atoms_cc/buildtoolbox.pl: cosmetics + get it working on windows (if it looks like...
[scilab.git] / atoms_cc / buildtoolbox.pl
1 #!/usr/bin/perl -w
2
3 # buildtoolbox.pl
4 # Usage: buildtoolbox.pl toolbox-archive [config file [stage]]
5
6 use strict;
7 use Cwd;
8
9 my ($TOOLBOXFILE, # Toolbox archive to compile
10     $TOOLBOXNAME, # Name of the toolbox
11     $STAGE); # Current stage
12
13 # common_log:
14 #    Print a log message. Seconf argument is the type of the
15 #    message:
16 #     " " for a normal message
17 #     "!" for an error
18 #     ">" when starting a stage
19 #     "<" when terminating a stage
20 #     "$" when running a command
21 #     "?" for the return code of previous command
22 sub common_log {
23         my $message = shift;
24         my $type = shift || " ";
25         
26         # Check message format: any newline must start by a space,
27         # no new line at end of message
28         $message =~ s/(?<=\n)(?!\s|$)/ /g;
29         chomp $message;
30         
31         print LOGFILE "[".time()."]${type}${message}\n";
32 }
33
34 # common_enter_stage:
35 #    Common stuff while starting a new stage
36 sub common_enter_stage {
37         $STAGE = shift;
38         common_log($STAGE, ">");
39 }
40
41 # common_leave_stage:
42 #    Common stuff while ending new stage
43 sub common_leave_stage {
44         common_log($STAGE, "<");
45 }
46
47 # common_die:
48 #    Called when a problem happens
49 sub common_die {
50         my $message = shift;
51         common_log($message, "!");
52         common_leave_stage();
53         
54         while(wait() > 0) { };
55         close LOGFILE;
56         exit(1);
57 }
58
59 # common_exec:
60 #    Execute given command, places its outputs to log files.
61 #    Returns a file handle on STDOUT
62 #    Die if return code is non-zero
63 sub common_exec {
64         my $cmd = shift;
65         my $commandnum = 1;
66         
67         # Find commandnum: log files are (stage)-1.out for first
68         # command of (stage), (stage)-2.out for second command of stage,
69         # and so on
70         $commandnum++ while(-e "$STAGE-$commandnum.out");
71         
72         my $stdout = "$STAGE-$commandnum.out";
73         my $stderr = "$STAGE-$commandnum.err";
74         
75         common_log("$cmd\nstdout=$stdout\nstderr=$stderr", "\$");
76         
77         my $pid = fork();
78         if($pid == 0) {
79                 open STDOUT, ">$stdout";
80                 open STDERR, ">$stderr";
81                 exec $cmd;
82         }
83         else {
84                 waitpid($pid, 0);
85                 common_log("$?", "?");
86                 if($? != 0) {
87                         common_die("\"$cmd\" failed");
88                 }
89         }
90         
91         open my ($fd), $stdout;
92         
93         return $fd;
94 }
95
96 # is_zip:
97 #    Return true if toolbox file extension is zip
98 sub is_zip {
99         return $TOOLBOXFILE =~ /\.zip$/;
100 }
101
102 # get_tree_from_tgz:
103 #   Get all files (names) of the compressed (in tar.gz) sources
104 sub get_tree_from_tgz {
105         my %files;
106         
107         my $fd = common_exec("zcat ${TOOLBOXFILE} | tar -t");
108         
109         while(<$fd>) {
110                 chomp;
111                 $files{$_} = 1;
112         }
113         
114         close $fd;
115         return %files;
116 }
117
118 # get_tree_from_zip:
119 #   Get all files (names) of the compressed (in zip) sources
120 sub get_tree_from_zip {
121         my (%files, $line);
122         
123         # tail & head are here to skip header & footer
124         my $fd = common_exec("unzip -l ${TOOLBOXFILE}");
125         
126         while(<$fd>) {
127                 if(((/^\s*-+/)...(/^\s*-+/)) && !/^\s*-+/) { # Delete header & footer
128                         # zip output format: size date time filename
129                         /\s*\d+\s+\d+-\d+-\d+\s+\d+:\d+\s+(.+)/ or common_die "Bad output of unzip";
130                         chomp $1;
131                         $files{$1} = 1;
132                 }
133         }
134         
135         close $fd;
136         return %files;
137 }
138
139 # get_tree:
140 #   Get all files (names) of the compressed sources, in a hash
141 #   (hash values are meaningless, set to 1)
142 sub get_tree {
143         if(is_zip()) {
144                 return get_tree_from_zip();
145         }
146         else {
147                 return get_tree_from_tgz();
148         }
149 }
150
151 # read_file_from_tgz:
152 #    Extract given file from the .zip archive
153 sub read_file_from_tgz {
154         my $filename = shift;
155         return common_exec("zcat ${TOOLBOXFILE} | tar -xO ${TOOLBOXNAME}/$filename");
156 }
157
158 # read_file_from_tgz:
159 #    Extract given file from the .tar.gz archive
160 sub read_file_from_zip {
161         my $filename = shift;
162         return common_exec("unzip -p ${TOOLBOXFILE} ${TOOLBOXNAME}/$filename");
163 }
164
165 # read_file_from_archive:
166 #   Extract given file from the archive
167 sub read_file_from_archive {
168         if(is_zip()) {
169                 return read_file_from_zip(@_);
170         }
171         else {
172                 return read_file_from_tgz(@_);
173         }
174 }
175
176 # read_description:
177 #   Check if DESCRIPTION file is correct, and parse it (return a hash
178 #   field => value).
179 #   First argument is a file descriptor for the DESCRIPTION file (see
180 #   get_description)
181 sub read_description {
182         my $fd = shift;
183         my @required = qw(Toolbox Version Title Author Maintainer
184                           Description License Category);
185         my @optional = qw(Date Depends URL Entity);
186         my (%infos, $key, $val);
187         my (%lines, %correct);
188         
189         # Populate hash
190         while(<$fd>) {
191                 common_die "\":\" not followed by a space at line $." if(/:(?! )/);
192                 if(/:/) { # New field
193                         ($key, $val) = split(/: /, $_, 2);
194                         $infos{$key} = $val;
195                         $lines{$key} = $.;
196                         $correct{$key} = 0;
197                 }
198                 else { # Continuation of previous field
199                         $infos{$key} .= $_;
200                 }
201         }
202         
203         # Check presence of required fields, mark them as correct
204         foreach (@required) {
205                 if(!defined($infos{$_})) {
206                         common_die "Mandatory field \"$_\" not defined";
207                 }
208                 else {
209                         $correct{$_} = 1;
210                 }
211         }
212         
213         # Mark optional fields as correct
214         foreach (@optional) {
215                 if(defined($infos{$_})) {
216                         $correct{$_} = 1;
217                 }
218         }
219         
220         # Check that there's no incorrect (= unknown) fields
221         foreach (keys(%infos)) {
222                 if($correct{$_} == 0) {
223                         common_die "Unknown field \"$_\" (defined at line $lines{$_})";
224                 }
225         }
226         
227         chomp %infos;
228         return %infos;
229 }
230
231 # read_description_functions:
232 #   Parse DESCRIPTION-FUNCTIONS file (and check it, too). Like DESCRIPTION,
233 #   first argument is a file descriptor. Returns a hash function name =>
234 #   function description
235 sub read_description_functions {
236         my $fd = shift;
237         my (%funcs, $func, $desc);
238         
239         while(<$fd>) {
240                 if(/-/ && !/ - /) {
241                         common_die "\"-\" not surrounded by spaces at line $.";
242                 }
243                 
244                 if(/-/) { # New field
245                         ($func, $desc) = split(/ - /, $_, 2);
246                         $funcs{$func} = $desc;
247                 }
248                 else { # Previous function description continuation
249                         $funcs{$func} .= $_;
250                 }
251         }
252         
253         chomp %funcs;
254         
255         return %funcs;
256 }
257
258 # check_tree:
259 #   Given a source tree of a toolbox (see get_tree), check if it is correct
260 #   (required files are present, files are at their right place, and so on...)
261 sub check_tree {
262         my %tree = @_;
263         my %newtree;
264         
265         # Check that all files are under a root which has the same name as the toolbox
266         # Delete this root to simplify other tests
267         foreach (keys %tree) {
268                 if(s#^\Q$TOOLBOXNAME\E(/|$)##) {
269                         $newtree{$_} = 1 if $_;
270                 }
271                 else {
272                         common_die "Incorrect archive: \"$_\" is not a child of \"$TOOLBOXNAME\"";
273                 }
274         }
275         %tree = %newtree;
276         
277         # Check that basic files are here
278         my @required = qw(DESCRIPTION DESCRIPTION-FUNCTIONS readme.txt license.txt
279                           builder.sce loader.sce);
280         push(@required, "etc/$TOOLBOXNAME.start");
281         push(@required, "etc/$TOOLBOXNAME.end");
282         
283         foreach (@required) {
284                 if(!defined($tree{$_})) {
285                         common_die "Incorrect archive: required file \"$_\" not present";
286                 }
287         }
288         
289         # macros/ must contain only .sci and .sce files
290         foreach (grep { $_ =~ m#^macros/# } keys %tree) {
291                 if(!/(\.sc[ie]|\/)$/) {
292                         common_die "Incorrect archive: macros/ must contain only .sci and .sce files".
293                             " (\"$_\" found)";
294                 }
295         }
296         
297         # All fortran files must be in src/fortran
298         foreach (grep { $_ =~ /\.f$/} keys %tree) {
299                 if(!m#^src/fortran/#) {
300                         common_die "Incorrect archive: \"$_\" is a fortran source and hence has to be in ".
301                             "src/fortran";
302                 }
303         }
304
305         # All c files must be in src/c or sci_gateway/{c,fortran}
306         foreach (grep { $_ =~ /\.[ch]$/} keys %tree) {
307                 if(!m#^(src/c|sci_gateway/(c|fortran))/#) {
308                         common_die "Incorrect archive: \"$_\" is a C source and hence has to be in ".
309                             "src/c, sci_gateway/c or sci_gateway/fortran";
310                 }
311         }
312         
313         # Constraints: if $key exists, $constraints{$key} must exist
314         my %constraints = (
315                 qr#help/.+\.xml$# => "help/buildhelp.sce",
316                 qr#macros/.+\.sc[ie]$# => "macros/buildmacros.sce");
317         
318         # Build constraints for allowed languages
319         my %languages = (
320                 "c" => qr/[ch]/,
321                 "fortran" => qr/f/);
322         
323         foreach (keys %languages) {
324                 # if src/(lang) has source files, src/(lang)/buildsrc_(lang).sce must exist
325                 $constraints{qr#^src/$_/.+\.$languages{$_}$#} = "src/$_/buildsrc_$_.sce";
326                 
327                 # if sci_gateway/(lang) has C sources, sci_gateway/(lang)/buildgateway_(lang).sce
328                 # must exist
329                 $constraints{qr#^sci_gateway/$_/.+[ch]$#} = "sci_gateway/$_/buildgateway_$_.sce";
330                 
331                 # if src/(lang)/buildsrc_(lang).sce exist, src/buildsrc.sce must exist
332                 $constraints{qr#^src/$_/buildsrc_$_.sce$#} = "src/buildsrc.sce";
333                 
334                 # if sci_gateway/(lang)/buildgateway_(lang).sce exist, sci_gateway/buildgateway.sce must exist
335                 $constraints{qr#^sci_gateway/$_/buildgateway_$_.sce$#} = "sci_gateway/buildgateway.sce";
336         }
337         
338         # Check constraints
339         foreach my $constraint (keys %constraints) {
340                 my $required = $constraints{$constraint};
341                 my @found = grep { $_ =~ $constraint } keys %tree;
342                 if(@found && !defined($tree{$required})) {
343                         common_die "Invalid archive: \"$found[0]\" needs \"$required\", which isn't in the archive";
344                 }
345         }
346 }
347
348 # stage_check:
349 #   Perform basic checks
350 sub stage_check {
351         common_enter_stage("check");
352         
353         if(is_zip()) {
354                 common_log("Detected ZIP format");
355         }
356         else {
357                 common_log("Detected TAR+GZIP format");
358         }
359         
360         # Check tree
361         common_log("Checking archive structure");
362         my %tree = get_tree();
363         common_log("Archive files:\n" . join("\n", sort keys %tree));
364         check_tree(%tree);
365         
366         # Check DESCRIPTION
367         common_log("Checking DESCRIPTION");
368         my $fd = read_file_from_archive("DESCRIPTION");
369         my %desc = read_description($fd);
370         common_log("Computed DESCRIPTION:\n" .
371                 join("\n", map { "$_: $desc{$_}" } sort keys %desc));
372         
373         # Check toolbox name
374         if($TOOLBOXNAME ne $desc{"Toolbox"}) {
375                 common_die "Detected toolbox name ($TOOLBOXNAME) different from ".
376                     "DESCRIPTION version ($desc{Toolbox})";
377         }
378         
379         # Check version
380         my $version = $1 if ($TOOLBOXFILE =~ /[^.]+\.([^-]+)/);
381         if(!defined($version)) {
382                 common_die "Can't detect version from archive name ($TOOLBOXFILE)";
383         }
384         
385         if($version ne $desc{"Version"}) {
386                 common_die "Detected version ($version) different from DESCRIPTION ".
387                     "version ($desc{Version})";
388         }
389         
390         # Check DESCRIPTION-FUNCTIONS
391         common_log("Checking DESCRIPTION-FUNCTIONS");
392         $fd = read_file_from_archive("DESCRIPTION-FUNCTIONS");
393         my %funcs = read_description_functions($fd);
394         common_log("Computed DESCRIPTION-FUNCTIONS:\n" .
395                 join("\n", map { "$_: $funcs{$_}" } sort keys %funcs));
396         
397         common_leave_stage("check");
398 }
399
400 # Init global vars, check arguments
401 $TOOLBOXFILE = shift;
402 if(!defined($TOOLBOXFILE)) {
403         common_die "Toolbox source file required";
404 }
405
406 if(! -r $TOOLBOXFILE) {
407         common_die "$TOOLBOXFILE doesn't exists or can't be read";
408 }
409
410 $TOOLBOXNAME = $1 if ($TOOLBOXFILE =~ /^([^.]+)/);
411
412 open LOGFILE, ">build.log";
413
414 common_log "Toolbox: $TOOLBOXNAME";
415 common_log "Source file: $TOOLBOXFILE";
416
417 stage_check;
418
419 close LOGFILE;