atoms_cc/buildtoolbox.pl:
[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         print "[$type] $message \n";
33 }
34
35 # common_enter_stage:
36 #    Common stuff while starting a new stage
37 sub common_enter_stage {
38         $STAGE = shift;
39         common_log($STAGE, ">");
40 }
41
42 # common_leave_stage:
43 #    Common stuff while ending new stage
44 sub common_leave_stage {
45         common_log($STAGE, "<");
46 }
47
48 # common_die:
49 #    Called when a problem happens
50 sub common_die {
51         my $message = shift;
52         common_log($message, "!");
53         common_leave_stage();
54         
55         while(wait() > 0) { };
56         close LOGFILE;
57         exit(1);
58 }
59
60 # common_exec:
61 #    Execute given command, places its outputs to log files.
62 #    Returns a file handle on STDOUT
63 #    Die if return code is non-zero
64 sub common_exec {
65         my $cmd = shift;
66         my $commandnum = 1;
67         
68         # Find commandnum: log files are (stage)-1.out for first
69         # command of (stage), (stage)-2.out for second command of stage,
70         # and so on
71         $commandnum++ while(-e "$STAGE-$commandnum.out");
72         
73         my $stdout = "$STAGE-$commandnum.out";
74         my $stderr = "$STAGE-$commandnum.err";
75         
76         common_log("$cmd\nstdout=$stdout\nstderr=$stderr", "\$");
77         
78         my $pid = fork();
79         if($pid == 0) {
80                 open STDOUT, ">$stdout";
81                 open STDERR, ">$stderr";
82                 close STDIN;
83                 exec $cmd;
84         }
85         else {
86                 waitpid($pid, 0);
87                 common_log("$?", "?");
88                 if($? != 0) {
89                         common_die("\"$cmd\" failed");
90                 }
91         }
92         
93         open my ($fd), $stdout;
94         
95         return $fd;
96 }
97
98 # is_zip:
99 #    Return true if toolbox file extension is zip
100 sub is_zip {
101         return $TOOLBOXFILE =~ /\.zip$/;
102 }
103
104 # get_tree_from_tgz:
105 #   Get all files (names) of the compressed (in tar.gz) sources
106 sub get_tree_from_tgz {
107         my %files;
108         
109         my $fd = common_exec("zcat ${TOOLBOXFILE} | tar -t");
110         
111         while(<$fd>) {
112                 chomp;
113                 $files{$_} = 1;
114         }
115         
116         close $fd;
117         return %files;
118 }
119
120 # get_tree_from_zip:
121 #   Get all files (names) of the compressed (in zip) sources
122 sub get_tree_from_zip {
123         my (%files, $line);
124         
125         # tail & head are here to skip header & footer
126         my $fd = common_exec("unzip -l ${TOOLBOXFILE}");
127         
128         while(<$fd>) {
129                 if(((/^\s*-+/)...(/^\s*-+/)) && !/^\s*-+/) { # Delete header & footer
130                         # zip output format: size date time filename
131                         /\s*\d+\s+\d+-\d+-\d+\s+\d+:\d+\s+(.+)/ or common_die "Bad output of unzip";
132                         chomp $1;
133                         $files{$1} = 1;
134                 }
135         }
136         
137         close $fd;
138         return %files;
139 }
140
141 # get_tree:
142 #   Get all files (names) of the compressed sources, in a hash
143 #   (hash values are meaningless, set to 1)
144 sub get_tree {
145         if(is_zip()) {
146                 return get_tree_from_zip();
147         }
148         else {
149                 return get_tree_from_tgz();
150         }
151 }
152
153 # read_file_from_tgz:
154 #    Extract given file from the .zip archive
155 sub read_file_from_tgz {
156         my $filename = shift;
157         return common_exec("zcat ${TOOLBOXFILE} | tar -xO ${TOOLBOXNAME}/$filename");
158 }
159
160 # read_file_from_tgz:
161 #    Extract given file from the .tar.gz archive
162 sub read_file_from_zip {
163         my $filename = shift;
164         return common_exec("unzip -p ${TOOLBOXFILE} ${TOOLBOXNAME}/$filename");
165 }
166
167 # read_file_from_archive:
168 #   Extract given file from the archive
169 sub read_file_from_archive {
170         if(is_zip()) {
171                 return read_file_from_zip(@_);
172         }
173         else {
174                 return read_file_from_tgz(@_);
175         }
176 }
177
178 # read_description:
179 #   Check if DESCRIPTION file is correct, and parse it (return a hash
180 #   field => value).
181 #   First argument is a file descriptor for the DESCRIPTION file (see
182 #   get_description)
183 sub read_description {
184         my $fd = shift;
185         my @required = qw(Toolbox Version Title Author Maintainer License
186                           Description ScilabVersion Category);
187         my @optional = qw(Date Depends URL Entity);
188         my (%infos, $key, $val);
189         my (%lines, %correct);
190         
191         # Populate hash
192         while(<$fd>) {
193                 common_die "\":\" not followed by a space at line $." if(/:(?! )/);
194                 if(/:/) { # New field
195                         ($key, $val) = split(/: /, $_, 2);
196                         $infos{$key} = $val;
197                         $lines{$key} = $.;
198                         $correct{$key} = 0;
199                 }
200                 else { # Continuation of previous field
201                         $infos{$key} .= $_;
202                 }
203         }
204         
205         # Check presence of required fields, mark them as correct
206         foreach (@required) {
207                 if(!defined($infos{$_})) {
208                         common_die "Mandatory field \"$_\" not defined";
209                 }
210                 else {
211                         $correct{$_} = 1;
212                 }
213         }
214         
215         # Mark optional fields as correct
216         foreach (@optional) {
217                 if(defined($infos{$_})) {
218                         $correct{$_} = 1;
219                 }
220         }
221         
222         # Check that there's no incorrect (= unknown) fields
223         foreach (keys(%infos)) {
224                 if($correct{$_} == 0) {
225                         common_die "Unknown field \"$_\" (defined at line $lines{$_})";
226                 }
227         }
228         
229         chomp %infos;
230         return %infos;
231 }
232
233 # read_description_functions:
234 #   Parse DESCRIPTION-FUNCTIONS file (and check it, too). Like DESCRIPTION,
235 #   first argument is a file descriptor. Returns a hash function name =>
236 #   function description
237 sub read_description_functions {
238         my $fd = shift;
239         my (%funcs, $func, $desc);
240         
241         while(<$fd>) {
242                 if(/-/ && !/ - /) {
243                         common_die "\"-\" not surrounded by spaces at line $.";
244                 }
245                 
246                 if(/-/) { # New field
247                         ($func, $desc) = split(/ - /, $_, 2);
248                         $funcs{$func} = $desc;
249                 }
250                 else { # Previous function description continuation
251                         $funcs{$func} .= $_;
252                 }
253         }
254         
255         chomp %funcs;
256         
257         return %funcs;
258 }
259
260 # check_tree:
261 #   Given a source tree of a toolbox (see get_tree), check if it is correct
262 #   (required files are present, files are at their right place, and so on...)
263 sub check_tree {
264         my %tree = @_;
265         my %newtree;
266         
267         # Check that all files are under a root which has the same name as the toolbox
268         # Delete this root to simplify other tests
269         foreach (keys %tree) {
270                 if(s#^\Q$TOOLBOXNAME\E(/|$)##) {
271                         $newtree{$_} = 1 if $_;
272                 }
273                 else {
274                         common_die "Incorrect archive: \"$_\" is not a child of \"$TOOLBOXNAME\"";
275                 }
276         }
277         %tree = %newtree;
278         
279         # Check that basic files are here
280         my @required = qw(DESCRIPTION DESCRIPTION-FUNCTIONS readme.txt license.txt
281                           changelog.txt builder.sce);
282         push(@required, "etc/$TOOLBOXNAME.start");
283         push(@required, "etc/$TOOLBOXNAME.quit");
284         
285         foreach (@required) {
286                 if(!defined($tree{$_})) {
287                         common_die "Incorrect archive: required file \"$_\" not present";
288                 }
289         }
290         
291         # macros/ must contain only .sci and .sce files
292         foreach (grep { $_ =~ m#^macros/# } keys %tree) {
293                 if(!/(\.sc[ie]|\/)$/) {
294                         common_die "Incorrect archive: macros/ must contain only .sci and .sce files".
295                             " (\"$_\" found)";
296                 }
297         }
298         
299         # All fortran files must be in src/fortran
300         foreach (grep { $_ =~ /\.f$/} keys %tree) {
301                 if(!m#^src/fortran/#) {
302                         common_die "Incorrect archive: \"$_\" is a fortran source and hence has to be in ".
303                             "src/fortran";
304                 }
305         }
306
307         # All c files must be in src/c or sci_gateway/{c,fortran}
308         foreach (grep { $_ =~ /\.[ch]$/} keys %tree) {
309                 if(!m#^(src/c|sci_gateway/(c|fortran))/#) {
310                         common_die "Incorrect archive: \"$_\" is a C source and hence has to be in ".
311                             "src/c, sci_gateway/c or sci_gateway/fortran";
312                 }
313         }
314         
315         # Constraints: if $key exists, $constraints{$key} must exist
316         my %constraints = (
317                 qr#^help/([a-z][a-z]_[A-Z][A-Z])/[^/]+\.xml$# => sub{ "help/$1/build_help.sce" },
318                 qr#^help/([a-z][a-z]_[A-Z][A-Z])/build_help.sce$# => sub{ "help/$1/addchapter.sce" },
319                 qr#^help/([a-z][a-z]_[A-Z][A-Z])/addchapter.sce$# => sub{ "help/builder_help.sce" },
320                 qr#^sci_gateway/builder_gateway.sce$# => sub{ "sci_gateway/loader_gateway.sce" },
321                 qr#^macros/.+\.sc[ie]$# => sub{ "macros/buildmacros.sce" });
322         
323         # Build constraints for allowed languages
324         my %languages = (
325                 "c" => qr/[ch]/,
326                 "fortran" => qr/f/);
327         
328         foreach (keys %languages) {
329                 # if src/(lang) has source files, src/(lang)/builder_(lang).sce must exist
330                 $constraints{qr#^src/($_)/.+\.$languages{$_}$#} = sub{ "src/$1/builder_$1.sce" };
331                 
332                 # if sci_gateway/(lang) has C sources, sci_gateway/(lang)/builder_gateway_(lang).sce
333                 # must exist
334                 $constraints{qr#^sci_gateway/($_)/.+[ch]$#} = sub{ "sci_gateway/$1/builder_gateway_$1.sce" };
335                 
336                 # if src/(lang)/builder_(lang).sce exist, src/builder_src.sce must exist
337                 $constraints{qr#^src/$_/builder_$_.sce$#} = sub{ "src/builder_src.sce" };
338                 
339                 # if sci_gateway/(lang)/builder_gateway_(lang).sce exist, sci_gateway/builder_gateway.sce must exist
340                 $constraints{qr#^sci_gateway/$_/builder_gateway_$_.sce$#} = sub{ "sci_gateway/builder_gateway.sce" };
341         }
342         
343         # Check constraints
344         foreach my $constraint (keys %constraints) {
345                 foreach my $file (keys %tree) {
346                         if($file =~ $constraint) {
347                                 my $required = $constraints{$constraint}();
348                                 common_die "Invalid archive: \"$&\" needs \"$required\", which isn't in the archive"
349                                         unless(defined($tree{$required}));
350                         }
351                 }
352         }
353 }
354
355 # stage_check:
356 #   Perform basic checks
357 sub stage_check {
358         common_enter_stage("check");
359         
360         if(is_zip()) {
361                 common_log("Detected ZIP format");
362         }
363         else {
364                 common_log("Detected TAR+GZIP format");
365         }
366         
367         # Check tree
368         common_log("Checking archive structure");
369         my %tree = get_tree();
370         common_log("Archive files:\n" . join("\n", sort keys %tree));
371         check_tree(%tree);
372         
373         # Check DESCRIPTION
374         common_log("Checking DESCRIPTION");
375         my $fd = read_file_from_archive("DESCRIPTION");
376         my %desc = read_description($fd);
377         common_log("Computed DESCRIPTION:\n" .
378                 join("\n", map { "$_: $desc{$_}" } sort keys %desc));
379         
380         # Check toolbox name
381         if($TOOLBOXNAME ne $desc{"Toolbox"}) {
382                 common_die "Detected toolbox name ($TOOLBOXNAME) different from ".
383                     "DESCRIPTION version ($desc{Toolbox})";
384         }
385         
386         # Check version
387         my $version = $1 if ($TOOLBOXFILE =~ /[^.]+\.([^-]+)/);
388         if(!defined($version)) {
389                 common_die "Can't detect version from archive name ($TOOLBOXFILE)";
390         }
391         
392         if($version ne $desc{"Version"}) {
393                 common_die "Detected version ($version) different from DESCRIPTION ".
394                     "version ($desc{Version})";
395         }
396         
397         # Check DESCRIPTION-FUNCTIONS
398         common_log("Checking DESCRIPTION-FUNCTIONS");
399         $fd = read_file_from_archive("DESCRIPTION-FUNCTIONS");
400         my %funcs = read_description_functions($fd);
401         common_log("Computed DESCRIPTION-FUNCTIONS:\n" .
402                 join("\n", map { "$_: $funcs{$_}" } sort keys %funcs));
403         
404         common_leave_stage("check");
405 }
406
407 # stage_unpack:
408 #     Extract the archive
409 sub stage_unpack {
410         common_enter_stage("unpack");
411         
412         if(is_zip()) {
413                 common_exec("unzip -o ${TOOLBOXFILE}");
414         }
415         else {
416                 common_exec("zcat ${TOOLBOXFILE} | tar -vx");
417         }
418         
419         common_leave_stage("unpack");
420 }
421
422 # stage_makeenv:
423 #    Build up the environment
424 sub stage_makeenv {
425         common_enter_stage("makeenv");
426         # TODO
427         common_leave_stage("makeenv");
428 }
429
430 # compare_versions:
431 #    Returns -1 if version a < version b, 0 if equals, 1 else
432 sub compare_versions {
433         my $versa = shift;
434         my $versb = shift;
435         my @va = split(/\./, $versa);
436         my @vb = split(/\./, $versb);
437         
438         if($#va < $#vb) {
439                 return -compare_versions($versb, $versa);
440         }
441         
442         for(my $i = 0; $i < $#vb; ++$i) {
443                 return  1 if $va[$i] > $vb[$i];
444                 return -1 if $va[$i] < $vb[$i];
445         }
446         
447         return 1 if($#va > $#vb);
448         return 0;
449 }
450
451 # stage_tbdeps:
452 #    Install toolbox dependencies
453 sub stage_tbdeps {
454         my $fd;
455         my @depsarray;
456         my (%deps, %desc);
457         
458         my $SCILABX = "scilab -nwni -nb -e ";
459         
460         common_enter_stage("tbdeps");
461         
462         # We alreay made the check, reading description should be OK
463         open $fd, "$TOOLBOXNAME/DESCRIPTION";
464         %desc = read_description($fd);
465         close($fd);
466         
467         # Make a hash depname => depvers
468         @depsarray = split(/\s*,\s*/, $desc{"Depends"} || "");
469         foreach (@depsarray) {
470                 if(/^(\S+?)\s*\([<>]=\s*([^)]+)\)$/) { # toolbox-name (version-comparator version)
471                         $deps{$1} = $2;
472                 }
473                 else {
474                         $deps{$_} = "*";
475                 }
476         }
477         
478         common_log("Dependencies: " . join(",", map { "$_ $deps{$_}" } keys %deps));
479         
480         # Install dependencies
481         # fixme: we always install the last version, but some packages
482         #   needs some versions... at most. Need to deal with that.
483         close(common_exec("$SCILABX 'installToolbox(\"$_\"); quit;'"))
484                 foreach(keys %deps);
485         
486         # Find toolboxes directory
487         $fd = common_exec("$SCILABX 'printf(\"path: %s\\n\", cd(toolboxDirectory())); quit;'");
488         
489         my $tbpath;
490         while(<$fd>) {
491                 if(/^path: (.+)$/) {
492                         $tbpath = $1;
493                         last;
494                 }
495         }
496         
497         if(!defined($tbpath)) {
498                 common_die("Can't find toolboxes directory");
499         }
500         
501         common_log("Toolboxes directory: $tbpath\n");
502         
503         # Check if required toolboxes are installed
504         foreach my $dep (keys %deps) {
505                 common_log("Checking $dep");
506                 if(! -r "$tbpath/$dep/DESCRIPTION") {
507                         common_die("Needed toolbox \"$dep\" is not installed");
508                 }
509                 
510                 next if($deps{$dep} eq "*");
511                 
512                 open $fd, "$tbpath/$dep/DESCRIPTION";
513                 my %desc2 = read_description($fd);
514                 close $fd;
515                 
516                 # fixme: we only check wether neededVersion <= installedVersion
517                 #   Others tests (=, <=) are still to be implemented
518                 if(compare_versions($deps{$dep}, $desc2{"Version"}) == 1) {
519                         common_die("We need \"$dep\" >= $deps{$dep}, but version $desc2{Version} installed");
520                 }
521         }
522         
523         common_leave_stage("tbdeps");
524 }
525
526 # stage_sysdeps:
527 #    Install system dependencies
528 sub stage_sysdeps {
529         common_enter_stage("sysdeps");
530         # TODO
531         common_leave_stage("sysdeps");
532 }
533
534 # stage_build
535 #     Run the build script
536 sub stage_build {
537         common_enter_stage("build");
538         
539         # Generate ccbuilder.sce (see __DATA__ section)
540         open CCBUILDER, ">ccbuilder.sce";
541         print CCBUILDER while(<DATA>);
542         close CCBUILDER;
543         
544         # For logging purposes only
545         common_exec("cat ccbuilder.sce");
546         
547         my $fd = common_exec("cd $TOOLBOXNAME; scilab -nb -nwni -e 'exec(\"../ccbuilder.sce\");'");
548         
549         # Check result
550         my $done = 0;
551         
552         while(<$fd>) {
553                 $done = 1 if(/^atoms_cc_builder:done$/);
554                 if(/^atoms_cc_ilib_compile:\s*(.+?)\s*$/) {
555                         common_die("Generated library \"$1\" is invalid") unless($1 && -x $1 && ! -d $1);
556                 }
557         }
558         
559         # fixme: need to check if everything was OK in macros/help generation
560         
561         common_die("builder.sce script didn't terminate normally") unless($done);
562         common_leave_stage("build");
563 }
564
565 # Init global vars, check arguments
566 open LOGFILE, ">build.log";
567
568 $STAGE = "";
569
570 $TOOLBOXFILE = shift;
571 if(!defined($TOOLBOXFILE)) {
572         common_die "Toolbox source file required";
573 }
574
575 if(! -r $TOOLBOXFILE) {
576         common_die "$TOOLBOXFILE doesn't exists or can't be read";
577 }
578
579 $TOOLBOXNAME = $1 if ($TOOLBOXFILE =~ /^([^.]+)/);
580
581 common_log "Toolbox: $TOOLBOXNAME";
582 common_log "Source file: $TOOLBOXFILE";
583
584 stage_check;
585 stage_unpack;
586 stage_makeenv;
587 stage_tbdeps;
588 stage_sysdeps;
589 stage_build;
590
591 close LOGFILE;
592
593 # Overwrite some scilab functions to get its return value and extra infos
594 __DATA__
595 predef(0);
596 funcprot(0);
597
598 old_ilib_compile = ilib_compile;
599 function libn = ilib_compile(lib_name,makename,files,ldflags,cflags,fflags)
600     libn = old_ilib_compile(lib_name,makename,files,ldflags,cflags,fflags);
601     mprintf("\natoms_cc_ilib_compile:%s/%s\n", pwd(), libn);
602 endfunction
603
604 exec("builder.sce");
605 mprintf("\natoms_cc_builder:done\n");
606 quit;
607