-
Notifications
You must be signed in to change notification settings - Fork 0
/
mksdk-3.13
1787 lines (1680 loc) · 58.4 KB
/
mksdk-3.13
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#!/usr/bin/perl -w
use strict;
use File::Basename;
use Cwd;
use Net::FTP;
use Fcntl ':mode';
#
# Produces the SDK and stores it in the SCR. This is the preferred way
# to store the firmware source now; storing the whole .tar.gz was
# taking too much space and storing the patch was lossy.
#
# NOTE: This script assumes that once a file is deemed NDA that it
# will stay NDA. This is not necessarily the case, but it should
# be the norm. If a file changes status, the file will need to
# be manually moved to the GPL side. The opposite, GPL to NDA,
# could only happen in the rare case where we've released some
# of our code under the GPL and then re-released it under a
# different licence. I don't see that happening, and it wouldn't
# be very effective since the old version would remain GPL. So I
# don't think we need to worry about that case.
#
# NOTE: There are a number of places where identical code lives in two
# or more locations. In C, I'd use a macro since the code isn't
# heavy-weight enough to require a routine of its own (and the
# overhead of calling it). Perl doesn't have macros, yet. Perl 6
# is supposed to have them, so I've left the code as is for now.
# What this means is, if you're doing changes, make sure that
# you have changed *all* the locations. To make it easy, I'll
# tag the locations with MACRO X in a comment.
# Arg. Perl 6 has no ETA. I've moved some of the more egregious
# code into unclean (changes global variables instead of just
# using its parameters and returning values) routines.
#
# NOTE: This script assumes that the old tree is the original uClinux
# distribution. If that changes, the code will have to be
# rewritten to take that into account. Specfically the
# assumption that a file's presence in the old tree makes it GPL
# is widespread and will need to be handled appropriately.
#
# NOTE: There are lots of notes in this script. Some of them apply to
# multiple locations; I've only noted the first instance. Thus,
# this script is intended to be read top-to-bottom, in line
# number order. If you find something you don't understand, try
# searching for a previous instance of it; there will probably
# be a note.
#
# NOTE: The reason this script exists at all is that diff and patch do
# not handle all that is needed to be handled when one wants to
# create a patch for two file trees. I believe this is due to
# their being created originally for handling only simple one-
# directory hunks of source code, but that's just a guess.
# What follows is a hopefully complete list of things that this
# script handles because diff and patch do not. If you think of
# something and it's not listed here, please let the current
# author (see the History section) know because it's almost
# certainly not handled, and needs to be.
#
# - handling of any file type other than regular files and
# directories
# - new empty directories not created because no patch of file
# from under that directory
# - directories always or never deleted when last file under it
# is deleted
# - new empty files not created since there's no patch for that
# - permissions not preserved
#
# Global version string
my $version = "3.13";
my $date = "Aug 02 2006";
# Program's canonical name
my $this = basename($0);
#
# History
#
# 3.13 Aug 02 2006 stuartm
#
# Small speed up: $ftp->ls() now takes a file glob string, and returns
# only SDK filenames for processing. Less network transfer, quicker
# pattern matching in get_old_sdks().
#
# 3.12 Feb 10 2006 stuartm
#
# Added a missing error check for get_patch_level().
# Updated the code to handle both uClinux-<ver> and uClinux-<ver>-*.
# This makes doing an SDK re-generation much easier. Also, the code
# now prefers a nameless version over a named version, in case it's
# a re-gen of an SDK that still has a temp tree hanging around.
#
# 3.11 Jan 31 2006 stuartm
#
# Improved error path when $ftp->put() fails. Attempt to delete the
# file from the remote machine. More accurately report the error.
# It looks like $ftp->message relies on $!, because I got an "Error
# 0." message.
#
# 3.10 Nov 08 2005 stuartm
#
# Toolchain install option. SDK scripts now perform this as a separate
# step, plays better with the go script.
# Script rename: mksdk. Now named for what it actually does.
# Minor URL bugfix. URLs are supposed to have the trailing '/' and the
# URLs in the SDK scripts did not. Added.
#
# 3.09 Jul 09 2005 stuartm
#
# Toolchain root check. The user needs to be root to allow the uClinux
# toolchain to be installed.
# Moved the toolchain handling. Since it's only required to compile
# the source, moved it from the assembly section to the compile
# section.
# Moved the patch workaround. Since the workaround only applies to the
# assembly section, moved all the handling there.
#
# 3.08 Jul 02 2005 stuartm
#
# Workaround buggy patch(1)s. Patch 2.5.4 or less has a bug where the
# code that looks ahead to guess what kind of patch is coming next
# can read off the end of a buffer and segfault. To the end user,
# this appears like the SDK crashed. Bad. The workaround is simple
# enough; process each file-hunk one at a time so that code isn't
# ever run. This works in practice; I manually patched a number of
# the SDKs that were crashing, and they worked. Decided against
# having the SDK script automatically use the workaround if it's
# detected a buggy patch because the crashes are rare, and a new
# patch will be out someday that doesn't need this. Also, the
# workaround is much slower than the regular method.
# No more GPL-only. Removed the code that produces this. It's not
# needed to store in the SCR, just for posting on the website, and
# it's wasted space. Wrote a separate tool to generate the GPL-only
# from the regular SDK.
#
# 3.07 Jun 10 2005 stuartm
#
# SDK script bug. Running it twice would appear to work, but really
# create uClinux-<ver>/uClinux-dist, and the third run would fail.
# Fixed it to delete uClinux-<ver>.
#
# 3.06 Jun 10 2005 stuartm
#
# Only create/store the gpl-only tarball for the production tree.
# Anything else is assumed to be internal release only.
#
# 3.05 May 30 2005 stuartm
#
# Command line help for the SDK script. Added help.
# New command line options for the SDK script. Two options:
# -a assemble-only and -c compile-only. Assemble-only puts the
# firmware together but does not compile it as a verification step.
# Compile-only assumes the firmware is assembled and compiles it.
# The default is both operations. This was mostly to help with SDK
# testing, where I wanted to assemble the firmware, but not bother
# compiling it. Figured the end users might find this useful too.
# Scripts now have versioning. Decided to just make the scripts the
# same version as this program. Since the program's version will
# always be updated when changes happen to the SDK scripts, doing it
# this ways means I don't have to fuss with individual versions in
# the SDK scripts. This allows us to look at an end user's SDK and
# determine if they require a newer version of the SDK for the same
# firmware level; if a bug in the SDK scripts is fixed for example,
# which has already happened once.
#
# 3.04 May 27 2005 stuartm
#
# New licence option: Delete. This probably won't be useful in the
# future, but when I was regenerating the old SDKs from the patches
# I encountered a lot of vi swap files and tags files that weren't
# needed. The standard method was to quit, delete the file and start
# the SDK generation over again. This wastes a lot of effort and is
# really annoying. The delete option has been added. It "deletes"
# files by adding them to the *_del lists, which are never output.
# Deletion by ignoring. Delete does *not* affect the last licence
# type tracking. If it did it would be very easy to accidentally
# delete a lot of files. Note that while this deletes the file from
# the SDK-created firmware tree it does not actually delete it from
# the original source tree. This allows "undeletion" by restarting
# the SDK generation.
#
# 3.03 May 24 2005 stuartm
#
# Bug: When regenerating an old SDK (say, due to a bug in this script,
# see 3.02 below), a newer SDK was allowed to serve as a reference.
# Since the SDK was newer, the $noselfcan flag had no effect, and
# even if it had, it would have only gone back one SDK version, not
# enough to help the real world situation I encountered
# (regenerating the first of three SDKs). Newer SDKs should never
# serve as references, because it's too easy to get things wrong.
# Example: A file has changed function from NDA to GPL. Using the
# newer SDK as a reference, this file would be incorrectly labeled
# GPL instead of NDA in the regenerated SDK.
# Warning for ignored newer SDKs. Added this just in case, a typo in
# the -p flag perhaps. Includes a count of how many were skipped.
#
# 3.02 May 11 2005 stuartm
#
# Bug: SDK script wasn't unpacking the toolchain properly after cd'ing
# to the root directory. Good spot by Gareth.
#
# 3.01 Apr 17 2005 stuartm
#
# Bug: Wasn't checking that the tree-pruning in the "only in old tree"
# files processing was actually acting on a directory. This caused
# some files to get pruned that should have been processed.
# Bug: Updated the first "Building" dstamp message to more accurately
# reflect the build. In the production tree it now mentions the
# version number as well as the patch level.
#
# 3.00 Apr 11 2005 stuartm
#
# Third draft. Removed dependence on external find(1) with new find()
# subroutine. find(1) loses top-level .* files, or if you do
# 'find .*' it seems to go off to neverland.
# New SDK packaging; full and GPL-only.
# New architecture: one pass. Fixes some problems dealing with
# patch(1)'s foibles that the old multi-pass architecture had.
# Should also be faster. Also fixes a broken assumption the old code
# had: that anything that has changed needs to have its licence
# status queried. Not true; files in the original tree that have
# changed are still GPL. This was carried over from Gareth's code
# and he had it because at one point the script (IIRC) was supposed
# to work equally well to generate "SDKs" between versions of the
# firmware; v1.00 to v1.02 for instance. My usage doesn't need this,
# and the script is tons faster without it, mainly due to the
# reduction in the questions asked.
# Lots and lots of commenting added.
# The new architecture has the side effect that the querying of the
# user is now a lot slower, since it's doing all the diffing between
# queries instead of up front. I was annoyed at myself until I
# realised this is a feature: now it's a lot harder to get partway
# through the queries and accidentally hit enter and get the wrong
# licence type. Nice.
# New script design. All the commands and data for them are in one
# file, GPL or NDA as appropriate. The patch command extracts the
# patches from the script as it runs. Much cleaner encapsulation;
# less for the end user to screw up. Also, *all* comamnds are now
# in the appropriate GPL or NDA update script, making the overall
# SDK script shorter and cleaner.
# GPL and NDA scripts are now *not* executable. This is to prevent the
# end users from accidentally running one of them when they
# shouldn't. The scripts are executed from the SDK main script via a
# "sh <script>" line. This works quite nicely.
# Filenames are now handled in their entirety. Funky characters are
# properly escaped for appearance in the update scripts. diffs are
# done on escaped filenames so the diff doesn't bail with an odd
# error. Reference SDKs are processed and filenames are de-escaped
# as appropriate. The only exception is that patch cannot handle
# finding whitespace of any kind in a filename. If it does then it
# takes what it has so far as the filename to patch, and gets the
# wrong file. other characters are okay though. I know; I
# exhaustively tested this one weekend.
# Timing! The script now times its operation so that a nice report at
# the end of the run tells you how long the script was waiting for
# you to answer questions. Really I wanted to know how long it was
# taking the script to run, and to know that I had to subtract the
# wait-for-user-input time from the total time.
# No more tree-copying. The new layout/patch handling lended itself to
# a new method of removing the top-level filename, so I don't need
# the $tree_(old|new)_short trees anymore. I just substitute in the
# short names when I need them. This has significantly speeded the
# script up.
#
# 2.00 Mar 29 2005 stuartm
#
# Second draft. Rewrote to take make more use of my development setup
# primarily to allow easier ftp manuevering.
#
# 1.00 Mar 22 2005 stuartm
#
# First draft. This is partially based on the original mksrc util I'd
# written, and partially based on the SDK generation scripts Gareth
# had written.
#
#
# Tunable variables
#
# The SCR and its host machine
my $scr_host = "";
my $scr_user = "";
my $scr_password = "";
my $scr_srcdir = "";
#
# Variables required by "macros"
#
# When Perl 6 is released, the functions making use of these should be
# changed to macros, and the variables below should be returned to the
# main declaration area.
#
my ($tree_old_long, @files_old, $type_old, $perm_old, $link_old);
my ($tree_new_long, @files_new, $type_new, $perm_new, $link_new);
my @old_sdks;
my $old_sdk;
my (@sdk_gpl, @sdk_nda);
my @files_rm;
my ($files_ln, @files_ln_gpl, @files_ln_nda, @files_ln_del);
my ($files_chmod, @files_chmod_gpl, @files_chmod_nda, @files_chmod_del);
my ($files_mkdir, @files_mkdir_gpl, @files_mkdir_nda, @files_mkdir_del);
my ($files_patch, @files_patch_gpl, @files_patch_nda, @files_patch_del);
my ($files_touch, @files_touch_gpl, @files_touch_nda, @files_touch_del);
my ($qstart, $qtotal) = (undef, 0);
#
# Dealing with interpolation is always annoying. The following is the
# set of characters that must be escaped in filenames in unix. If they
# are not, the shell will interpret them, mangling the filename. For
# an rm command, this can be dangerous. Some of the characters are
# standard escaped characters, \n and \t. The " $ @ \ characters must
# all be escaped here as well, to counter the interpolation of the
# double-quoted string at the Perl level.
#
my $unix_esc_chars = "\t\n !\"\$&'()*:;<=>?\@[\\`{|";
#
# Functions
#
# Print a message with a datestamp
sub dstamp {
print localtime() . " @_";
}
# Discover the highest patch level of firmware in the current directory
sub get_patch_level {
my $tmp_level;
my $patch_level = 0;
while (<uClinux-[0-9]*>) {
#
# Unfortunately the -d operator follows links so we first have to
# rule out a link explicitly.
#
if (! -l && -d) {
($tmp_level) = /uClinux-([0-9]+)/;
if (defined($tmp_level) && ($tmp_level > $patch_level)) {
$patch_level = $tmp_level;
}
}
}
return $patch_level;
}
# Retrieve the firmware version from within the tree
sub get_firmware_version {
my $tree = shift;
my $makefile = "$tree/vendors/vendor/product/Makefile";
my $firmware_version;
open(MAKEFILE, $makefile);
while (<MAKEFILE>) {
#
# NOTE: [:space:] is a *superset* of the \s set. See perlre.
#
if (/^[[:space:]]*BHNRELEASE[[:space:]]*=[[:space:]]*([0-9]+\.[0-9]+)/) {
$firmware_version = $1;
last;
}
}
close(MAKEFILE);
if (!defined($firmware_version)) {
die "$this: Error: Couldn't determine firmware version from '$makefile'\n";
}
return $firmware_version;
}
# Start the FTP connection
sub start_ftp {
my $ftp;
if (!($ftp = Net::FTP->new($scr_host))) {
warn "$this: Error: Couldn't connect to '$scr_host'\n";
die "$this: Error: $@\n";
}
if (!$ftp->login($scr_user, $scr_password)) {
warn "$this: Error: Couldn't login to '$scr_host'\n";
die "$this: Error: " . $ftp->message;
}
if (!$ftp->binary()) {
warn "$this: Error: Couldn't set binary mode on '$scr_host'\n";
die "$this: Error: " . $ftp->message;
}
if (!$ftp->cwd($scr_srcdir)) {
warn "$this: Error: Couldn't cd to '$scr_srcdir'\n";
die "$this: Error: " . $ftp->message;
}
return $ftp;
}
# Discover the SDKs available, return the list highest to lowest
sub get_old_sdks {
my @patch_levels;
for (@_) {
if (/^uClinux-([0-9\.]+)\.sdk\.tar\.gz$/) {
push @patch_levels, $1;
}
}
return sort { $b <=> $a } @patch_levels;
}
# find(1) rewritten in perl. Note: recursive, depth-first.
sub find {
my $dir = shift;
my $fullpath;
my @files;
my @subfiles;
if (!(opendir DIR, $dir)) {
warn "$this: Error: Couldn't open '$dir'\n";
die "$this: Error: $!\n";
}
for (readdir DIR) {
if (/^\.\.?$/) {
next;
}
push @files, $_;
$fullpath = $dir . "/" . $_;
if ((! -l $fullpath) && (-d $fullpath)) {
@subfiles = find($fullpath);
while (@subfiles) {
push @files, $_ . "/" . shift @subfiles;
}
}
}
closedir DIR;
return @files;
}
#
# Determine an "only in the new tree" file's GPL or NDA status
#
# The odd bracing is to create a local to the routine C-style static
# variable; see perlsub.
#
{
my $last_type = "gpl";
my $last_nda_file;
sub set_gplnda {
my $file = shift;
my $type = "ask";
my @indexes;
my $old_block;
my $fullpath;
if ($old_sdk) {
#
# The following grep() idiom works like this: loop over all the
# possible indexes of the array, binding the actual array value
# to a search for the item in question. grep then returns a
# list of the looped-over items that the expressions was true
# for, that is, a list of all the indexes of matching lines.
#
# This one is tricky; take a few minutes.
#
# The \Q and \E turn off regex metacharacters between them, so
# those sorts of characters in the filename we're trying to
# match don't affect the regex. (Think preventing an SQL
# injection attack.)
#
@indexes = grep(($sdk_gpl[$_] =~ /^\Q$file\E$/), 0..$#sdk_gpl);
if (@indexes) {
$type = "gpl";
#
# Remove the matched item from the array. Since they are unique
# once it's matched it will never match again, and just slow
# down further lookups.
#
# A simple shift might seem like it would suffice, especially
# as the lists are sorted, except that the lists are generated
# from the chmod commands in the old SDK scripts and more than
# just the "only in the new tree" files get chmoded.
#
splice(@sdk_gpl, $indexes[0], 1);
} else {
@indexes = grep(($sdk_nda[$_] =~ /^\Q$file\E$/), 0..$#sdk_nda);
if (@indexes) {
$type = "nda";
splice(@sdk_nda, $indexes[0], 1);
}
}
}
while ($type eq "ask") {
#
# This is apparently how one flushes STDIN in Perl. Annoying but
# true. HANDLE->flush() only flushes the output side.
#
$old_block = STDIN->blocking(0);
while (<STDIN>) {};
STDIN->blocking($old_block);
print "$file, (g)pl, (n)da or (D)el [$last_type]? ";
$qstart = time();
chomp($type = <STDIN>);
$qtotal += (time() - $qstart);
if ($type eq "g") {
$type = "gpl";
} elsif ($type eq "n") {
$type = "nda";
} elsif ($type eq "D") {
$type = "del";
} elsif ($type eq "") {
$type = $last_type;
} else {
$type = "ask";
}
}
#
# This is a bit of niceness. When answering questions, the code
# remembers your last answer and assumes that as a default. This
# generally works because the files, GPL or NDA, tend to group. So
# there'll be a bunch of GPL, bunch of NDA, bunch of GPL. To say
# that another way, the number of licence status transitions are
# naturally minimal. So far, nothing special, right?
#
# This code is invoked for all files, including the ones that
# don't require a question to the user. This also might not sound
# like much, it's necessary after all, but the effect is that the
# last licence status is tracked, not the last answer. When
# creating a new SDK with an old reference SDK this tracking will
# appear to correctly guess the default for the licence status in
# question! ie When one new file has been added to the NDA
# section, since the previous status was NDA, then the default for
# the single new file is NDA, which happens to be correct. Again,
# this is due to the grouping of the licence types, but it's not
# obvious. It may confuse someone down the road when the program
# is given too much credit for being smart, but the code
# responsible for heuristically guessing the licence status can't
# be found. The final piece of this trick is that the $last_type
# variable is initialised to GPL. This is due to the fact that the
# file list is processed in sorted order, and the first file is
# generally a file in the top level of the uClinux distribution,
# which is GPL.
#
# Except we never want to remember the delete "licence", so retain
# the previous licence type.
#
if ($type ne "del") {
$last_type = $type;
}
if ($type eq "gpl") {
#
# The use of one pointer to refer to the GPL or NDA actual lists
# made the code in the diffing section cleaner and easier to
# read.
#
$files_ln = \@files_ln_gpl;
$files_chmod = \@files_chmod_gpl;
$files_mkdir = \@files_mkdir_gpl;
$files_patch = \@files_patch_gpl;
$files_touch = \@files_touch_gpl;
#
# Generally one can't have a GPL file of any type if one of the
# parent directories is NDA. This is because the creation of
# that directory will happen second, in the NDA update, but the
# GPL file will need it to happen first, in the GPL update.
# Yes it would be very easy to simply switch the declaration of
# the parent directories, or to make everything under the NDA
# directory automatically NDA, but I didn't do that. I figure if
# you're trying to decelare this particular chain of files, then
# you don't realise that you've got other bigger problems, and
# you need the error to force yourself to look at the situation.
#
if ($last_nda_file && ($file =~ /^\Q$last_nda_file\E/)) {
warn "$this: Error: Bad GPL declaration. '$last_nda_file'\n";
warn "$this: Error: previously declared NDA. If this was allowed it\n";
die "$this: Error: would produce SDK scripts that don't work.\n";
}
} elsif ($type eq "nda") {
$files_ln = \@files_ln_nda;
$files_chmod = \@files_chmod_nda;
$files_mkdir = \@files_mkdir_nda;
$files_patch = \@files_patch_nda;
$files_touch = \@files_touch_nda;
$fullpath = "$tree_new_long/$file";
if (((! -l $fullpath) && (-d $fullpath)) &&
!($last_nda_file && ($file =~ /^\Q$last_nda_file\E/))) {
$last_nda_file = $file;
}
} else {
$files_ln = \@files_ln_del;
$files_chmod = \@files_chmod_del;
$files_mkdir = \@files_mkdir_del;
$files_patch = \@files_patch_del;
$files_touch = \@files_touch_del;
}
}
}
# Type TO String; translates a file's type to a readable string
sub ttos {
my $type = shift;
if ($type == S_IFBLK) {
return "block device";
} elsif ($type == S_IFCHR) {
return "character device";
} elsif ($type == S_IFDIR) {
return "directory";
} elsif ($type == S_IFREG) {
return "file";
} elsif ($type == S_IFLNK) {
return "link";
} elsif ($type == S_IFIFO) {
return "fifo";
} elsif ($type == S_IFSOCK) {
return "socket";
}
}
# system() a command, and check the return status
sub do_system {
my $exit_code;
system(@_);
if ($? == -1) {
die "$this: Error: Couldn't execute '@_'\n";
} elsif ($? & 127) {
die "$this: Error: Exit on signal for '@_'\n";
} elsif ($?) {
$exit_code = ($? >> 8);
if ($exit_code) {
die "$this: Error: Bad exit ($exit_code) for '@_'\n";
}
}
}
# Escape a filename
sub esc {
if (defined($_[0])) {
#
# The \Q \E is critical around the character set variable;
# otherwise the set is interpolated, and the \ will be dropped as
# escaping whatever follows it.
#
if ($_[0] =~ /[\Q$unix_esc_chars\E]/) {
#
# Search for all 's in the string and escape them with
# backslashes.
#
$_[0] =~ s/'/\\'/g;
#
# This one's tricker:
# ( - make a capture/group
# (?: - make a group without making a capture
# [^'\\] - match a class consisting of *not* a single
# quote or backslash
# | - or (of the non-capture group)
# \\ - match a backslash...
# (?!') - *not* followed by a single quote; see perlre
# ) - close the non-capture group
# + - match one or more of the non-capture group
# ) - close the capture group
#
# This should match all sequences of text that's not the escaped
# single quotes generated by the previous s///, and enclose them
# in single quotes.
#
$_[0] =~ s/((?:[^'\\]|\\(?!'))+)/'$1'/g;
}
} else {
if (/[\Q$unix_esc_chars\E]/) {
s/'/\\'/g;
s/((?:[^'\\]|\\(?!'))+)/'$1'/g;
}
}
}
# Unescape a filename
sub unesc {
if (defined($_[0])) {
#
# The presence of a single quote means the filename has been
# escaped, since the single quote is the escape-mechanism.
#
if ($_[0] =~ /'/) {
#
# (?<!\\) - whatever matches must not have been preceded by a
# backslash
# ' - match a single quote (not following a backslash)
#
# Delete all non-escaped single quotes; this is the inverse of
# the last s/// in esc().
#
$_[0] =~ s/(?<!\\)'//g;
#
# Unescape all the escaped single quotes. This is the inverse of
# the first s/// in esc().
#
$_[0] =~ s/\\'/'/g;
}
} else {
if (/'/) {
s/(?<!\\)'//g;
s/\\'/'/g;
}
}
}
# Prettify the time
sub pretty_time {
my $time = shift;
my ($days, $hours, $mins, $secs);
$days = sprintf("%4d", ($time / (24 * 60 * 60)) % (24 * 60 * 60));
$hours = sprintf("%02d", ($time / (60 * 60)) % (60 * 60));
$mins = sprintf("%02d", ($time / 60) % 60);
$secs = sprintf("%02d", $time % 60);
return ($days, $hours, $mins, $secs);
}
#
# "Macros"
#
# Variables that should really be macros. When Perl 6 comes out...
#
my $noselfcan = "-o";
#
# Main
#
my $patch_level;
my $use_older_sdk = 0;
my $ignored_sdks = 0;
my $tree_type;
my ($start, $end);
my $target_level;
my $tree_new_short;
my $ftp;
my ($diff_old, $diff_new);
my $cmd_diff = "diff -Nau";
my $cmd_rm = "rm -rf";
my $cmd_ln = "ln -s";
my $cmd_mkdir = "mkdir -p";
my $cmd_chmod = "chmod";
#
# The default for the -p option is -p<max> instead of -p0. grr.
#
my $cmd_patch = "patch -p0";
my $cmd_touch = "touch";
my @patch_lines;
my ($total_time, $script_time);
my ($days, $hours, $minutes, $seconds);
my $message;
my $i;
while (@ARGV) {
$_ = shift;
if (/^-h$/) {
#
# Perl's version of the here document. Works just like the shell's
# version. Makes some code much easier to read.
#
print <<END;
$this v$version $date
$this -h
$this [$noselfcan] [-p <level>]
-h Help
$noselfcan Use the second oldest SDK for guidance. Avoids self-cannibalism.
-p The patch level of the source tree to prepare. If not specified
defaults to the most recent patch level available.
END
exit 0;
} elsif (/^-p$/) {
if (!@ARGV) {
warn "$this: Error: Option '-p' missing argument <level>\n";
die "'$this -h' for help.\n";
}
$patch_level = shift;
} elsif (/^$noselfcan$/) {
$use_older_sdk = 1;
} else {
warn "$this: Error: Bad option '$_'.\n";
die "'$this -h' for help.\n";
}
}
#
# I'd like to do something about the LTS in this regex, but any non-
# slash delimiter screws up vim's syntax highlighting. grr. Please
# leave this as it is.
#
($tree_type) = (cwd() =~ /\/firm\/([^\/]+)/);
if (!defined($tree_type)) {
die "$this: Error: Unable to determine firmware tree type\n";
}
chdir "/firm/$tree_type";
if (!defined($patch_level)) {
$patch_level = get_patch_level();
if (!$patch_level) {
die "$this: Error: Couldn't find any firmware\n";
}
}
#
# When redoing the SDKs due to a mksdk update, the generated trees
# have no name tag. So check for the no-name tree first.
#
$tree_old_long = "uClinux-0";
if (! -d $tree_old_long) {
$tree_old_long = glob("uClinux-0-*");
if (!defined($tree_old_long)) {
die "$this: Error: No original uClinux tree present\n";
}
}
$tree_new_long = "uClinux-$patch_level";
if (! -d $tree_new_long) {
$tree_new_long = glob("uClinux-$patch_level-*");
#
# If the firmware can't be found, probably it was specified on the
# command line. It's possible that between the get_patch_level() call
# and the glob() that the firmware was erased, but that's highly
# unlikely. Hence the wording of the error message.
#
if (!defined($tree_new_long)) {
die "$this: Error: Couldn't find specified firmware version '$patch_level'\n";
}
}
$start = time();
#
# The tree type determines where in the SCR to put the finished SDK,
# and what version numbering to use.
#
if ($tree_type eq "prod") {
$target_level = get_firmware_version($tree_new_long);
dstamp "Building SDK for firmware $target_level ($patch_level)...\n";
} elsif ($tree_type eq "stu") {
$target_level = $patch_level;
$scr_srcdir .= "/$tree_type";
dstamp "Building SDK for firmware $patch_level...\n";
} else {
warn "$this: Error: Unknown firmware tree type '$tree_type'\n";
die "$this: Error: Please update me.\n";
}
$tree_new_short = "uClinux-$target_level";
# Load the old SDK if possible
dstamp "Checking for old SDKs...\n";
$ftp = start_ftp();
@old_sdks = get_old_sdks($ftp->ls("uClinux-*.sdk.tar.gz"));
$old_sdk = shift @old_sdks;
# Never use a newer SDK as a reference for an old SDK
while ($old_sdk && ($old_sdk > $target_level)) {
$old_sdk = shift @old_sdks;
$ignored_sdks++;
}
if ($ignored_sdks) {
warn "$this: Warning: Ignored $ignored_sdks newer SDK" .
($ignored_sdks > 1 ? "s" : "") . "\n";
}
if ($old_sdk && ($old_sdk == $target_level)) {
if ($use_older_sdk) {
#
# This shift can cause $old_sdk to be undefined again; hence this
# if statement can't be moved into the main if statement below.
#
$old_sdk = shift @old_sdks;
} else {
warn "$this: Warning: Self-cannibalism detected. Old SDK is $old_sdk, " .
"build is $target_level.\n";
warn "$this: Warning: This probably isn't what you wanted; try the " .
"$noselfcan flag.\n";
}
}
if ($old_sdk) {
dstamp "Loading old SDK $old_sdk...\n";
if (!$ftp->get("uClinux-$old_sdk.sdk.tar.gz")) {
warn "$this: Error: Couldn't get 'uClinux-$old_sdk.sdk.tar.gz'\n";
die "$this: Error: " . $ftp->message;
}
do_system("gunzip < uClinux-$old_sdk.sdk.tar.gz | tar xf -");
#
# Only files that are only in the new tree have the option of being
# GPL or NDA. Common files were in the old tree, as well as files
# only in the old tree, and they are all GPL by definition. Since we
# always chmod the new files; it is sufficient to grep in only the
# chmod commands to get a complete reference from the old SDK.
#
# The first grep gets all the matching lines from the file, and the
# for loop extracts the filename from each line.
#
open SDK_GPL, "uClinux-$old_sdk.gpl";
open SDK_NDA, "uClinux-$old_sdk.nda";
chomp(@sdk_gpl = grep(/^\Q$cmd_chmod\E/, <SDK_GPL>));
chomp(@sdk_nda = grep(/^\Q$cmd_chmod\E/, <SDK_NDA>));
close SDK_GPL;
close SDK_NDA;
for (@sdk_gpl, @sdk_nda) {
#
# [0-7]{1,4} is an accurate regex for the octal mode value. The
# file could have as little as only other permissions set (one
# digit) or have the setuid bit set (four digits).
#
# ( - start the capture group
# (?: - start a non-capture group
# \\' - match an escaped single quote
# | - or (non-capture group)
# ' - match a single quote...
# [^']+ - followed by a string of non-single quotes...
# ' - followed by a single quote
# (?!') - this match may not be followed by a single
# quote; see perlre
# ) - end group
# + - one or more of the groups; this represents
# an escaped filename
# | - or (capture group)
# [^'[:space:]]+ - a sequence of non-spaces or -single-quotes;
# this represents an unescaped filename
# ) - end capture group
#
# There's a small or (|) and a big or; the small one matches parts
# of an escaped filename to make a whole filename, and the large
# one matches either an escaped filename or an unescaped filename.
# The whole in is then replaced with only the matched filename.
#
s/^\Q$cmd_chmod\E [0-7]{1,4} ((?:\\'|'[^']+'(?!'))+|[^'[:space:]]+).*$/$1/;
#
# And unescape. unesc knows to leave non-escaped filenames as is.
#
unesc;
}
} elsif ($use_older_sdk) {
dstamp "No second oldest SDK. Queens, lots of queens...\n";
} else {
dstamp "Old SDK not found. Questions, lots of questions...\n";
}
#
# In the time it takes to run the script, there's lots of things that
# could go wrong with the connection. It would be slightly faster to
# leave it up, but it's more robust to take it down and bring it up
# later.
#
$ftp->quit();
dstamp "Generating file lists...\n";
@files_old = sort(find($tree_old_long));
@files_new = sort(find($tree_new_long));
dstamp "Diffing trees...\n";
#
# The overview of the following loop is:
# if (only in old) {
# } elsif (only in new) {
# } else (common to both) {
# }
#
# This is the behaviour of comm(1). In previous versions of this
# script the loop was limited to merely separating the files into the
# three classes. This version expands the loop to do the diffing as
# well, making it a one-pass system. In really old versions we tried
# to leverage comm for this task, but that's no longer possible with
# the extra diffing work.
#
while (@files_old && @files_new) {
if ($files_old[0] lt $files_new[0]) {
#
# Files only in the original distribution. Remove them.
#
# Files only in the old tree are always GPL, since the original
# uClinux tree is GPL and we can't logically be removing files
# from the new tree. (That would be making the patch in the
# reverse direction.)
#
# MACRO A start
push @files_rm, shift @files_old;
#
# An 'rm -rf' is sufficient to remove a whole tree of files. To
# avoid producing useless removes for all of the contents of such
# a tree, remove the rest of the tree from the files list. This
# depends on the files list being sorted, which it is.
#
# The [-1] notation is a regular array index, if unusual. The
# negative sign allows one to reference from the end of the array.
# So -1 is the index of the last element in the array.
#
if ((! -l $files_rm[-1]) && (-d $files_rm[-1])) {
while ((@files_old) && ($files_old[0] =~ /^\Q$files_rm[-1]\E/)) {
shift @files_old;
}
}
# MACRO A end
} elsif ($files_new[0] lt $files_old[0]) {