atoms_cc/buildtoolbox:
[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("tar -tzf ${TOOLBOXFILE}");
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} | tail -n +4 | head -n -2");
125         
126         while(<$fd>) {
127                 # zip output format: size date time filename
128                 /\s*\d+\s+\d+-\d+-\d+\s+\d+:\d+\s+(.+)/ or common_die "Bad output of unzip";
129                 chomp $1;
130                 $files{$1} = 1;
131         }
132         
133         close $fd;
134         return %files;
135 }
136
137 # get_tree:
138 #   Get all files (names) of the compressed sources, in a hash
139 #   (hash values are meaningless, set to 1)
140 sub get_tree {
141         if(is_zip()) {
142                 return get_tree_from_zip();
143         }
144         else {
145                 return get_tree_from_tgz();
146         }
147 }
148
149 # read_file_from_tgz:
150 #    Extract given file from the .zip archive
151 sub read_file_from_tgz {
152         my $filename = shift;
153         return common_exec("tar -xOzf ${TOOLBOXFILE} ${TOOLBOXNAME}/$filename");
154 }
155
156 # read_file_from_tgz:
157 #    Extract given file from the .tar.gz archive
158 sub read_file_from_zip {
159         my $filename = shift;
160         return common_exec("unzip -c ${TOOLBOXFILE} ${TOOLBOXNAME}/$filename | tail -n +3 | head -n -1");
161 }
162
163 # read_file_from_archive:
164 #   Extract given file from the archive
165 sub read_file_from_archive {
166         if(is_zip()) {
167                 return read_file_from_zip(@_);
168         }
169         else {
170                 return read_file_from_tgz(@_);
171         }
172 }
173
174 # read_description:
175 #   Check if DESCRIPTION file is correct, and parse it (return a hash
176 #   field => value).
177 #   First argument is a file descriptor for the DESCRIPTION file (see
178 #   get_description)
179 sub read_description {
180         my $fd = shift;
181         my @required = qw(Toolbox Version Title Author Maintainer
182                           Description License Category);
183         my @optional = qw(Date Depends URL Entity);
184         my (%infos, $key, $val);
185         my (%lines, %correct);
186         
187         # Populate hash
188         while(<$fd>) {
189                 common_die "\":\" not followed by a space at line $." if(/:(?! )/);
190                 if(/:/) { # New field
191                         ($key, $val) = split(/: /, $_, 2);
192                         $infos{$key} = $val;
193                         $lines{$key} = $.;
194                         $correct{$key} = 0;
195                 }
196                 else { # Continuation of previous field
197                         $infos{$key} .= $_;
198                 }
199         }
200         
201         # Check presence of required fields, mark them as correct
202         foreach (@required) {
203                 if(!defined($infos{$_})) {
204                         common_die "Mandatory field \"$_\" not defined";
205                 }
206                 else {
207                         $correct{$_} = 1;
208                 }
209         }
210         
211         # Mark optional fields as correct
212         foreach (@optional) {
213                 if(defined($infos{$_})) {
214                         $correct{$_} = 1;
215                 }
216         }
217         
218         # Check that there's no incorrect (= unknown) fields
219         foreach (keys(%infos)) {
220                 if($correct{$_} == 0) {
221                         common_die "Unknown field \"$_\" (defined at line $lines{$_})";
222                 }
223         }
224         
225         chomp %infos;
226         return %infos;
227 }
228
229 # read_description_functions:
230 #   Parse DESCRIPTION-FUNCTIONS file (and check it, too). Like DESCRIPTION,
231 #   first argument is a file descriptor. Returns a hash function name =>
232 #   function description
233 sub read_description_functions {
234         my $fd = shift;
235         my (%funcs, $func, $desc);
236         
237         while(<$fd>) {
238                 if(/-/ && !/ - /) {
239                         common_die "\"-\" not surrounded by spaces at line $.";
240                 }
241                 
242                 if(/-/) { # New field
243                         ($func, $desc) = split(/ - /, $_, 2);
244                         $funcs{$func} = $desc;
245                 }
246                 else { # Previous function description continuation
247                         $funcs{$func} .= $_;
248                 }
249         }
250         
251         chomp %funcs;
252         
253         return %funcs;
254 }
255
256 # check_tree:
257 #   Given a source tree of a toolbox (see get_tree), check if it is correct
258 #   (required files are present, files are at their right place, and so on...)
259 sub check_tree {
260         my %tree = @_;
261         my %newtree;
262         
263         # Check that all files are under a root which has the same name as the toolbox
264         # Delete this root to simplify other tests
265         foreach (keys %tree) {
266                 if(s#^\Q$TOOLBOXNAME\E(/|$)##) {
267                         $newtree{$_} = 1 if $_;
268                 }
269                 else {
270                         common_die "Incorrect archive: \"$_\" is not a child of \"$TOOLBOXNAME\"";
271                 }
272         }
273         %tree = %newtree;
274         
275         # Check that basic files are here
276         my @required = qw(DESCRIPTION DESCRIPTION-FUNCTIONS readme.txt license.txt
277                           builder.sce loader.sce);
278         push(@required, "etc/$TOOLBOXNAME.start");
279         push(@required, "etc/$TOOLBOXNAME.end");
280         
281         foreach (@required) {
282                 if(!defined($tree{$_})) {
283                         common_die "Incorrect archive: required file \"$_\" not present";
284                 }
285         }
286         
287         # macros/ must contain only .sci and .sce files
288         foreach (grep { $_ =~ m#^macros/# } keys %tree) {
289                 if(!/(\.sc[ie]|\/)$/) {
290                         common_die "Incorrect archive: macros/ must contain only .sci and .sce files".
291                             " (\"$_\" found)";
292                 }
293         }
294         
295         # All fortran files must be in src/fortran
296         foreach (grep { $_ =~ /\.f$/} keys %tree) {
297                 if(!m#^src/fortran/#) {
298                         common_die "Incorrect archive: \"$_\" is a fortran source and hence has to be in ".
299                             "src/fortran";
300                 }
301         }
302
303         # All c files must be in src/c or sci_gateway/{c,fortran}
304         foreach (grep { $_ =~ /\.[ch]$/} keys %tree) {
305                 if(!m#^(src/c|sci_gateway/(c|fortran))/#) {
306                         common_die "Incorrect archive: \"$_\" is a C source and hence has to be in ".
307                             "src/c, sci_gateway/c or sci_gateway/fortran";
308                 }
309         }
310         
311         # Constraints: if $key exists, $constraints{$key} must exist
312         my %constraints = (
313                 qr#help/.+\.xml$# => "help/buildhelp.sce",
314                 qr#macros/.+\.sc[ie]$# => "macros/buildmacros.sce");
315         
316         # Build constraints for allowed languages
317         my %languages = (
318                 "c" => qr/[ch]/,
319                 "fortran" => qr/f/);
320         
321         foreach (keys %languages) {
322                 # if src/(lang) has source files, src/(lang)/buildsrc_(lang).sce must exist
323                 $constraints{qr#^src/$_/.+\.$languages{$_}$#} = "src/$_/buildsrc_$_.sce";
324                 
325                 # if sci_gateway/(lang) has C sources, sci_gateway/(lang)/buildgateway_(lang).sce
326                 # must exist
327                 $constraints{qr#^sci_gateway/$_/.+[ch]$#} = "sci_gateway/$_/buildgateway_$_.sce";
328                 
329                 # if src/(lang)/buildsrc_(lang).sce exist, src/buildsrc.sce must exist
330                 $constraints{qr#^src/$_/buildsrc_$_.sce$#} = "src/buildsrc.sce";
331                 
332                 # if sci_gateway/(lang)/buildgateway_(lang).sce exist, sci_gateway/buildgateway.sce must exist
333                 $constraints{qr#^sci_gateway/$_/buildgateway_$_.sce$#} = "sci_gateway/buildgateway.sce";
334         }
335         
336         # Check constraints
337         foreach my $constraint (keys %constraints) {
338                 my $required = $constraints{$constraint};
339                 my @found = grep { $_ =~ $constraint } keys %tree;
340                 if(@found && !defined($tree{$required})) {
341                         common_die "Invalid archive: \"$found[0]\" needs \"$required\", which isn't in the archive";
342                 }
343         }
344 }
345
346 # stage_check:
347 #   Perform basic checks
348 sub stage_check {
349         common_enter_stage("check");
350         
351         if(is_zip()) {
352                 common_log("Detected ZIP format");
353         }
354         else {
355                 common_log("Detected TAR+GZIP format");
356         }
357         
358         # Check tree
359         common_log("Checking archive structure");
360         my %tree = get_tree();
361         common_log("Archive files:\n" . join("\n", sort keys %tree));
362         check_tree(%tree);
363         
364         # Check DESCRIPTION
365         common_log("Checking DESCRIPTION");
366         my $fd = read_file_from_archive("DESCRIPTION");
367         my %desc = read_description($fd);
368         common_log("Computed DESCRIPTION:\n" .
369                 join("\n", map { "$_: $desc{$_}" } sort keys %desc));
370         
371         # Check toolbox name
372         if($TOOLBOXNAME ne $desc{"Toolbox"}) {
373                 common_die "Detected toolbox name ($TOOLBOXNAME) different from ".
374                     "DESCRIPTION version ($desc{Toolbox})";
375         }
376         
377         # Check version
378         my $version = $1 if ($TOOLBOXFILE =~ /[^.]+\.([^-]+)/);
379         if(!defined($version)) {
380                 common_die "Can't detect version from archive name ($TOOLBOXFILE)";
381         }
382         
383         if($version ne $desc{"Version"}) {
384                 common_die "Detected version ($version) different from DESCRIPTION ".
385                     "version ($desc{Version})";
386         }
387         
388         # Check DESCRIPTION-FUNCTIONS
389         common_log("Checking DESCRIPTION-FUNCTIONS");
390         $fd = read_file_from_archive("DESCRIPTION-FUNCTIONS");
391         my %funcs = read_description_functions($fd);
392         common_log("Computed DESCRIPTION-FUNCTIONS:\n" .
393                 join("\n", map { "$_: $funcs{$_}" } sort keys %funcs));
394         
395         common_leave_stage("check");
396 }
397
398 # Init global vars, check arguments
399 $TOOLBOXFILE = shift;
400 if(!defined($TOOLBOXFILE)) {
401         common_die "Toolbox source file required";
402 }
403
404 if(! -r $TOOLBOXFILE) {
405         common_die "$TOOLBOXFILE doesn't exists or can't be read";
406 }
407
408 $TOOLBOXNAME = $1 if ($TOOLBOXFILE =~ /^([^.]+)/);
409
410 open LOGFILE, ">build.log";
411
412 common_log "Toolbox: $TOOLBOXNAME";
413 common_log "Source file: $TOOLBOXFILE";
414
415 stage_check;
416
417 close LOGFILE;