Commit | Line | Data |
---|---|---|
6092c506 | 1 | #!/usr/bin/perl |
459d3fb5 | 2 | |
a8ae8817 DH |
3 | use FindBin; |
4 | ||
5 | $p5_metaconfig_base = "$FindBin::Bin/../"; | |
2edea9d0 | 6 | chdir "$p5_metaconfig_base/perl" or |
a8ae8817 | 7 | die "perl/ directory missing in $p5_metaconfig_base\n"; |
459d3fb5 | 8 | |
2edea9d0 | 9 | -w 'Configure' && -w 'config_h.SH' or |
e9be536b DH |
10 | die "both Configure and config_h.SH must be writable\n"; |
11 | ||
459d3fb5 MBT |
12 | # |
13 | # This perl program uses dynamic loading [generated by perload] | |
14 | # | |
15 | ||
16 | $ENV{LC_ALL} = 'C'; | |
17 | ||
18 | # $Id: mconfig.SH 4 2006-08-25 21:54:31Z rmanfredi $ | |
19 | # | |
20 | # Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi | |
21 | # | |
22 | # You may redistribute only under the terms of the Artistic Licence, | |
23 | # as specified in the README file that comes with the distribution. | |
24 | # You may reuse parts of this distribution only within the terms of | |
25 | # that same Artistic Licence; a copy of which may be found at the root | |
26 | # of the source tree for dist 4.0. | |
27 | # | |
28 | # Original Author: Larry Wall <lwall@netlabs.com> | |
29 | # Key Contributor: Harlan Stenn <harlan@mumps.pfcs.com> | |
30 | # | |
31 | # $Log: mconfig.SH,v $ | |
32 | # Revision 3.0.1.5 1995/07/25 14:19:05 ram | |
33 | # patch56: new -G option | |
34 | # | |
35 | # Revision 3.0.1.4 1994/06/20 07:11:04 ram | |
36 | # patch30: new -L option to override public library path for testing | |
37 | # | |
38 | # Revision 3.0.1.3 1994/01/24 14:20:53 ram | |
39 | # patch16: added ~/.dist_profile awareness | |
40 | # | |
41 | # Revision 3.0.1.2 1993/10/16 13:53:10 ram | |
42 | # patch12: new -M option for magic symbols and confmagic.h production | |
43 | # | |
44 | # Revision 3.0.1.1 1993/08/19 06:42:26 ram | |
45 | # patch1: leading config.sh searching was not aborting properly | |
46 | # | |
47 | # Revision 3.0 1993/08/18 12:10:17 ram | |
48 | # Baseline for dist 3.0 netwide release. | |
49 | # | |
50 | ||
51 | # Perload ON | |
52 | ||
a8ae8817 | 53 | $MC = "$p5_metaconfig_base/dist"; |
459d3fb5 MBT |
54 | $version = '3.5'; |
55 | $patchlevel = '0'; | |
56 | $grep = '/usr/bin/grep'; | |
57 | chop($date = `date`); | |
58 | &profile; # Read ~/.dist_profile | |
59 | require 'getopts.pl'; | |
60 | &usage unless &Getopts("dhkmostvwGMVL:"); | |
61 | ||
62 | $MC = $opt_L if $opt_L; # May override public library path | |
63 | $MC = &tilda_expand($MC); # ~name expansion | |
64 | chop($WD = `pwd`); # Working directory | |
65 | chdir $MC || die "Can't chdir to $MC: $!\n"; | |
66 | chop($MC = `pwd`); # Real metaconfig lib path (no symbolic links) | |
67 | chdir $WD || die "Can't chdir back to $WD: $!\n"; | |
68 | ||
69 | ++$opt_k if $opt_d; | |
70 | ++$opt_M if -f 'confmagic.h'; # Force -M if confmagic.h already there | |
71 | ||
72 | if ($opt_V) { | |
73 | print STDERR "metaconfig $version PL$patchlevel\n"; | |
74 | exit 0; | |
75 | } elsif ($opt_h) { | |
76 | &usage; | |
77 | } | |
78 | ||
79 | unlink 'Wanted' unless $opt_w; # Wanted rebuilt if no -w | |
80 | unlink 'Obsolete' unless $opt_w; # Obsolete file rebuilt if no -w | |
81 | &readpackage; # Merely get the package's name | |
82 | &init; # Various initializations | |
83 | `mkdir .MT 2>&1` unless -d '.MT'; # For private temporary files | |
84 | ||
85 | &locate_units; # Fill in @ARGV with a unit list | |
86 | &extract_dependencies; # Extract dependencies from units | |
87 | &extract_filenames; # Extract files to be scanned for | |
88 | &build_wanted; # Build a list of wanted symbols in file Wanted | |
89 | &build_makefile; # To do the transitive closure of dependencies | |
90 | &solve_dependencies; # Now run the makefile to close dependency graph | |
91 | &create_configure; # Create the Configure script and related files | |
92 | &cosmetic_update; # Update the manifests | |
93 | ||
94 | if ($opt_k) { | |
95 | print "Leaving subdirectory .MT unremoved so you can peruse it.\n" | |
96 | unless $opt_s; | |
97 | } else { | |
98 | `rm -rf .MT 2>&1`; | |
99 | } | |
100 | system "Porting/config_h.pl"; | |
101 | print "Done.\n" unless $opt_s; | |
102 | ||
103 | sub main'init { &auto_main'init; } | |
104 | sub auto_main'init { &main'dataload; } | |
105 | ||
106 | sub main'init_constants { &auto_main'init_constants; } | |
107 | sub auto_main'init_constants { &main'dataload; } | |
108 | ||
109 | sub main'init_except { &auto_main'init_except; } | |
110 | sub auto_main'init_except { &main'dataload; } | |
111 | ||
112 | sub main'usage { &auto_main'usage; } | |
113 | sub auto_main'usage { &main'dataload; } | |
114 | ||
115 | package locate; | |
116 | ||
117 | sub main'locate_units { &auto_main'locate_units; } | |
118 | sub auto_main'locate_units { &main'dataload; } | |
119 | ||
120 | sub locate'dump_list { &auto_locate'dump_list; } | |
121 | sub auto_locate'dump_list { &main'dataload; } | |
122 | ||
123 | sub locate'private_units { &auto_locate'private_units; } | |
124 | sub auto_locate'private_units { &main'dataload; } | |
125 | ||
126 | sub locate'public_units { &auto_locate'public_units; } | |
127 | sub auto_locate'public_units { &main'dataload; } | |
128 | ||
129 | sub locate'units_path { &auto_locate'units_path; } | |
130 | sub auto_locate'units_path { &main'dataload; } | |
131 | ||
132 | package main; | |
133 | ||
134 | sub main'init_extraction { &auto_main'init_extraction; } | |
135 | sub auto_main'init_extraction { &main'dataload; } | |
136 | ||
137 | sub main'end_extraction { &auto_main'end_extraction; } | |
138 | sub auto_main'end_extraction { &main'dataload; } | |
139 | ||
140 | sub main'p_make { &auto_main'p_make; } | |
141 | sub auto_main'p_make { &main'dataload; } | |
142 | ||
143 | sub main'p_obsolete { &auto_main'p_obsolete; } | |
144 | sub auto_main'p_obsolete { &main'dataload; } | |
145 | ||
146 | sub main'p_shell { &auto_main'p_shell; } | |
147 | sub auto_main'p_shell { &main'dataload; } | |
148 | ||
149 | sub main'p_c { &auto_main'p_c; } | |
150 | sub auto_main'p_c { &main'dataload; } | |
151 | ||
152 | sub main'p_config { &auto_main'p_config; } | |
153 | sub auto_main'p_config { &main'dataload; } | |
154 | ||
155 | sub main'p_magic { &auto_main'p_magic; } | |
156 | sub auto_main'p_magic { &main'dataload; } | |
157 | ||
158 | sub p_ignore {} # Ignore comment line | |
159 | sub p_lint {} # Ignore lint directives | |
160 | sub p_visible {} # No visible checking in metaconfig | |
161 | sub p_temp {} # No temporary variable control | |
162 | sub p_file {} # Ignore produced file directives (for now) | |
163 | ||
164 | sub main'p_wanted { &auto_main'p_wanted; } | |
165 | sub auto_main'p_wanted { &main'dataload; } | |
166 | ||
167 | sub main'p_init { &auto_main'p_init; } | |
168 | sub auto_main'p_init { &main'dataload; } | |
169 | ||
170 | sub main'p_default { &auto_main'p_default; } | |
171 | sub auto_main'p_default { &main'dataload; } | |
172 | ||
173 | sub main'p_public { &auto_main'p_public; } | |
174 | sub auto_main'p_public { &main'dataload; } | |
175 | ||
176 | sub main'p_layout { &auto_main'p_layout; } | |
177 | sub auto_main'p_layout { &main'dataload; } | |
178 | ||
179 | sub main'p_library { &auto_main'p_library; } | |
180 | sub auto_main'p_library { &main'dataload; } | |
181 | ||
182 | sub main'p_include { &auto_main'p_include; } | |
183 | sub auto_main'p_include { &main'dataload; } | |
184 | ||
185 | sub main'write_out { &auto_main'write_out; } | |
186 | sub auto_main'write_out { &main'dataload; } | |
187 | ||
188 | sub main'init_depend { &auto_main'init_depend; } | |
189 | sub auto_main'init_depend { &main'dataload; } | |
190 | ||
191 | sub main'extract_dependencies { &auto_main'extract_dependencies; } | |
192 | sub auto_main'extract_dependencies { &main'dataload; } | |
193 | ||
194 | sub main'complete_line { &auto_main'complete_line; } | |
195 | sub auto_main'complete_line { &main'dataload; } | |
196 | ||
197 | sub main'extract_filenames { &auto_main'extract_filenames; } | |
198 | sub auto_main'extract_filenames { &main'dataload; } | |
199 | ||
200 | sub main'build_filext { &auto_main'build_filext; } | |
201 | sub auto_main'build_filext { &main'dataload; } | |
202 | ||
203 | sub main'build_extfun { &auto_main'build_extfun; } | |
204 | sub auto_main'build_extfun { &main'dataload; } | |
205 | ||
206 | sub main'q { &auto_main'q; } | |
207 | sub auto_main'q { &main'dataload; } | |
208 | ||
209 | sub main'build_wanted { &auto_main'build_wanted; } | |
210 | sub auto_main'build_wanted { &main'dataload; } | |
211 | ||
212 | sub main'parse_files { &auto_main'parse_files; } | |
213 | sub auto_main'parse_files { &main'dataload; } | |
214 | ||
215 | sub main'cmaster { &auto_main'cmaster; } | |
216 | sub auto_main'cmaster { &main'dataload; } | |
217 | ||
218 | sub main'ofound { &auto_main'ofound; } | |
219 | sub auto_main'ofound { &main'dataload; } | |
220 | ||
221 | sub main'shmaster { &auto_main'shmaster; } | |
222 | sub auto_main'shmaster { &main'dataload; } | |
223 | ||
224 | sub main'add_obsolete { &auto_main'add_obsolete; } | |
225 | sub auto_main'add_obsolete { &main'dataload; } | |
226 | ||
227 | sub main'map_obsolete { &auto_main'map_obsolete; } | |
228 | sub auto_main'map_obsolete { &main'dataload; } | |
229 | ||
230 | sub main'record_obsolete { &auto_main'record_obsolete; } | |
231 | sub auto_main'record_obsolete { &main'dataload; } | |
232 | ||
233 | sub main'dump_obsolete { &auto_main'dump_obsolete; } | |
234 | sub auto_main'dump_obsolete { &main'dataload; } | |
235 | ||
236 | sub main'build_makefile { &auto_main'build_makefile; } | |
237 | sub auto_main'build_makefile { &main'dataload; } | |
238 | ||
239 | sub main'build_private { &auto_main'build_private; } | |
240 | sub auto_main'build_private { &main'dataload; } | |
241 | ||
242 | sub main'symbols { &auto_main'symbols; } | |
243 | sub auto_main'symbols { &main'dataload; } | |
244 | ||
245 | sub main'compute_loadable { &auto_main'compute_loadable; } | |
246 | sub auto_main'compute_loadable { &main'dataload; } | |
247 | ||
248 | # Now that we know all the desirable symbols, we have to rebuild | |
249 | # another makefile, in order to have the units in a more optimal | |
250 | # way. | |
251 | # Actually, if we have both ?MAKE:a:+b and ?MAKE:d:b and 'd' is | |
252 | # wanted; then 'b' will be loaded. However, 'b' is a conditional | |
253 | # dependency for 'a', and it would be better if 'b' were loaded | |
254 | # before 'a' is, though this is not necessary. | |
255 | # It is hard to know that 'b' will be loaded *before* the first make. | |
256 | ||
257 | sub main'update_makefile { &auto_main'update_makefile; } | |
258 | sub auto_main'update_makefile { &main'dataload; } | |
259 | ||
260 | sub main'solve_dependencies { &auto_main'solve_dependencies; } | |
261 | sub auto_main'solve_dependencies { &main'dataload; } | |
262 | ||
263 | sub main'create_configure { &auto_main'create_configure; } | |
264 | sub auto_main'create_configure { &main'dataload; } | |
265 | ||
266 | sub main'process_command { &auto_main'process_command; } | |
267 | sub auto_main'process_command { &main'dataload; } | |
268 | ||
269 | sub main'skipped { &auto_main'skipped; } | |
270 | sub auto_main'skipped { &main'dataload; } | |
271 | ||
272 | sub main'cosmetic_update { &auto_main'cosmetic_update; } | |
273 | sub auto_main'cosmetic_update { &main'dataload; } | |
274 | ||
275 | sub main'mani_add { &auto_main'mani_add; } | |
276 | sub auto_main'mani_add { &main'dataload; } | |
277 | ||
278 | sub main'mani_remove { &auto_main'mani_remove; } | |
279 | sub auto_main'mani_remove { &main'dataload; } | |
280 | ||
281 | sub main'add_configure { &auto_main'add_configure; } | |
282 | sub auto_main'add_configure { &main'dataload; } | |
283 | ||
284 | package interpreter; | |
285 | ||
286 | sub main'init_keep { &auto_main'init_keep; } | |
287 | sub auto_main'init_keep { &main'dataload; } | |
288 | ||
289 | sub main'init_priority { &auto_main'init_priority; } | |
290 | sub auto_main'init_priority { &main'dataload; } | |
291 | ||
292 | sub main'init_interp { &auto_main'init_interp; } | |
293 | sub auto_main'init_interp { &main'dataload; } | |
294 | ||
295 | sub interpreter'error { &auto_interpreter'error; } | |
296 | sub auto_interpreter'error { &main'dataload; } | |
297 | ||
298 | sub main'check_state { &auto_main'check_state; } | |
299 | sub auto_main'check_state { &main'dataload; } | |
300 | ||
301 | sub interpreter'push_val { &auto_interpreter'push_val; } | |
302 | sub auto_interpreter'push_val { &main'dataload; } | |
303 | ||
304 | sub interpreter'execute { &auto_interpreter'execute; } | |
305 | sub auto_interpreter'execute { &main'dataload; } | |
306 | ||
307 | sub interpreter'update_stack { &auto_interpreter'update_stack; } | |
308 | sub auto_interpreter'update_stack { &main'dataload; } | |
309 | ||
310 | sub interpreter'eval_expr { &auto_interpreter'eval_expr; } | |
311 | sub auto_interpreter'eval_expr { &main'dataload; } | |
312 | ||
313 | sub interpreter'evaluate { &auto_interpreter'evaluate; } | |
314 | sub auto_interpreter'evaluate { &main'dataload; } | |
315 | ||
316 | sub main'interpret { &auto_main'interpret; } | |
317 | sub auto_main'interpret { &main'dataload; } | |
318 | ||
319 | package main; | |
320 | ||
321 | sub main'readpackage { &auto_main'readpackage; } | |
322 | sub auto_main'readpackage { &main'dataload; } | |
323 | ||
324 | sub main'manifake { &auto_main'manifake; } | |
325 | sub auto_main'manifake { &main'dataload; } | |
326 | ||
327 | sub main'tilda_expand { &auto_main'tilda_expand; } | |
328 | sub auto_main'tilda_expand { &main'dataload; } | |
329 | ||
330 | sub main'profile { &auto_main'profile; } | |
331 | sub auto_main'profile { &main'dataload; } | |
332 | ||
333 | # Load the calling function from DATA segment and call it. This function is | |
334 | # called only once per routine to be loaded. | |
335 | sub main'dataload { | |
336 | local($__packname__) = (caller(1))[3]; | |
337 | $__packname__ =~ s/::/'/; | |
338 | local($__rpackname__) = $__packname__; | |
339 | local($__at__) = $@; | |
340 | $__rpackname__ =~ s/^auto_//; | |
341 | &perload'load_from_data($__rpackname__); | |
342 | local($__fun__) = "$__rpackname__"; | |
343 | $__fun__ =~ s/'/'load_/; | |
344 | eval "*$__packname__ = *$__fun__;"; # Change symbol table entry | |
345 | die $@ if $@; # Should not happen | |
346 | $@ = $__at__; # Restore value $@ had on entrance | |
347 | &$__fun__; # Call newly loaded function | |
348 | } | |
349 | ||
350 | # Load function name given as argument, fatal error if not existent | |
351 | sub perload'load_from_data { | |
352 | package perload; | |
353 | local($pos) = $Datapos{$_[0]}; # Offset within DATA | |
354 | # Avoid side effects by protecting special variables which will be changed | |
355 | # by the dataloading operation. | |
356 | local($., $_, $@); | |
357 | $pos = &fetch_function_code unless $pos; | |
358 | die "Function $_[0] not found in data section.\n" unless $pos; | |
359 | die "Cannot seek to $pos into data section.\n" | |
360 | unless seek(main'DATA, $pos, 0); | |
361 | local($/) = "\n}"; | |
362 | local($body) = scalar(<main'DATA>); | |
363 | die "End of file found while loading $_[0].\n" unless $body =~ /^\}$/m; | |
364 | eval $body; # Load function into perl space | |
365 | chop($@) && die "$@, while parsing code of $_[0].\n"; | |
366 | } | |
367 | ||
368 | # This function is called only once, and fills in the %Datapos array with | |
369 | # the offset of each of the dataloaded routines held in the data section. | |
370 | sub perload'fetch_function_code { | |
371 | package perload; | |
372 | local($start) = 0; | |
373 | local($., $_); | |
374 | while (<main'DATA>) { # First move to start of offset table | |
375 | next if /^#/; | |
376 | last if /^$/ && ++$start > 2; # Skip two blank line after end token | |
377 | } | |
378 | $start = tell(main'DATA); # Offsets in table are relative to here | |
379 | local($key, $value); | |
380 | while (<main'DATA>) { # Load the offset table | |
381 | last if /^$/; # Ends with a single blank line | |
382 | ($key, $value) = split(' '); | |
383 | $Datapos{$key} = $value + $start; | |
384 | } | |
385 | $Datapos{$_[0]}; # All that pain to get this offset... | |
386 | } | |
387 | ||
388 | # | |
389 | # The perl compiler stops here. | |
390 | # | |
391 | ||
392 | __END__ | |
393 | ||
394 | # | |
395 | # Beyond this point lie functions we may never compile. | |
396 | # | |
397 | ||
398 | # | |
399 | # DO NOT CHANGE A IOTA BEYOND THIS COMMENT! | |
400 | # The following table lists offsets of functions within the data section. | |
401 | # Should modifications be needed, change original code and rerun perload | |
402 | # with the -o option to regenerate a proper offset table. | |
403 | # | |
404 | ||
405 | interpreter'error 51675 | |
406 | interpreter'eval_expr 53822 | |
407 | interpreter'evaluate 56190 | |
408 | interpreter'execute 52464 | |
409 | interpreter'push_val 52099 | |
410 | interpreter'update_stack 52968 | |
411 | locate'dump_list 5219 | |
412 | locate'private_units 5352 | |
413 | locate'public_units 6139 | |
414 | locate'units_path 7632 | |
415 | main'add_configure 50796 | |
416 | main'add_obsolete 33314 | |
417 | main'build_extfun 26133 | |
418 | main'build_filext 25782 | |
419 | main'build_makefile 37799 | |
420 | main'build_private 38542 | |
421 | main'build_wanted 27394 | |
422 | main'check_state 51824 | |
423 | main'cmaster 31781 | |
424 | main'complete_line 24485 | |
425 | main'compute_loadable 40540 | |
426 | main'cosmetic_update 48406 | |
427 | main'create_configure 42431 | |
428 | main'dump_obsolete 35957 | |
429 | main'end_extraction 9995 | |
430 | main'extract_dependencies 21627 | |
431 | main'extract_filenames 24925 | |
432 | main'init 2714 | |
433 | main'init_constants 3033 | |
434 | main'init_depend 20477 | |
435 | main'init_except 3575 | |
436 | main'init_extraction 9143 | |
437 | main'init_interp 51524 | |
438 | main'init_keep 51113 | |
439 | main'init_priority 51376 | |
440 | main'interpret 57070 | |
441 | main'locate_units 4602 | |
442 | main'mani_add 49864 | |
443 | main'mani_remove 50228 | |
444 | main'manifake 59389 | |
445 | main'map_obsolete 34152 | |
446 | main'ofound 32371 | |
447 | main'p_c 12564 | |
448 | main'p_config 13870 | |
449 | main'p_default 17683 | |
450 | main'p_include 19574 | |
451 | main'p_init 17541 | |
452 | main'p_layout 19054 | |
453 | main'p_library 19485 | |
454 | main'p_magic 15626 | |
455 | main'p_make 10347 | |
456 | main'p_obsolete 11957 | |
457 | main'p_public 17872 | |
458 | main'p_shell 12111 | |
459 | main'p_wanted 16526 | |
460 | main'parse_files 27710 | |
461 | main'process_command 43224 | |
462 | main'profile 60570 | |
463 | main'q 27239 | |
464 | main'readpackage 58877 | |
465 | main'record_obsolete 34904 | |
466 | main'shmaster 32915 | |
467 | main'skipped 48225 | |
468 | main'solve_dependencies 41708 | |
469 | main'symbols 40026 | |
470 | main'tilda_expand 60215 | |
471 | main'update_makefile 41191 | |
472 | main'usage 3931 | |
473 | main'write_out 19840 | |
474 | ||
475 | # | |
476 | # End of offset table and beginning of dataloading section. | |
477 | # | |
478 | ||
479 | # General initializations | |
480 | sub main'load_init { | |
481 | package main; | |
482 | &init_except; # Token which have upper-cased letters | |
483 | &init_keep; # The keep status for built-in interpreter | |
484 | &init_priority; # Priorities for diadic operators | |
485 | &init_constants; # Define global constants | |
486 | &init_depend; # The %Depend array records control line handling | |
487 | } | |
488 | ||
489 | sub main'load_init_constants { | |
490 | package main; | |
491 | $NEWMANI = 'MANIFEST.new'; # List of files to be scanned | |
492 | $MANI = 'MANIFEST'; # For manifake | |
493 | ||
494 | # The distinction between MANIFEST.new and MANIFEST can make sense | |
495 | # when the "pat" tools are used, but if only metaconfig is used, then | |
496 | # we can very well leave without a MANIFEST.new. --RAM, 2006-08-25 | |
497 | $NEWMANI = $MANI if -f $MANI && ! -f $NEWMANI; | |
498 | } | |
499 | ||
500 | # Record the exceptions -- almost all symbols but these are lower case | |
501 | # We also use three symbols from Unix.U for default file suffixes. | |
502 | sub main'load_init_except { | |
503 | package main; | |
504 | $Except{'Author'}++; | |
505 | $Except{'Date'}++; | |
506 | $Except{'Header'}++; | |
507 | $Except{'Id'}++; | |
508 | $Except{'Locker'}++; | |
509 | $Except{'Log'}++; | |
510 | $Except{'RCSfile'}++; | |
511 | $Except{'Revision'}++; | |
512 | $Except{'Source'}++; | |
513 | $Except{'State'}++; | |
514 | $Except{'_a'}++; | |
515 | $Except{'_o'}++; | |
516 | $Except{'_exe'}++; | |
517 | } | |
518 | ||
519 | # Print out metaconfig's usage and exits | |
520 | sub main'load_usage { | |
521 | package main; | |
522 | print STDERR <<'EOH'; | |
523 | Usage: metaconfig [-dhkmostvwGMV] [-L dir] | |
524 | -d : debug mode. | |
525 | -h : print this help message and exits. | |
526 | -k : keep temporary directory. | |
527 | -m : assume lots of memory and swap space. | |
528 | -o : maps obsolete symbols on new ones. | |
529 | -s : silent mode. | |
530 | -t : trace symbols as they are found. | |
531 | -v : verbose mode. | |
532 | -w : trust Wanted file as being up-to-date. | |
533 | -G : also provide a GNU configure-like front end. | |
534 | -L : specify main units repository. | |
535 | -M : activate production of confmagic.h. | |
536 | -V : print version number and exits. | |
537 | EOH | |
538 | exit 1; | |
539 | } | |
540 | ||
541 | # Locate the units and push their path in @ARGV (sorted alphabetically) | |
542 | sub main'load_locate_units { | |
543 | package locate; | |
544 | print "Locating units...\n" unless $main'opt_s; | |
545 | local(*WD) = *main'WD; # Current working directory | |
546 | local(*MC) = *main'MC; # Public metaconfig library | |
547 | undef %myUlist; # Records private units paths | |
548 | undef %myUseen; # Records private/public conflicts | |
549 | &private_units; # Locate private units in @myUlist | |
550 | &public_units; # Locate public units in @ARGV | |
551 | @ARGV = sort @ARGV; # Sort it alphabetically | |
552 | push(@ARGV, sort @myUlist); # Append user's units sorted | |
553 | &dump_list if $main'opt_v; # Dump the list of units | |
554 | } | |
555 | ||
556 | # Dump the list of units on stdout | |
557 | sub locate'load_dump_list { | |
558 | package locate; | |
559 | print "\t"; | |
560 | $, = "\n\t"; | |
561 | print @ARGV; | |
562 | $, = ''; | |
563 | print "\n"; | |
564 | } | |
565 | ||
566 | # Scan private units | |
567 | sub locate'load_private_units { | |
568 | package locate; | |
569 | return unless -d 'U'; # Nothing to be done if no 'U' entry | |
570 | local(*ARGV) = *myUlist; # Really fill in @myUlist | |
571 | local($MC) = $WD; # We are really in the working directory | |
572 | &units_path("U"); # Locate units in the U directory | |
573 | local($unit_name); # Unit's name (without .U) | |
574 | local(@kept); # Array of kept units | |
575 | # Loop over the units and remove duplicates (the first one seen is the one | |
576 | # we keep). Also set the %myUseen H table to record private units seen. | |
577 | foreach (@ARGV) { | |
578 | ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path | |
579 | next if $myUseen{$unit_name}; # Already recorded | |
580 | $myUseen{$unit_name} = 1; # Record pirvate unit | |
581 | push(@kept, $_); # Keep this unit | |
582 | } | |
583 | @ARGV = @kept; | |
584 | } | |
585 | ||
586 | # Scan public units | |
587 | sub locate'load_public_units { | |
588 | package locate; | |
589 | chdir($MC) || die "Can't find directory $MC.\n"; | |
590 | &units_path("U"); # Locate units in public U directory | |
591 | chdir($WD) || die "Can't go back to directory $WD.\n"; | |
592 | local($path); # Relative path from $WD | |
593 | local($unit_name); # Unit's name (without .U) | |
594 | local(*Unit) = *main'Unit; # Unit is a global from main package | |
595 | local(@kept); # Units kept | |
596 | local(%warned); # Units which have already issued a message | |
597 | # Loop over all the units and keep only the ones that were not found in | |
598 | # the user's U directory. As it is possible two or more units with the same | |
599 | # name be found in | |
600 | foreach (@ARGV) { | |
601 | ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path | |
602 | next if $warned{$unit_name}; # We have already seen this unit | |
603 | $warned{$unit_name} = 1; # Remember we have warned the user | |
604 | if ($myUseen{$unit_name}) { # User already has a private unit | |
605 | $path = $Unit{$unit_name}; # Extract user's unit path | |
606 | next if $path eq $_; # Same path, we must be in mcon/ | |
607 | $path =~ s|^$WD/||o; # Weed out leading working dir path | |
608 | print " Your private $path overrides the public one.\n" | |
609 | unless $main'opt_s; | |
610 | } else { | |
611 | push(@kept, $_); # We may keep this one | |
612 | } | |
613 | } | |
614 | @ARGV = @kept; | |
615 | } | |
616 | ||
617 | # Recursively locate units in the directory. Each file ending with .U has to be | |
618 | # a unit. Others are stat()'ed, and if they are a directory, they are also | |
619 | # scanned through. The $MC and @ARGV variable are dynamically set by the caller. | |
620 | sub locate'load_units_path { | |
621 | package locate; | |
622 | local($dir) = @_; # Directory where units are to be found | |
623 | local(@contents); # Contents of the directory | |
624 | local($unit_name); # Unit's name, without final .U | |
625 | local($path); # Full path of a unit | |
626 | local(*Unit) = *main'Unit; # Unit is a global from main package | |
627 | unless (opendir(DIR, $dir)) { | |
628 | warn("Cannot open directory $dir.\n"); | |
629 | return; | |
630 | } | |
631 | print "Locating in $MC/$dir...\n" if $main'opt_v; | |
632 | @contents = readdir DIR; # Slurp the whole thing | |
633 | closedir DIR; # And close dir, ready for recursion | |
634 | foreach (@contents) { | |
635 | next if $_ eq '.' || $_ eq '..'; | |
636 | if (/\.U$/) { # A unit, definitely | |
637 | ($unit_name) = /^(.*)\.U$/; | |
638 | $path = "$MC/$dir/$_"; # Full path of unit | |
639 | push(@ARGV, $path); # Record its path | |
640 | if (defined $Unit{$unit_name}) { # Already seen this unit | |
641 | if ($main'opt_v) { | |
642 | ($path) = $Unit{$unit_name} =~ m|^(.*)/.*|; | |
643 | print " We've already seen $unit_name.U in $path.\n"; | |
644 | } | |
645 | } else { | |
646 | $Unit{$unit_name} = $path; # Map name to path | |
647 | } | |
648 | next; | |
649 | } | |
650 | # We have found a file which does not look like a unit. If it is a | |
651 | # directory, then scan it. Otherwise skip the file. | |
652 | unless (-d "$dir/$_") { | |
653 | print " Skipping file $_ in $dir.\n" if $main'opt_v; | |
654 | next; | |
655 | } | |
656 | &units_path("$dir/$_"); | |
657 | print "Back to $MC/$dir...\n" if $main'opt_v; | |
658 | } | |
659 | } | |
660 | ||
661 | # Initialize the extraction process by setting some variables. | |
662 | # We return a string to be eval to do more customized initializations. | |
663 | sub main'load_init_extraction { | |
664 | package main; | |
665 | open(INIT, ">$WD/.MT/Init.U") || | |
666 | die "Can't create .MT/Init.U\n"; | |
667 | open(CONF_H, ">$WD/.MT/Config_h.U") || | |
668 | die "Can't create .MT/Config_h.U\n"; | |
669 | open(EXTERN, ">$WD/.MT/Extern.U") || | |
670 | die "Can't create .MT/Extern.U\n"; | |
671 | open(MAGIC_H, ">$WD/.MT/Magic_h.U") || | |
672 | die "Can't create .MT/Magic_h.U\n"; | |
673 | ||
674 | $c_symbol = ''; # Current symbol seen in ?C: lines | |
675 | $s_symbol = ''; # Current symbol seen in ?S: lines | |
676 | $m_symbol = ''; # Current symbol seen in ?M: lines | |
677 | $heredoc = ''; # Last "here" document symbol seen | |
678 | $heredoc_nosubst = 0; # True for <<'EOM' here docs | |
679 | $condlist = ''; # List of conditional symbols | |
680 | $defined = ''; # List of defined symbols in the unit | |
681 | $body = ''; # No procedure to handle body | |
682 | $ending = ''; # No procedure to clean-up | |
683 | } | |
684 | ||
685 | # End the extraction process | |
686 | sub main'load_end_extraction { | |
687 | package main; | |
688 | close EXTERN; # External dependencies (libraries, includes...) | |
689 | close CONF_H; # C symbol definition template | |
690 | close INIT; # Required initializations | |
691 | close MAGIC; # Magic C symbol redefinition templates | |
692 | ||
693 | print $dependencies if $opt_v; # Print extracted dependencies | |
694 | } | |
695 | ||
696 | # Process the ?MAKE: line | |
697 | sub main'load_p_make { | |
698 | package main; | |
699 | local($_) = @_; | |
700 | local(@ary); # Locally defined symbols | |
701 | local(@dep); # Dependencies | |
702 | if (/^[\w+ ]*:/) { # Main dependency rule | |
703 | s|^\s*||; # Remove leading spaces | |
704 | chop; | |
705 | s/:(.*)//; | |
706 | @dep = split(' ', $1); # Dependencies | |
707 | @ary = split(' '); # Locally defined symbols | |
708 | foreach $sym (@ary) { | |
709 | # Symbols starting with a '+' are meant for internal use only. | |
710 | next if $sym =~ s/^\+//; | |
711 | # Only sumbols starting with a lowercase letter are to | |
712 | # appear in config.sh, excepted the ones listed in Except. | |
713 | if ($sym =~ /^[_a-z]/ || $Except{$sym}) { | |
714 | $shmaster{"\$$sym"} = undef; | |
715 | push(@Master,"?$unit:$sym=''\n"); # Initializations | |
716 | } | |
717 | } | |
718 | $condlist = ''; # List of conditional symbols | |
719 | local($sym); # Symbol copy, avoid @dep alteration | |
720 | foreach $dep (@dep) { | |
721 | if ($dep =~ /^\+[A-Za-z]/) { | |
722 | ($sym = $dep) =~ s|^\+||; | |
723 | $condlist .= "$sym "; | |
724 | push(@Cond, $sym) unless $condseen{$sym}; | |
725 | $condseen{$sym}++; # Conditionally wanted | |
726 | } | |
727 | } | |
728 | # Append to already existing dependencies. The 'defined' variable | |
729 | # is set for &write_out, used to implement ?L: and ?I: canvas. It is | |
730 | # reset each time a new unit is parsed. | |
731 | # NB: leading '+' for defined symbols (internal use only) have been | |
732 | # removed at this point, but conditional dependencies still bear it. | |
733 | $defined = join(' ', @ary); # Symbols defined by this unit | |
734 | $dependencies .= $defined . ':' . join(' ', @dep) . "\n"; | |
735 | $dependencies .= " -cond $condlist\n" if $condlist; | |
736 | } else { | |
737 | $dependencies .= $_; # Building rules | |
738 | } | |
739 | } | |
740 | ||
741 | # Process the ?O: line | |
742 | sub main'load_p_obsolete { | |
743 | package main; | |
744 | local($_) = @_; | |
745 | $Obsolete{"$unit.U"} .= $_; # Message(s) to print if unit is used | |
746 | } | |
747 | ||
748 | # Process the ?S: lines | |
749 | sub main'load_p_shell { | |
750 | package main; | |
751 | local($_) = @_; | |
752 | unless ($s_symbol) { | |
753 | if (/^(\w+).*:/) { | |
754 | $s_symbol = $1; | |
755 | print " ?S: $s_symbol\n" if $opt_d; | |
756 | } else { | |
757 | warn "\"$file\", line $.: syntax error in ?S: construct.\n"; | |
758 | $s_symbol = $unit; | |
759 | return; | |
760 | } | |
761 | # Deal with obsolete symbol list (enclosed between parenthesis) | |
762 | &record_obsolete("\$$_") if /\(/; | |
763 | } | |
764 | m|^\.\s*$| && ($s_symbol = ''); # End of comment | |
765 | } | |
766 | ||
767 | # Process the ?C: lines | |
768 | sub main'load_p_c { | |
769 | package main; | |
770 | local($_) = @_; | |
771 | unless ($c_symbol) { | |
772 | if (s/^(\w+)\s*~\s*(\S+)\s*(.*):/$1 $3:/) { | |
773 | # The ~ operator aliases the main C symbol to another symbol which | |
774 | # is to be used instead for definition in config.h. That is to say, | |
775 | # the line '?C:SYM ~ other:' would look for symbol 'other' instead, | |
776 | # and the documentation for symbol SYM would only be included in | |
777 | # config.h if 'other' were actually wanted. | |
778 | $c_symbol = $2; # Alias for definition in config.h | |
779 | print " ?C: $1 ~ $c_symbol\n" if $opt_d; | |
780 | } elsif (/^(\w+).*:/) { | |
781 | # Default behaviour. Include in config.h if symbol is needed. | |
782 | $c_symbol = $1; | |
783 | print " ?C: $c_symbol\n" if $opt_d; | |
784 | } else { | |
785 | warn "\"$file\", line $.: syntax error in ?C: construct.\n"; | |
786 | $c_symbol = $unit; | |
787 | return; | |
788 | } | |
789 | # Deal with obsolete symbol list (enclosed between parenthesis) and | |
790 | # make sure that list do not appear in config.h.SH by removing it. | |
791 | &record_obsolete("$_") if /\(/; | |
792 | s/\s*\(.*\)//; # Get rid of obsolete symbol list | |
793 | } | |
794 | s|^(\w+)\s*|?$c_symbol:/* $1| || # Start of comment | |
795 | (s|^\.\s*$|?$c_symbol: */\n| && ($c_symbol = '', 1)) || # End of comment | |
796 | s|^(.*)|?$c_symbol: *$1|; # Middle of comment | |
797 | &p_config("$_"); # Add comments to config.h.SH | |
798 | } | |
799 | ||
800 | # Process the ?H: lines | |
801 | sub main'load_p_config { | |
802 | package main; | |
803 | local($_) = @_; | |
804 | local($constraint); # Constraint to be used for inclusion | |
805 | ++$old_version if s/^\?%1://; # Old version | |
806 | if (s/^\?(\w+)://) { # Remove leading '?var:' | |
807 | $constraint = $1; # Constraint is leading '?var' | |
808 | } else { | |
809 | $constraint = ''; # No constraint | |
810 | } | |
811 | if (/^#.*\$/) { # Look only for cpp lines | |
812 | if (m|^#\$(\w+)\s+(\w+).*\$(\w+)|) { | |
813 | # Case: #$d_var VAR "$var" | |
814 | $constraint = $2 unless $constraint; | |
815 | print " ?H: ($constraint) #\$$1 $2 \"\$$3\"\n" if $opt_d; | |
816 | $cmaster{$2} = undef; | |
817 | $cwanted{$2} = "$1\n$3"; | |
818 | } elsif (m|^#define\s+(\w+)\((.*)\)\s+\$(\w+)|) { | |
819 | # Case: #define VAR(x) $var | |
820 | $constraint = $1 unless $constraint; | |
821 | print " ?H: ($constraint) #define $1($2) \$$3\n" if $opt_d; | |
822 | $cmaster{$1} = undef; | |
823 | $cwanted{$1} = $3; | |
824 | } elsif (m|^#\$define\s+(\w+)|) { | |
825 | # Case: #$define VAR | |
826 | $constraint = $1 unless $constraint; | |
827 | print " ?H: ($constraint) #define $1\n" if $opt_d; | |
828 | $cmaster{$1} = undef; | |
829 | $cwanted{$1} = "define\n$unit"; | |
830 | } elsif (m|^#\$(\w+)\s+(\w+)|) { | |
831 | # Case: #$d_var VAR | |
832 | $constraint = $2 unless $constraint; | |
833 | print " ?H: ($constraint) #\$$1 $2\n" if $opt_d; | |
834 | $cmaster{$2} = undef; | |
835 | $cwanted{$2} = $1; | |
836 | } elsif (m|^#define\s+(\w+).*\$(\w+)|) { | |
837 | # Case: #define VAR "$var" | |
838 | $constraint = $1 unless $constraint; | |
839 | print " ?H: ($constraint) #define $1 \"\$$2\"\n" if $opt_d; | |
840 | $cmaster{$1} = undef; | |
841 | $cwanted{$1} = $2; | |
842 | } else { | |
843 | $constraint = $unit unless $constraint; | |
844 | print " ?H: ($constraint) $_" if $opt_d; | |
845 | } | |
846 | } else { | |
847 | print " ?H: ($constraint) $_" if $opt_d; | |
848 | } | |
849 | # If not a single ?H:. line, add the leading constraint | |
850 | s/^\.// || s/^/?$constraint:/; | |
851 | print CONF_H; | |
852 | } | |
853 | ||
854 | # Process the ?M: lines | |
855 | sub main'load_p_magic { | |
856 | package main; | |
857 | local($_) = @_; | |
858 | unless ($m_symbol) { | |
859 | if (/^(\w+):\s*([\w\s]*)\n$/) { | |
860 | # A '?M:sym:' line implies a '?W:%<:sym' since we'll need to know | |
861 | # about the wantedness of sym later on when building confmagic.h. | |
862 | # Buf is sym is wanted, then the C symbol dependencies have to | |
863 | # be triggered. That is done by introducing sym in the mwanted | |
864 | # array, known by the Wanted file construction process... | |
865 | $m_symbol = $1; | |
866 | print " ?M: $m_symbol\n" if $opt_d; | |
867 | $mwanted{$m_symbol} = $2; # Record C dependencies | |
868 | &p_wanted("$unit:$m_symbol"); # Build fake ?W: line | |
869 | } else { | |
870 | warn "\"$file\", line $.: syntax error in ?M: construct.\n"; | |
871 | } | |
872 | return; | |
873 | } | |
874 | (s/^\.\s*$/?$m_symbol:\n/ && ($m_symbol = '', 1)) || # End of block | |
875 | s/^/?$m_symbol:/; | |
876 | print MAGIC_H; # Definition goes to confmagic.h | |
877 | print " ?M: $_" if $opt_d; | |
878 | } | |
879 | ||
880 | # Process the ?W: lines | |
881 | sub main'load_p_wanted { | |
882 | package main; | |
883 | # Syntax is ?W:<shell symbols>:<C symbols> | |
884 | local($active) = $_[0] =~ /^([^:]*):/; # Symbols to activate | |
885 | local($look_symbols) = $_[0] =~ /:(.*)/; # When those are used | |
886 | local(@syms) = split(/ /, $look_symbols); # Keep original spacing info | |
887 | $active =~ s/\s+/\n/g; # One symbol per line | |
888 | ||
889 | # Concatenate quoted strings, so saying something like 'two words' will | |
890 | # be introduced as one single symbol "two words". | |
891 | local(@symbols); # Concatenated symbols to look for | |
892 | local($concat) = ''; # Concatenation buffer | |
893 | foreach (@syms) { | |
894 | if (s/^\'//) { | |
895 | $concat = $_; | |
896 | } elsif (s/\'$//) { | |
897 | push(@symbols, $concat . ' ' . $_); | |
898 | $concat = ''; | |
899 | } else { | |
900 | push(@symbols, $_) unless $concat; | |
901 | $concat .= ' ' . $_ if $concat; | |
902 | } | |
903 | } | |
904 | ||
905 | # Now record symbols in master and wanted tables | |
906 | foreach (@symbols) { | |
907 | $cmaster{$_} = undef; # Asks for look-up in C files | |
908 | $cwanted{$_} = "$active" if $active; # Shell symbols to activate | |
909 | } | |
910 | } | |
911 | ||
912 | # Process the ?INIT: lines | |
913 | sub main'load_p_init { | |
914 | package main; | |
915 | local($_) = @_; | |
916 | print INIT "?$unit:", $_; # Wanted only if unit is loaded | |
917 | } | |
918 | ||
919 | # Process the ?D: lines | |
920 | sub main'load_p_default { | |
921 | package main; | |
922 | local($_) = @_; | |
923 | s/^([A-Za-z_]+)=(.*)/\@if !$1\n%$1:$1=$2\n\@define $1\n\@end/ | |
924 | && ($hasdefault{$1}++, print INIT $_); | |
925 | } | |
926 | ||
927 | # Process the ?P: lines | |
928 | sub main'load_p_public { | |
929 | package main; | |
930 | local($_) = @_; | |
931 | local($csym); # C symbol(s) we're trying to look at | |
932 | local($nosym); # List of symbol(s) which mustn't be wanted | |
933 | local($cfile); # Name of file implementing csym (no .ext) | |
934 | ($csym, $nosym, $cfile) = /([^()]+)\s*(\(.*\))\s*:\s*(\S+)/; | |
935 | unless ($csym eq '' || $cfile eq '') { | |
936 | # Add dependencies for each C symbol, of the form: | |
937 | # -pick public <sym> <file> <notdef symbols list> | |
938 | # and the file will be added to config.c whenever sym is wanted and | |
939 | # none of the notdef symbols is wanted. | |
940 | foreach $sym (split(' ', $csym)) { | |
941 | $dependencies .= "\t-pick public $sym $cfile $nosym\n"; | |
942 | } | |
943 | } | |
944 | } | |
945 | ||
946 | # Process the ?Y: lines | |
947 | # Valid layouts are for now are: top, bottom, default. | |
948 | # | |
949 | # NOTA BENE: | |
950 | # This routine relies on the $defined variable, a global variable set | |
951 | # during the ?MAKE: processing, which lists all the defined symbols in | |
952 | # the unit (the optional leading '+' for internal symbols has been removed | |
953 | # if present). | |
954 | # | |
955 | # The routine fills up a %Layout table, indexed by symbol, yielding the | |
956 | # layout imposed to this unit. That table will then be used later on when | |
957 | # we sort wanted symbols for the Makefile. | |
958 | sub main'load_p_layout { | |
959 | package main; | |
960 | local($_) = @_; | |
961 | local($layout) = /^\s*(\w+)/; | |
962 | $layout =~ tr/A-Z/a-z/; # Case is not significant for layouts | |
963 | unless (defined $Lcmp{$layout}) { | |
964 | warn "\"$file\", line $.: unknown layout directive '$layout'.\n"; | |
965 | return; | |
966 | } | |
967 | foreach $sym (split(' ', $defined)) { | |
968 | $Layout{$sym} = $Lcmp{$layout}; | |
969 | } | |
970 | } | |
971 | ||
972 | # Process the ?L: lines | |
973 | # There should not be any '-l' in front of the library name | |
974 | sub main'load_p_library { | |
975 | package main; | |
976 | &write_out("L:$_"); | |
977 | } | |
978 | ||
979 | # Process the ?I: lines | |
980 | sub main'load_p_include { | |
981 | package main; | |
982 | &write_out("I:$_"); | |
983 | } | |
984 | ||
985 | # Write out line in file Extern.U. The information recorded there has the | |
986 | # following prototypical format: | |
987 | # ?symbol:L:inet bsd | |
988 | # If 'symbol' is wanted, then 'inet bsd' will be added to $libswanted. | |
989 | sub main'load_write_out { | |
990 | package main; | |
991 | local($_) = @_; | |
992 | local($target) = $defined; # By default, applies to defined symbols | |
993 | $target = $1 if s/^(.*)://; # List is qualified "?L:target:symbols" | |
994 | local(@target) = split(' ', $target); | |
995 | chop; | |
996 | foreach $key (@target) { | |
997 | print EXTERN "?$key:$_\n"; # EXTERN file defined in xref.pl | |
998 | } | |
999 | } | |
1000 | ||
1001 | # The %Depend array records the functions we use to process the configuration | |
1002 | # lines in the unit, with a special meaning. It is important that all the | |
1003 | # known control symbols be listed below, so that metalint does not complain. | |
1004 | # The %Lcmp array contains valid layouts and their comparaison value. | |
1005 | sub main'load_init_depend { | |
1006 | package main; | |
1007 | %Depend = ( | |
1008 | 'MAKE', 'p_make', # The ?MAKE: line records dependencies | |
1009 | 'INIT', 'p_init', # Initializations printed verbatim | |
1010 | 'LINT', 'p_lint', # Hints for metalint | |
1011 | 'RCS', 'p_ignore', # RCS comments are ignored | |
1012 | 'C', 'p_c', # C symbols | |
1013 | 'D', 'p_default', # Default value for conditional symbols | |
1014 | 'E', 'p_example', # Example of usage | |
1015 | 'F', 'p_file', # Produced files | |
1016 | 'H', 'p_config', # Process the config.h lines | |
1017 | 'I', 'p_include', # Added includes | |
1018 | 'L', 'p_library', # Added libraries | |
1019 | 'M', 'p_magic', # Process the confmagic.h lines | |
1020 | 'O', 'p_obsolete', # Unit obsolescence | |
1021 | 'P', 'p_public', # Location of PD implementation file | |
1022 | 'S', 'p_shell', # Shell variables | |
1023 | 'T', 'p_temp', # Shell temporaries used | |
1024 | 'V', 'p_visible', # Visible symbols like 'rp', 'dflt' | |
1025 | 'W', 'p_wanted', # Wanted value for interpreter | |
1026 | 'X', 'p_ignore', # User comment is ignored | |
1027 | 'Y', 'p_layout', # User-defined layout preference | |
1028 | ); | |
1029 | %Lcmp = ( | |
1030 | 'top', -1, | |
1031 | 'default', 0, | |
1032 | 'bottom', 1, | |
1033 | ); | |
1034 | } | |
1035 | ||
1036 | # Extract dependencies from units held in @ARGV | |
1037 | sub main'load_extract_dependencies { | |
1038 | package main; | |
1039 | local($proc); # Procedure used to handle a ctrl line | |
1040 | local($file); # Current file scanned | |
1041 | local($dir, $unit); # Directory and unit's name | |
1042 | local($old_version) = 0; # True when old-version unit detected | |
1043 | local($mc) = "$MC/U"; # Public metaconfig directory | |
1044 | local($line); # Last processed line for metalint | |
1045 | ||
1046 | printf "Extracting dependency lists from %d units...\n", $#ARGV+1 | |
1047 | unless $opt_s; | |
1048 | ||
1049 | chdir $WD; # Back to working directory | |
1050 | &init_extraction; # Initialize extraction files | |
1051 | $dependencies = ' ' x (50 * @ARGV); # Pre-extend | |
1052 | $dependencies = ''; | |
1053 | ||
1054 | # We do not want to use the <> construct here, because we need the | |
1055 | # name of the opened files (to get the unit's name) and we want to | |
1056 | # reset the line number for each files, and do some pre-processing. | |
1057 | ||
1058 | file: while ($file = shift(@ARGV)) { | |
1059 | close FILE; # Reset line number | |
1060 | $old_version = 0; # True if unit is an old version | |
1061 | if (open(FILE, $file)) { | |
1062 | ($dir, $unit) = ('', $file) | |
1063 | unless ($dir, $unit) = ($file =~ m|(.*)/(.*)|); | |
1064 | $unit =~ s|\.U$||; # Remove extension | |
1065 | } else { | |
1066 | warn("Can't open $file.\n"); | |
1067 | } | |
1068 | # If unit is in the standard public directory, keep only the unit name | |
1069 | $file = "$unit.U" if $dir eq $mc; | |
1070 | print "$dir/$unit.U:\n" if $opt_d; | |
1071 | line: while (<FILE>) { | |
1072 | $line = $_; # Save last processed unit line | |
1073 | if (s/^\?([\w\-]+)://) { # We may have found a control line | |
1074 | $proc = $Depend{$1}; # Look for a procedure to handle it | |
1075 | unless ($proc) { # Unknown control line | |
1076 | $proc = $1; # p_unknown expects symbol in '$proc' | |
1077 | eval '&p_unknown'; # Signal error (metalint only) | |
1078 | next line; # And go on next line | |
1079 | } | |
1080 | # Long lines may be escaped with a final backslash | |
1081 | $_ .= &complete_line(FILE) if s/\\\s*$//; | |
1082 | # Run macros substitutions | |
1083 | s/%</$unit/g; # %< expands into the unit's name | |
1084 | if (s/%\*/$unit/) { | |
1085 | # %* expanded into the entire set of defined symbols | |
1086 | # in the old version. Now it is only the unit's name. | |
1087 | ++$old_version; | |
1088 | } | |
1089 | eval { &$proc($_) }; # Process the line | |
1090 | } else { | |
1091 | next file unless $body; # No procedure to handle body | |
1092 | do { | |
1093 | $line = $_; # Save last processed unit line | |
1094 | eval { &$body($_) } ; # From now on, it's the unit body | |
1095 | } while (defined ($_ = <FILE>)); | |
1096 | next file; | |
1097 | } | |
1098 | } | |
1099 | } continue { | |
1100 | warn(" Warning: $file is a pre-3.0 version.\n") if $old_version; | |
1101 | &$ending($line) if $ending; # Post-processing for metalint | |
1102 | } | |
1103 | ||
1104 | &end_extraction; # End the extraction process | |
1105 | } | |
1106 | ||
1107 | # The first line was escaped with a final \ character. Every following line | |
1108 | # is to be appended to it (until we found a real \n not escaped). Note that | |
1109 | # the leading spaces of the continuation line are removed, so any space should | |
1110 | # be added before the former \ if needed. | |
1111 | sub main'load_complete_line { | |
1112 | package main; | |
1113 | local($file) = @_; # File where lines come from | |
1114 | local($_); | |
1115 | local($read) = ''; # Concatenation of all the continuation lines found | |
1116 | while (<$file>) { | |
1117 | s/^\s+//; # Remove leading spaces | |
1118 | if (s/\\\s*$//) { # Still followed by a continuation line | |
1119 | $read .= $_; | |
1120 | } else { # We've reached the end of the continuation | |
1121 | return $read . $_; | |
1122 | } | |
1123 | } | |
1124 | } | |
1125 | ||
1126 | # Extract filenames from manifest | |
1127 | sub main'load_extract_filenames { | |
1128 | package main; | |
1129 | &build_filext; # Construct &is_cfile and &is_shfile | |
1130 | print "Extracting filenames (C and SH files) from $NEWMANI...\n" | |
1131 | unless $opt_s; | |
1132 | open(NEWMANI,$NEWMANI) || die "Can't open $NEWMANI.\n"; | |
1133 | local($file); | |
1134 | while (<NEWMANI>) { | |
1135 | ($file) = split(' '); | |
1136 | next if $file eq 'config_h.SH'; # skip config_h.SH | |
1137 | next if $file eq 'Configure'; # also skip Configure | |
1138 | next if $file eq 'confmagic.h' && $opt_M; | |
1139 | push(@SHlist, $file) if &is_shfile($file); | |
1140 | push(@clist, $file) if &is_cfile($file); | |
1141 | } | |
1142 | } | |
1143 | ||
1144 | # Construct two file identifiers based on the file suffix: one for C files, | |
1145 | # and one for SH files (using the $cext and $shext variables) defined in | |
1146 | # the .package file. | |
1147 | # The &is_cfile and &is_shfile routine may then be called to known whether | |
1148 | # a given file is a candidate for holding C or SH symbols. | |
1149 | sub main'load_build_filext { | |
1150 | package main; | |
1151 | &build_extfun('is_cfile', $cext, '.c .h .y .l'); | |
1152 | &build_extfun('is_shfile', $shext, '.SH'); | |
1153 | } | |
1154 | ||
1155 | # Build routine $name to identify extensions listed in $exts, ensuring | |
1156 | # that $minimum is at least matched (both to be backward compatible with | |
1157 | # older .package and because it is really the minimum requirred). | |
1158 | sub main'load_build_extfun { | |
1159 | package main; | |
1160 | local($name, $exts, $minimum) = @_; | |
1161 | local(@single); # Single letter dot extensions (may be grouped) | |
1162 | local(@others); # Other extensions | |
1163 | local(%seen); # Avoid duplicate extensions | |
1164 | foreach $ext (split(' ', "$exts $minimum")) { | |
1165 | next if $seen{$ext}++; | |
1166 | if ($ext =~ s/^\.(\w)$/$1/) { | |
1167 | push(@single, $ext); | |
1168 | } else { | |
1169 | # Convert into perl's regexp | |
1170 | $ext =~ s/\./\\./g; # Escape . | |
1171 | $ext =~ s/\?/./g; # ? turns into . | |
1172 | $ext =~ s/\*/.*/g; # * turns into .* | |
1173 | push(@others, $ext); | |
1174 | } | |
1175 | } | |
1176 | local($fn) = &q(<<EOF); # Function being built | |
1177 | :sub $name { | |
1178 | : local(\$_) = \@_; | |
1179 | EOF | |
1180 | local($single); # Single regexp: .c .h grouped into .[ch] | |
1181 | $single = '\.[' . join('', @single) . ']' if @single; | |
1182 | $fn .= &q(<<EOL) if @single; | |
1183 | : return 1 if /$single\$/; | |
1184 | EOL | |
1185 | foreach $ext (@others) { | |
1186 | $fn .= &q(<<EOL); | |
1187 | : return 1 if /$ext\$/; | |
1188 | EOL | |
1189 | } | |
1190 | $fn .= &q(<<EOF); | |
1191 | : 0; # None of the extensions may be applied to file name | |
1192 | :} | |
1193 | EOF | |
1194 | print $fn if $opt_d; | |
1195 | eval $fn; | |
1196 | chop($@) && die "Can't compile '$name':\n$fn\n$@.\n"; | |
1197 | } | |
1198 | ||
1199 | # Remove ':' quotations in front of the lines | |
1200 | sub main'load_q { | |
1201 | package main; | |
1202 | local($_) = @_; | |
1203 | #ocal($*) =1; | |
1204 | s/^://gm; | |
1205 | $_; | |
1206 | } | |
1207 | ||
1208 | # Build a wanted file from the files held in @SHlist and @clist arrays | |
1209 | sub main'load_build_wanted { | |
1210 | package main; | |
1211 | # If wanted file is already there, parse it to map obsolete if -o option | |
1212 | # was used. Otherwise, build a new one. | |
1213 | if (-f 'Wanted') { | |
1214 | &map_obsolete if $opt_o; # Build Obsol*.U files | |
1215 | &dump_obsolete; # Dump obsolete symbols if any | |
1216 | return; | |
1217 | } | |
1218 | &parse_files; | |
1219 | } | |
1220 | ||
1221 | sub main'load_parse_files { | |
1222 | package main; | |
1223 | print "Building a Wanted file...\n" unless $opt_s; | |
1224 | open(WANTED,"| sort | uniq >Wanted") || die "Can't create Wanted.\n"; | |
1225 | unless (-f $NEWMANI) { | |
1226 | &manifake; | |
1227 | die "No $NEWMANI--can't build a Wanted file.\n" unless -f $NEWMANI; | |
1228 | } | |
1229 | ||
1230 | local($search); # Where to-be-evaled script is held | |
1231 | local($_) = ' ' x 50000 if $opt_m; # Pre-extend pattern search space | |
1232 | local(%visited); # Records visited files | |
1233 | local(%lastfound); # Where last occurence of key was | |
1234 | ||
1235 | # Now we are a little clever, and build a loop to eval so that we don't | |
1236 | # have to recompile our patterns on every file. We also use "study" since | |
1237 | # we are searching the same string for many different things. Hauls! | |
1238 | ||
1239 | if (@clist) { | |
1240 | local($others) = $cext ? " $cext" : ''; | |
1241 | print " Scanning .[chyl]$others files for symbols...\n" | |
1242 | unless $opt_s; | |
1243 | $search = ' ' x (40 * (@cmaster + @ocmaster)); # Pre-extend | |
1244 | $search = "while (<>) {study;\n"; # Init loop over ARGV | |
1245 | foreach $key (keys(%cmaster)) { | |
1246 | $search .= "&cmaster('$key') if /\\b$key\\b/;\n"; | |
1247 | } | |
1248 | foreach $key (grep(!/^\$/, keys %Obsolete)) { | |
1249 | $search .= "&ofound('$key') if /\\b$key\\b/;\n"; | |
1250 | } | |
1251 | $search .= "}\n"; # terminate loop | |
1252 | print $search if $opt_d; | |
1253 | @ARGV = @clist; | |
1254 | # Swallow each file as a whole, if memory is available | |
1255 | undef $/ if $opt_m; | |
1256 | eval $search; | |
1257 | eval ''; | |
1258 | $/ = "\n"; | |
1259 | while (($key,$value) = each(%cmaster)) { | |
1260 | print WANTED $cwanted{$key}, "\n", ">$key", "\n" if $value; | |
1261 | } | |
1262 | } | |
1263 | ||
1264 | # If they don't use magic but use magically guarded symbols without | |
1265 | # their corresponding C symbol dependency, warn them, since they might | |
1266 | # not know about that portability issue. | |
1267 | ||
1268 | if (@clist && !$opt_M) { | |
1269 | local($nused); # list of non-used symbols | |
1270 | local($warning) = 0; # true when one warning issued | |
1271 | foreach $cmag (keys %mwanted) { # loop over all used magic symbols | |
1272 | next unless $cmaster{$cmag}; | |
1273 | $nused = ''; | |
1274 | foreach $cdep (split(' ', $mwanted{$cmag})) { | |
1275 | $nused .= " $cdep" unless $cmaster{$cdep}; | |
1276 | } | |
1277 | $nused =~ s/^ //; | |
1278 | $nused = "one of " . $nused if $nused =~ s/ /, /g; | |
1279 | if ($nused ne '') { | |
1280 | print " Warning: $cmag is used without $nused.\n"; | |
1281 | $warning++; | |
1282 | } | |
1283 | } | |
1284 | if ($warning) { | |
1285 | local($those) = $warning == 1 ? 'that' : 'those'; | |
1286 | local($s) = $warning == 1 ? '' : 's'; | |
1287 | print "Note: $those previous warning$s may be suppressed by -M.\n"; | |
1288 | } | |
1289 | } | |
1290 | ||
1291 | # Cannot remove $cmaster as it is used later on when building Configure | |
1292 | undef @clist; | |
1293 | undef %cwanted; | |
1294 | undef %mwanted; | |
1295 | %visited = (); | |
1296 | %lastfound = (); | |
1297 | ||
1298 | if (@SHlist) { | |
1299 | local($others) = $shext ? " $shext" : ''; | |
1300 | print " Scanning .SH$others files for symbols...\n" unless $opt_s; | |
1301 | $search = ' ' x (40 * (@shmaster + @oshmaster)); # Pre-extend | |
1302 | $search = "while (<>) {study;\n"; | |
1303 | # All the keys already have a leading '$' | |
1304 | foreach $key (keys(%shmaster)) { | |
1305 | $search .= "&shmaster('$key') if /\\$key\\b/;\n"; | |
1306 | } | |
1307 | foreach $key (grep (/^\$/, keys %Obsolete)) { | |
1308 | $search .= "&ofound('$key') if /\\$key\\b/;\n"; | |
1309 | } | |
1310 | $search .= "}\n"; | |
1311 | print $search if $opt_d; | |
1312 | @ARGV = @SHlist; | |
1313 | # Swallow each file as a whole, if memory is available | |
1314 | undef $/ if $opt_m; | |
1315 | eval $search; | |
1316 | eval ''; | |
1317 | $/ = "\n"; | |
1318 | while (($key,$value) = each(%shmaster)) { | |
1319 | if ($value) { | |
1320 | $key =~ s/^\$//; | |
1321 | print WANTED $key, "\n"; | |
1322 | } | |
1323 | } | |
1324 | } | |
1325 | ||
1326 | # Obsolete symbols, if any, are written in the Wanted file preceded by a | |
1327 | # '!' character. In case -w is used, we'll thus be able to correctly build | |
1328 | # the Obsol_h.U and Obsol_sh.U files. | |
1329 | ||
1330 | &add_obsolete; # Add obsolete symbols in Wanted file | |
1331 | ||
1332 | close WANTED; | |
1333 | ||
1334 | # If obsolete symbols where found, write an Obsolete file which lists where | |
1335 | # each of them appear and the new symbol to be used. Also write Obsol_h.U | |
1336 | # and Obsol_sh.U in .MT for later perusal. | |
1337 | ||
1338 | &dump_obsolete; # Dump obsolete symbols if any | |
1339 | ||
1340 | die "No desirable symbols found--aborting.\n" unless -s 'Wanted'; | |
1341 | ||
1342 | # Clean-up memory by freeing useless data structures | |
1343 | undef @SHlist; | |
1344 | undef %shmaster; | |
1345 | } | |
1346 | ||
1347 | # This routine records matches of C master keys | |
1348 | sub main'load_cmaster { | |
1349 | package main; | |
1350 | local($key) = @_; | |
1351 | $cmaster{$key}++; # This symbol is wanted | |
1352 | return unless $opt_t || $opt_M; # Return if neither -t nor -M | |
1353 | if ($opt_t && | |
1354 | $lastfound{$key} ne $ARGV # Never mentionned for this file ? | |
1355 | ) { | |
1356 | $visited{$ARGV}++ || print $ARGV,":\n"; | |
1357 | print "\t$key\n"; | |
1358 | $lastfound{$key} = $ARGV; | |
1359 | } | |
1360 | if ($opt_M && | |
1361 | defined($mwanted{$key}) # Found a ?M: symbol | |
1362 | ) { | |
1363 | foreach $csym (split(' ', $mwanted{$key})) { | |
1364 | $cmaster{$csym}++; # Activate C symbol dependencies | |
1365 | } | |
1366 | } | |
1367 | } | |
1368 | ||
1369 | # This routine records matches of obsolete keys (C or shell) | |
1370 | sub main'load_ofound { | |
1371 | package main; | |
1372 | local($key) = @_; | |
1373 | local($_) = $Obsolete{$key}; # Value of new symbol | |
1374 | $ofound{"$ARGV $key $_"}++; # Record obsolete match | |
1375 | $cmaster{$_}++ unless /^\$/; # A C hit | |
1376 | $shmaster{$_}++ if /^\$/; # Or a shell one | |
1377 | return unless $opt_t; # Continue if trace option on | |
1378 | if ($lastfound{$key} ne $ARGV) { # Never mentionned for this file ? | |
1379 | $visited{$ARGV}++ || print $ARGV,":\n"; | |
1380 | print "\t$key (obsolete, use $_)\n"; | |
1381 | $lastfound{$key} = $ARGV; | |
1382 | } | |
1383 | } | |
1384 | ||
1385 | # This routine records matches of shell master keys | |
1386 | sub main'load_shmaster { | |
1387 | package main; | |
1388 | local($key) = @_; | |
1389 | $shmaster{$key}++; # This symbol is wanted | |
1390 | return unless $opt_t; # Continue if trace option on | |
1391 | if ($lastfound{$key} ne $ARGV) { # Never mentionned for this file ? | |
1392 | $visited{$ARGV}++ || print $ARGV,":\n"; | |
1393 | print "\t$key\n"; | |
1394 | $lastfound{$key} = $ARGV; | |
1395 | } | |
1396 | } | |
1397 | ||
1398 | # Write obsolete symbols into the Wanted file for later perusal by -w. | |
1399 | sub main'load_add_obsolete { | |
1400 | package main; | |
1401 | local($file); # File where obsolete symbol was found | |
1402 | local($old); # Name of this old symbol | |
1403 | local($new); # Value of the new symbol to be used | |
1404 | foreach $key (sort keys %ofound) { | |
1405 | ($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/); | |
1406 | if ($new =~ s/^\$//) { # We found an obsolete shell symbol | |
1407 | print WANTED "!$old\n"; | |
1408 | } else { # We found an obsolete C symbol | |
1409 | print WANTED "!>$old\n"; | |
1410 | } | |
1411 | } | |
1412 | } | |
1413 | ||
1414 | # Map obsolete symbols from Wanted file into %Obsolete and call dump_obsolete | |
1415 | # to actually build the Obsol_sh.U and Obsol_h.U files. Those will be needed | |
1416 | # during the Configure building phase to actually do the remaping. | |
1417 | # The obsolete symbols found are entered in the %ofound array, tagged as from | |
1418 | # file 'XXX', which is specially recognized by dump_obsolete. | |
1419 | sub main'load_map_obsolete { | |
1420 | package main; | |
1421 | open(WANTED, 'Wanted') || die "Can't open Wanted file.\n"; | |
1422 | local($new); # New symbol to be used instead of obsolete one | |
1423 | while (<WANTED>) { | |
1424 | chop; | |
1425 | next unless s/^!//; # Skip non-obsolete symbols | |
1426 | if (s/^>//) { # C symbol | |
1427 | $new = $Obsolete{$_}; # Fetch new symbol | |
1428 | $ofound{"XXX $_ $new"}++; # Record obsolete match (XXX = no file) | |
1429 | } else { # Shell symbol | |
1430 | $new = $Obsolete{"\$$_"}; # Fetch new symbol | |
1431 | $ofound{"XXX \$$_ $new"}++; # Record obsolete match (XXX = no file) | |
1432 | } | |
1433 | } | |
1434 | close WANTED; | |
1435 | } | |
1436 | ||
1437 | # Record obsolete symbols association (new versus old), that is to say for a | |
1438 | # given old symbol, $Obsolete{'old'} = new symbol to be used. A '$' is prepended | |
1439 | # for all shell variables | |
1440 | sub main'load_record_obsolete { | |
1441 | package main; | |
1442 | local($_) = @_; | |
1443 | local(@obsoleted); # List of obsolete symbols | |
1444 | local($symbol); # New symbol which must be used | |
1445 | local($dollar) = s/^\$// ? '$':''; # The '$' or a null string | |
1446 | # Syntax for obsolete symbols specification is | |
1447 | # list of symbols (obsolete ones): | |
1448 | if (/^(\w+)\s*\((.*)\)\s*:$/) { | |
1449 | $symbol = "$dollar$1"; | |
1450 | @obsoleted = split(' ', $2); # List of obsolete symbols | |
1451 | } else { | |
1452 | if (/^(\w+)\s*\((.*):$/) { | |
1453 | warn "\"$file\", line $.: final ')' before ':' missing.\n"; | |
1454 | $symbol = "$dollar$1"; | |
1455 | @obsoleted = split(' ', $2); | |
1456 | } else { | |
1457 | warn "\"$file\", line $.: syntax error.\n"; | |
1458 | return; | |
1459 | } | |
1460 | } | |
1461 | foreach $val (@obsoleted) { | |
1462 | $_ = $dollar . $val; | |
1463 | if (defined $Obsolete{$_}) { | |
1464 | warn "\"$file\", line $.: '$_' already obsoleted by '$Obsolete{$_}'.\n"; | |
1465 | } else { | |
1466 | $Obsolete{$_} = $symbol; # Record (old, new) tuple | |
1467 | } | |
1468 | } | |
1469 | } | |
1470 | ||
1471 | # Dump obsolete symbols used in file 'Obsolete'. Also write Obsol_h.U and | |
1472 | # Obsol_sh.U to record old versus new mappings if the -o option was used. | |
1473 | sub main'load_dump_obsolete { | |
1474 | package main; | |
1475 | unless (-f 'Obsolete') { | |
1476 | open(OBSOLETE, ">Obsolete") || die "Can't create Obsolete.\n"; | |
1477 | } | |
1478 | open(OBSOL_H, ">.MT/Obsol_h.U") || die "Can't create .MT/Obsol_h.U.\n"; | |
1479 | open(OBSOL_SH, ">.MT/Obsol_sh.U") || die "Can't create .MT/Obsol_sh.U.\n"; | |
1480 | local($file); # File where obsolete symbol was found | |
1481 | local($old); # Name of this old symbol | |
1482 | local($new); # Value of the new symbol to be used | |
1483 | # Leave a blank line at the top so that anny added ^L will stand on a line | |
1484 | # by itself (the formatting process adds a ^L when a new page is needed). | |
1485 | format OBSOLETE_TOP = | |
1486 | ||
1487 | File | Old symbol | New symbol | |
1488 | -----------------------------------+----------------------+--------------------- | |
1489 | . | |
1490 | format OBSOLETE = | |
1491 | @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | |
1492 | $file, $old, $new | |
1493 | . | |
1494 | local(%seen); | |
1495 | foreach $key (sort keys %ofound) { | |
1496 | ($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/); | |
1497 | write(OBSOLETE) unless $file eq 'XXX'; | |
1498 | next unless $opt_o; # Obsolete mapping done only with -o | |
1499 | next if $seen{$old}++; # Already remapped, thank you | |
1500 | if ($new =~ s/^\$//) { # We found an obsolete shell symbol | |
1501 | $old =~ s/^\$//; | |
1502 | print OBSOL_SH "$old=\"\$$new\"\n"; | |
1503 | } else { # We found an obsolete C symbol | |
1504 | print OBSOL_H "#ifdef $new\n"; | |
1505 | print OBSOL_H "#define $old $new\n"; | |
1506 | print OBSOL_H "#endif\n\n"; | |
1507 | } | |
1508 | } | |
1509 | close OBSOLETE; | |
1510 | close OBSOL_H; | |
1511 | close OBSOL_SH; | |
1512 | if (-s 'Obsolete') { | |
1513 | print "*** Obsolete symbols found -- see file 'Obsolete' for a list.\n"; | |
1514 | } else { | |
1515 | unlink 'Obsolete'; | |
1516 | } | |
1517 | undef %ofound; # Not needed any more | |
1518 | } | |
1519 | ||
1520 | # Build the private makefile we use to compute the transitive closure of the | |
1521 | # previously determined dependencies. | |
1522 | sub main'load_build_makefile { | |
1523 | package main; | |
1524 | print "Computing optimal dependency graph...\n" unless $opt_s; | |
1525 | chdir('.MT') || die "Can't chdir to .MT\n"; | |
1526 | local($wanted); # Wanted shell symbols | |
1527 | &build_private; # Build a first makefile from dependencies | |
1528 | &compute_loadable; # Compute loadable units | |
1529 | &update_makefile; # Update makefile using feedback from first pass | |
1530 | chdir($WD) || die "Can't chdir back to $WD\n"; | |
1531 | # Free memory by removing useless data structures | |
1532 | undef $dependencies; | |
1533 | undef $saved_dependencies; | |
1534 | } | |
1535 | ||
1536 | # First pass: build a private makefile from the extracted dependency, changing | |
1537 | # conditional units to truly wanted ones if the symbol is used, removing the | |
1538 | # dependency otherwise. The original dependencies are saved. | |
1539 | sub main'load_build_private { | |
1540 | package main; | |
1541 | print " Building private make file...\n" unless $opt_s; | |
1542 | open(WANTED,"../Wanted") || die "Can't reopen Wanted.\n"; | |
1543 | $wanted = ' ' x 2000; # Pre-extend string | |
1544 | $wanted = ''; | |
1545 | while (<WANTED>) { | |
1546 | chop; | |
1547 | next if /^!/; # Skip obsolete symbols | |
1548 | if (s/^>//) { | |
1549 | $cmaster{$_}++; | |
1550 | } else { | |
1551 | $wanted .= "$_ "; | |
1552 | } | |
1553 | } | |
1554 | close WANTED; | |
1555 | ||
1556 | # The wanted symbols are sorted so that d_* (checking for C library symbol) | |
1557 | # come first and i_* (checking for includes) comes at the end. Grouping the | |
1558 | # d_* symbols together has good chances of improving the locality of the | |
1559 | # other questions and i_* symbols must come last since some depend on h_* | |
1560 | # values which prevent incompatible headers inclusions. | |
1561 | $wanted = join(' ', sort symbols split(' ', $wanted)); | |
1562 | ||
1563 | # Now generate the first makefile, which will be used to determine which | |
1564 | # symbols we really need, so that conditional dependencies may be solved. | |
1565 | open(MAKEFILE,">Makefile") || die "Can't create .MT/Makefile.\n"; | |
1566 | print MAKEFILE "SHELL = /bin/sh\n"; | |
1567 | print MAKEFILE "W = $wanted\n"; | |
1568 | $saved_dependencies = $dependencies; | |
1569 | foreach $sym (@Cond) { | |
1570 | if ($symwanted{$sym}) { | |
1571 | $dependencies =~ s/\+($sym\s)/$1/gm; | |
1572 | } else { | |
1573 | $dependencies =~ s/\+$sym(\s)/$1/gm; | |
1574 | } | |
1575 | } | |
1576 | print MAKEFILE $dependencies; | |
1577 | close MAKEFILE; | |
1578 | } | |
1579 | ||
1580 | # Ordering for symbols. Give higher priority to d_* ones and lower to i_* ones. | |
1581 | # If any layout priority is defined in %Layout, it is used to order the | |
1582 | # symbols. | |
1583 | sub main'load_symbols { | |
1584 | package main; | |
1585 | local($r) = $Layout{$a} <=> $Layout{$b}; | |
1586 | return $r if $r; | |
1587 | # If we come here, both symbols have the same layout priority. | |
1588 | if ($a =~ /^d_/) { | |
1589 | return -1 unless $b =~ /^d_/; | |
1590 | } elsif ($b =~ /^d_/) { | |
1591 | return 1; | |
1592 | } elsif ($a =~ /^i_/) { | |
1593 | return 1 unless $b =~ /^i_/; | |
1594 | } elsif ($b =~ /^i_/) { | |
1595 | return -1; | |
1596 | } | |
1597 | $a cmp $b; | |
1598 | } | |
1599 | ||
1600 | # Run the makefile produced in the first pass to find the whole set of units we | |
1601 | # have to load, filling in the %symwanted and %condwanted structures. | |
1602 | sub main'load_compute_loadable { | |
1603 | package main; | |
1604 | print " Determining loadable units...\n" unless $opt_s; | |
1605 | open(MAKE, "make -n |") || die "Can't run make"; | |
1606 | while (<MAKE>) { | |
1607 | s|^\s+||; # Some make print tabs before command | |
1608 | if (/^pick/) { | |
1609 | print "\t$_" if $opt_v; | |
1610 | ($pick,$cmd,$symbol,$unit) = split(' '); | |
1611 | $symwanted{$symbol}++; | |
1612 | $symwanted{$unit}++; | |
1613 | } elsif (/^cond/) { | |
1614 | print "\t$_" if $opt_v; | |
1615 | ($pick,@symbol) = split(' '); | |
1616 | for (@symbol) { | |
1617 | $condwanted{$_}++; # Default value is requested | |
1618 | } | |
1619 | } | |
1620 | } | |
1621 | close MAKE; | |
1622 | } | |
1623 | ||
1624 | # Back to the original dependencies, make loadable units truly wanted ones and | |
1625 | # remove optional ones. | |
1626 | sub main'load_update_makefile { | |
1627 | package main; | |
1628 | print " Updating make file...\n" unless $opt_s; | |
1629 | open(MAKEFILE,">Makefile") || die "Can't create .MT/Makefile.\n"; | |
1630 | print MAKEFILE "SHELL = /bin/sh\n"; | |
1631 | print MAKEFILE "W = $wanted\n"; | |
1632 | foreach $sym (@Cond) { | |
1633 | if ($symwanted{$sym}) { | |
1634 | $saved_dependencies =~ s/\+($sym\s)/$1/gm; | |
1635 | } else { | |
1636 | $saved_dependencies =~ s/\+$sym(\s)/$1/gm; | |
1637 | } | |
1638 | } | |
1639 | print MAKEFILE $saved_dependencies; | |
1640 | close MAKEFILE; | |
1641 | } | |
1642 | ||
1643 | # Solve dependencies by saving the 'pick' command in @cmdwanted | |
1644 | sub main'load_solve_dependencies { | |
1645 | package main; | |
1646 | local(%unitseen); # Record already picked units (avoid duplicates) | |
1647 | print "Determining the correct order for the units...\n" unless $opt_s; | |
1648 | chdir('.MT') || die "Can't chdir to .MT: $!.\n"; | |
1649 | open(MAKE, "make -n |") || die "Can't run make"; | |
1650 | while (<MAKE>) { | |
1651 | s|^\s+||; # Some make print tabs before command | |
1652 | print "\t$_" if $opt_v; | |
1653 | if (/^pick/) { | |
1654 | ($pick,$cmd,$symbol,$unit) = split(' '); | |
1655 | push(@cmdwanted,"$cmd $symbol $unit") | |
1656 | unless $unitseen{"$cmd:$unit"}++; | |
1657 | } elsif (/^cond/) { | |
1658 | # Ignore conditional symbol request | |
1659 | } else { | |
1660 | chop; | |
1661 | system; | |
1662 | } | |
1663 | } | |
1664 | chdir($WD) || die "Can't chdir to $WD: $!.\n"; | |
1665 | close MAKE; | |
1666 | } | |
1667 | ||
1668 | # Create the Configure script | |
1669 | sub main'load_create_configure { | |
1670 | package main; | |
1671 | print "Creating Configure...\n" unless $opt_s; | |
1672 | open(CONFIGURE,">Configure") || die "Can't create Configure: $!\n"; | |
1673 | open(CONF_H,">config_h.SH") || die "Can't create config_h.SH: $!\n"; | |
1674 | if ($opt_M) { | |
1675 | open(MAGIC_H,">confmagic.h") || die "Can't create confmagic.h: $!\n"; | |
1676 | } | |
1677 | ||
1678 | chdir('.MT') || die "Can't cd to .MT: $!\n"; | |
1679 | for (@cmdwanted) { | |
1680 | &process_command($_); # Run the makefile command | |
1681 | } | |
1682 | chdir($WD) || die "Can't cd back to $WD\n"; | |
1683 | close CONFIGURE; | |
1684 | print CONF_H "#endif\n"; # Close the opened #ifdef (see Config_h.U) | |
1685 | print CONF_H "!GROK!THIS!\n"; | |
1686 | close CONF_H; | |
1687 | if ($opt_M) { | |
1688 | print MAGIC_H "#endif\n"; # Close the opened #ifdef (see Magic_h.U) | |
1689 | close MAGIC_H; | |
1690 | } | |
1691 | `chmod +x Configure`; | |
1692 | } | |
1693 | ||
1694 | # Process a Makefile 'pick' command | |
1695 | sub main'load_process_command { | |
1696 | package main; | |
1697 | local($cmd, $target, $unit_name) = split(' ', $_[0]); | |
1698 | local($name) = $unit_name . '.U'; # Restore missing .U | |
1699 | local($file) = $name; # Where unit is located | |
1700 | unless ($file =~ m|^\./|) { # Unit produced earlier by metaconfig | |
1701 | $file = $Unit{$unit_name}; # Fetch unit from U directory | |
1702 | } | |
1703 | if (defined $Obsolete{$name}) { # Signal use of an obsolete unit | |
1704 | warn "\tObsolete unit $name is used:\n"; | |
1705 | local(@msg) = split(/\n/, $Obsolete{$name}); | |
1706 | foreach $msg (@msg) { | |
1707 | warn "\t $msg\n"; | |
1708 | } | |
1709 | } | |
1710 | die "Can't open $file.\n" unless open(UNIT, $file); | |
1711 | print "\t$cmd $file\n" if $opt_v; | |
1712 | &init_interp; # Initializes the interpreter | |
1713 | ||
1714 | # The 'add' command adds the unit to Configure. | |
1715 | if ($cmd eq 'add') { | |
1716 | while (<UNIT>) { | |
1717 | print CONFIGURE unless &skipped || !&interpret($_); | |
1718 | } | |
1719 | } | |
1720 | ||
1721 | # The 'weed' command adds the unit to Configure, but | |
1722 | # makes some tests for the lines starting with '?' or '%'. | |
1723 | # These lines are kept only if the symbol is wanted. | |
1724 | elsif ($cmd eq 'weed') { | |
1725 | while (<UNIT>) { | |
1726 | if (/^\?(\w+):/) { | |
1727 | s/^\?\w+:// if $symwanted{$1}; | |
1728 | } | |
1729 | if (/^%(\w+):/) { | |
1730 | s/^%\w+:// if $condwanted{$1}; | |
1731 | } | |
1732 | print CONFIGURE unless &skipped || !&interpret($_); | |
1733 | } | |
1734 | } | |
1735 | ||
1736 | # The 'wipe' command adds the unit to Configure, but | |
1737 | # also substitues some hardwired macros. | |
1738 | elsif ($cmd eq 'wipe') { | |
1739 | while (<UNIT>) { | |
1740 | s/<PACKAGENAME>/$package/g; | |
1741 | s/<MAINTLOC>/$maintloc/g; | |
1742 | s/<VERSION>/$version/g; # This is metaconfig's version | |
1743 | s/<PATCHLEVEL>/$patchlevel/g; # And patchlevel information | |
1744 | s/<DATE>/$date/g; | |
1745 | s/<BASEREV>/$baserev/g; | |
1746 | s/<\$(\w+)>/eval("\$$1")/ge; # <$var> -> $var substitution | |
1747 | print CONFIGURE unless &skipped || !&interpret($_); | |
1748 | } | |
1749 | } | |
1750 | ||
1751 | # The 'add.Null' command adds empty initializations | |
1752 | # to Configure for all the shell variable used. | |
1753 | elsif ($cmd eq 'add.Null') { | |
1754 | for (sort @Master) { | |
1755 | if (/^\?(\w+):/) { | |
1756 | s/^\?\w+:// if $symwanted{$1}; | |
1757 | } | |
1758 | print CONFIGURE unless &skipped; | |
1759 | } | |
1760 | for (sort @Cond) { | |
1761 | print CONFIGURE "$_=''\n" | |
1762 | unless $symwanted{$_} || $hasdefault{$_}; | |
1763 | } | |
1764 | while (<UNIT>) { | |
1765 | print CONFIGURE unless &skipped || !&interpret($_); | |
1766 | } | |
1767 | print CONFIGURE "CONFIG=''\n\n"; | |
1768 | } | |
1769 | ||
1770 | # The 'add.Config_sh' command fills in the production of | |
1771 | # the config.sh script within Configure. Only the used | |
1772 | # variable are added, the conditional ones are skipped. | |
1773 | elsif ($cmd eq 'add.Config_sh') { | |
1774 | while (<UNIT>) { | |
1775 | print CONFIGURE unless &skipped || !&interpret($_); | |
1776 | } | |
1777 | for (sort @Master) { | |
1778 | if (/^\?(\w+):/) { | |
1779 | # Can't use $shmaster, because config.sh must | |
1780 | # also contain some internal defaults used by | |
1781 | # Configure (e.g. nm_opt, libc, etc...). | |
1782 | s/^\?\w+:// if $symwanted{$1}; | |
1783 | } | |
1784 | s/^(\w+)=''/$1='\$$1'/; | |
1785 | print CONFIGURE unless &skipped; | |
1786 | } | |
1787 | } | |
1788 | ||
1789 | # The 'close.Config_sh' command adds the final EOT line at | |
1790 | # the end of the here-document construct which produces the | |
1791 | # config.sh file within Configure. | |
1792 | elsif ($cmd eq 'close.Config_sh') { | |
1793 | print CONFIGURE "EOT\n\n"; # Ends up file | |
1794 | } | |
1795 | ||
1796 | # The 'c_h_weed' command produces the config_h.SH file. | |
1797 | # Only the necessary lines are kept. If no conditional line is | |
1798 | # ever printed, then the file is useless and will be removed. | |
1799 | elsif ($cmd eq 'c_h_weed') { | |
1800 | $printed = 0; | |
1801 | while (<UNIT>) { | |
1802 | if (/^\?(\w+):/) { | |
1803 | s/^\?\w+:// if $cmaster{$1} || $symwanted{$1}; | |
1804 | } | |
1805 | unless (&skipped || !&interpret($_)) { | |
1806 | if (/^$/) { | |
1807 | print CONF_H "\n" if $printed; | |
1808 | $printed = 0; | |
1809 | } else { | |
1810 | print CONF_H; | |
1811 | ++$printed; | |
1812 | } | |
1813 | } | |
1814 | } | |
1815 | } | |
1816 | ||
1817 | # The 'cm_h_weed' command produces the confmagic.h file. | |
1818 | # Only the necessary lines are kept. If no conditional line is | |
1819 | # ever printed, then the file is useless and will be removed. | |
1820 | elsif ($cmd eq 'cm_h_weed') { | |
1821 | if ($opt_M) { | |
1822 | $printed = 0; | |
1823 | while (<UNIT>) { | |
1824 | if (/^\?(\w+):/) { | |
1825 | s/^\?\w+:// if $cmaster{$1} || $symwanted{$1}; | |
1826 | } | |
1827 | unless (&skipped || !&interpret($_)) { | |
1828 | if (/^$/) { | |
1829 | print MAGIC_H "\n" if $printed; | |
1830 | $printed = 0; | |
1831 | } else { | |
1832 | print MAGIC_H; | |
1833 | ++$printed; | |
1834 | } | |
1835 | } | |
1836 | } | |
1837 | } | |
1838 | } | |
1839 | ||
1840 | # The 'prepend' command will add the content of the target to | |
1841 | # the current file (held in $file, the one which UNIT refers to), | |
1842 | # if the file is not empty. | |
1843 | elsif ($cmd eq 'prepend') { | |
1844 | if (-s $file) { | |
1845 | open(PREPEND, ">.prepend") || | |
1846 | die "Can't create .MT/.prepend.\n"; | |
1847 | open(TARGET, $Unit{$target}) || | |
1848 | die "Can't open $Unit{$target}.\n"; | |
1849 | while (<TARGET>) { | |
1850 | print PREPEND unless &skipped; | |
1851 | } | |
1852 | print PREPEND <UNIT>; # Now add original file contents | |
1853 | close PREPEND; | |
1854 | close TARGET; | |
1855 | rename('.prepend', $file) || | |
1856 | die "Can't rename .prepend into $file.\n"; | |
1857 | } | |
1858 | } | |
1859 | ||
1860 | # Command not found | |
1861 | else { | |
1862 | die "Unrecognized command from Makefile: $cmd\n"; | |
1863 | } | |
1864 | &check_state; # Make sure there are no pending statements | |
1865 | close UNIT; | |
1866 | } | |
1867 | ||
1868 | # Skip lines starting with ? or %, including all the following continuation | |
1869 | # lines, if any. Return 0 if the line was not to be skipped, 1 otherwise. | |
1870 | sub main'load_skipped { | |
1871 | package main; | |
1872 | return 0 unless /^\?|^%/; | |
1873 | &complete_line(UNIT) if /\\\s*$/; # Swallow continuation lines | |
1874 | 1; | |
1875 | } | |
1876 | ||
1877 | # Update the MANIFEST.new file if necessary | |
1878 | sub main'load_cosmetic_update { | |
1879 | package main; | |
1880 | # Check for an "empty" config_h.SH (2 blank lines only). This test relies | |
1881 | # on the actual text held in Config_h.U. If the unit is modified, then the | |
1882 | # following might need adjustments. | |
1883 | local($blank_lines) = 0; | |
1884 | local($spaces) = 0; | |
1885 | open(CONF_H, 'config_h.SH') || die "Can't open config_h.SH\n"; | |
1886 | while(<CONF_H>) { | |
1887 | ++$blank_lines if /^$/; | |
1888 | } | |
1889 | unlink 'config_h.SH' unless $blank_lines > 3; | |
1890 | ||
1891 | open(NEWMANI,$NEWMANI); | |
1892 | $_ = <NEWMANI>; | |
1893 | /(\S+\s+)\S+/ && ($spaces = length($1)); # Spaces wanted | |
1894 | close NEWMANI; | |
1895 | $spaces = 29 if ($spaces < 12); # Default value | |
1896 | open(NEWMANI,$NEWMANI); | |
1897 | $/ = "\001"; # Swallow the whole file | |
1898 | $_ = <NEWMANI>; | |
1899 | $/ = "\n"; | |
1900 | close NEWMANI; | |
1901 | ||
1902 | &mani_add('Configure', 'Portability tool', $spaces) unless /^Configure\b/m; | |
1903 | &mani_add('config_h.SH', 'Produces config.h', $spaces) | |
1904 | unless /^config_h\.SH\b/m || !-f 'config_h.SH'; | |
1905 | &mani_add('confmagic.h', 'Magic symbol remapping', $spaces) | |
1906 | if $opt_M && !/^confmagic\.h\b/m; | |
1907 | ||
1908 | &mani_remove('config_h.SH') if /^config_h\.SH\b/m && !-f 'config_h.SH'; | |
1909 | &mani_remove('confmagic.h') if /^confmagic.h\b/m && !$opt_M; | |
1910 | ||
1911 | if ($opt_G) { # Want a GNU-like configure wrapper | |
1912 | &add_configure; | |
1913 | &mani_add('configure', 'GNU configure-like wrapper', $spaces) | |
1914 | if !/^configure\s/m && -f 'configure'; | |
1915 | } else { | |
1916 | &mani_remove('configure') if /^configure\s/m && !-f 'configure'; | |
1917 | } | |
1918 | } | |
1919 | ||
1920 | # Add file to MANIFEST.new, with properly indented comment | |
1921 | sub main'load_mani_add { | |
1922 | package main; | |
1923 | local($file, $comment, $spaces) = @_; | |
1924 | print "Adding $file to your $NEWMANI file...\n" unless $opt_s; | |
1925 | open(NEWMANI, ">>$NEWMANI") || warn "Can't add $file to $NEWMANI: $!\n"; | |
1926 | local($blank) = ' ' x ($spaces - length($file)); | |
1927 | print NEWMANI "${file}${blank}${comment}\n"; | |
1928 | close NEWMANI; | |
1929 | } | |
1930 | ||
1931 | # Remove file from MANIFEST.new | |
1932 | sub main'load_mani_remove { | |
1933 | package main; | |
1934 | local($file) = @_; | |
1935 | print "Removing $file from $NEWMANI...\n" unless $opt_s; | |
1936 | unless (open(NEWMANI, ">$NEWMANI.x")) { | |
1937 | warn "Can't create backup $NEWMANI copy: $!\n"; | |
1938 | return; | |
1939 | } | |
1940 | unless (open(OLDMANI, $NEWMANI)) { | |
1941 | warn "Can't open $NEWMANI: $!\n"; | |
1942 | return; | |
1943 | } | |
1944 | local($_); | |
1945 | while (<OLDMANI>) { | |
1946 | print NEWMANI unless /^$file\b/ | |
1947 | } | |
1948 | close OLDMANI; | |
1949 | close NEWMANI; | |
1950 | rename("$NEWMANI.x", $NEWMANI) || | |
1951 | warn "Couldn't restore $NEWMANI from $NEWMANI.x\n"; | |
1952 | } | |
1953 | ||
1954 | # Copy GNU-like configure wrapper to the package root directory | |
1955 | sub main'load_add_configure { | |
1956 | package main; | |
1957 | if (-f "$MC/configure") { | |
1958 | print "Copying GNU configure-like front end...\n" unless $opt_s; | |
1959 | system "cp $MC/configure ./configure"; | |
1960 | `chmod +x configure`; | |
1961 | } else { | |
1962 | warn "Can't locate $MC/configure: $!\n"; | |
1963 | } | |
1964 | } | |
1965 | ||
1966 | # States used by our interpeter -- in sync with @Keep | |
1967 | sub main'load_init_keep { | |
1968 | package interpreter; | |
1969 | # Status in which we keep lines -- $Keep[$status] | |
1970 | @Keep = (0, 1, 1, 0, 1); | |
1971 | ||
1972 | # Available status ($status) | |
1973 | $SKIP = 0; | |
1974 | $IF = 1; | |
1975 | $ELSE = 2; | |
1976 | $NOT = 3; | |
1977 | $OUT = 4; | |
1978 | } | |
1979 | ||
1980 | # Priorities for operators -- magic numbers :-) | |
1981 | sub main'load_init_priority { | |
1982 | package interpreter; | |
1983 | $Priority{'&&'} = 4; | |
1984 | $Priority{'||'} = 3; | |
1985 | } | |
1986 | ||
1987 | # Initializes the state stack of the interpreter | |
1988 | sub main'load_init_interp { | |
1989 | package interpreter; | |
1990 | @state = (); | |
1991 | push(@state, $OUT); | |
1992 | } | |
1993 | ||
1994 | # Print error messages -- asssumes $unit and $. correctly set. | |
1995 | sub interpreter'load_error { | |
1996 | package interpreter; | |
1997 | warn "\"$main'file\", line $.: @_.\n"; | |
1998 | } | |
1999 | ||
2000 | # If some states are still in the stack, warn the user | |
2001 | sub main'load_check_state { | |
2002 | package interpreter; | |
2003 | &error("one statement pending") if $#state == 1; | |
2004 | &error("$#state statements pending") if $#state > 1; | |
2005 | } | |
2006 | ||
2007 | # Add a value on the stack, modified by all the monadic operators. | |
2008 | # We use the locals @val and @mono from eval_expr. | |
2009 | sub interpreter'load_push_val { | |
2010 | package interpreter; | |
2011 | local($val) = shift(@_); | |
2012 | while ($#mono >= 0) { | |
2013 | # Cheat... the only monadic operator is '!'. | |
2014 | pop(@mono); | |
2015 | $val = !$val; | |
2016 | } | |
2017 | push(@val, $val); | |
2018 | } | |
2019 | ||
2020 | # Execute a stacked operation, leave result in stack. | |
2021 | # We use the locals @val and @op from eval_expr. | |
2022 | # If the value stack holds only one operand, do nothing. | |
2023 | sub interpreter'load_execute { | |
2024 | package interpreter; | |
2025 | return unless $#val > 0; | |
2026 | local($op) = pop(@op); | |
2027 | local($val1) = pop(@val); | |
2028 | local($val2) = pop(@val); | |
2029 | push(@val, eval("$val1 $op $val2") ? 1: 0); | |
2030 | } | |
2031 | ||
2032 | # Given an operator, either we add it in the stack @op, because its | |
2033 | # priority is lower than the one on top of the stack, or we first execute | |
2034 | # the stacked operations until we reach the end of stack or an operand | |
2035 | # whose priority is lower than ours. | |
2036 | # We use the locals @val and @op from eval_expr. | |
2037 | sub interpreter'load_update_stack { | |
2038 | package interpreter; | |
2039 | local($op) = shift(@_); # Operator | |
2040 | if (!$Priority{$op}) { | |
2041 | &error("illegal operator $op"); | |
2042 | return; | |
2043 | } else { | |
2044 | if ($#val < 0) { | |
2045 | &error("missing first operand for '$op' (diadic operator)"); | |
2046 | return; | |
2047 | } | |
2048 | # Because of the special behaviour of do-SUBR with the while modifier, | |
2049 | # I'm using a while-BLOCK construct. I consider this to be a bug of perl | |
2050 | # 4.0 PL19, although it is clearly documented in the man page. | |
2051 | while ( | |
2052 | $Priority{$op[$#op]} > $Priority{$op} # Higher priority op | |
2053 | && $#val > 0 # At least 2 values | |
2054 | ) { | |
2055 | &execute; # Execute an higher priority stacked operation | |
2056 | } | |
2057 | push(@op, $op); # Everything at higher priority has been executed | |
2058 | } | |
2059 | } | |
2060 | ||
2061 | # This is the heart of our little interpreter. Here, we evaluate | |
2062 | # a logical expression and return its value. | |
2063 | sub interpreter'load_eval_expr { | |
2064 | package interpreter; | |
2065 | local(*expr) = shift(@_); # Expression to parse | |
2066 | local(@val) = (); # Stack of values | |
2067 | local(@op) = (); # Stack of diadic operators | |
2068 | local(@mono) =(); # Stack of monadic operators | |
2069 | local($tmp); | |
2070 | $_ = $expr; | |
2071 | while (1) { | |
2072 | s/^\s+//; # Remove spaces between words | |
2073 | # The '(' construct | |
2074 | if (s/^\(//) { | |
2075 | &push_val(&eval_expr(*_)); | |
2076 | # A final '\' indicates an end of line | |
2077 | &error("missing final parenthesis") if !s/^\\//; | |
2078 | } | |
2079 | # Found a ')' or end of line | |
2080 | elsif (/^\)/ || /^$/) { | |
2081 | s/^\)/\\/; # Signals: left parenthesis found | |
2082 | $expr = $_; # Remove interpreted stuff | |
2083 | &execute() while $#val > 0; # Executed stacked operations | |
2084 | while ($#op >= 0) { | |
2085 | $_ = pop(@op); | |
2086 | &error("missing second operand for '$_' (diadic operator)"); | |
2087 | } | |
2088 | return $val[0]; | |
2089 | } | |
2090 | # A perl statement '{{' | |
2091 | elsif (s/^\{\{//) { | |
2092 | if (s/^(.*)\}\}//) { | |
2093 | &push_val((system | |
2094 | ('perl','-e', "if ($1) {exit 0;} else {exit 1;}" | |
2095 | ))? 0 : 1); | |
2096 | } else { | |
2097 | &error("incomplete perl statement"); | |
2098 | } | |
2099 | } | |
2100 | # A shell statement '{' | |
2101 | elsif (s/^\{//) { | |
2102 | if (s/^(.*)\}//) { | |
2103 | &push_val((system | |
2104 | ("if $1 >/dev/null 2>&1; then exit 0; else exit 1; fi" | |
2105 | ))? 0 : 1); | |
2106 | } else { | |
2107 | &error("incomplete shell statement"); | |
2108 | } | |
2109 | } | |
2110 | # Operator '||' and '&&' | |
2111 | elsif (s/^(\|\||&&)//) { | |
2112 | $tmp = $1; # Save for perl5 (Dataloaded update_stack) | |
2113 | &update_stack($tmp); | |
2114 | } | |
2115 | # Unary operator '!' | |
2116 | elsif (s/^!//) { | |
2117 | push(@mono,'!'); | |
2118 | } | |
2119 | # Everything else is a test for a defined value | |
2120 | elsif (s/^([\?%]?\w+)//) { | |
2121 | $tmp = $1; | |
2122 | # Test for wanted | |
2123 | if ($tmp =~ s/^\?//) { | |
2124 | &push_val(($main'symwanted{$tmp})? 1 : 0); | |
2125 | } | |
2126 | # Test for conditionally wanted | |
2127 | elsif ($tmp =~ s/^%//) { | |
2128 | &push_val(($main'condwanted{$tmp})? 1 : 0); | |
2129 | } | |
2130 | # Default: test for definition (see op @define) | |
2131 | else { | |
2132 | &push_val(( | |
2133 | $main'symwanted{$tmp} || | |
2134 | $main'cmaster{$tmp} || | |
2135 | $main'userdef{$tmp}) ? 1 : 0); | |
2136 | } | |
2137 | } | |
2138 | # An error occured -- we did not recognize the expression | |
2139 | else { | |
2140 | s/^([^\s\(\)\{\|&!]+)//; # Skip until next meaningful char | |
2141 | } | |
2142 | } | |
2143 | } | |
2144 | ||
2145 | # Given an expression in a '@' command, returns a boolean which is | |
2146 | # the result of the evaluation. Evaluate is collecting all the lines | |
2147 | # in the expression into a single string, and then calls eval_expr to | |
2148 | # really evaluate it. | |
2149 | sub interpreter'load_evaluate { | |
2150 | package interpreter; | |
2151 | local($val); # Value returned | |
2152 | local($expr) = ""; # Expression to be parsed | |
2153 | chop; | |
2154 | while (s/\\$//) { # While end of line escaped | |
2155 | $expr .= $_; | |
2156 | $_ = <UNIT>; # Fetch next line | |
2157 | unless ($_) { | |
2158 | &error("EOF in expression"); | |
2159 | last; | |
2160 | } | |
2161 | chop; | |
2162 | } | |
2163 | $expr .= $_; | |
2164 | while ($expr ne '') { | |
2165 | $val = &eval_expr(*expr); # Expression will be modified | |
2166 | # We return from eval_expr either when a closing parenthisis | |
2167 | # is found, or when the expression has been fully analysed. | |
2168 | &error("extra closing parenthesis ignored") if $expr ne ''; | |
2169 | } | |
2170 | $val; | |
2171 | } | |
2172 | ||
2173 | # Given a line, we search for commands (lines starting with '@'). | |
2174 | # If there is no command in the line, then we return the boolean state. | |
2175 | # Otherwise, the command is analysed and a new state is computed. | |
2176 | # The returned value of interpret is 1 if the line is to be printed. | |
2177 | sub main'load_interpret { | |
2178 | package interpreter; | |
2179 | local($value); | |
2180 | local($status) = $state[$#state]; # Current status | |
2181 | if (s|^\s*@\s*(\w+)\s*(.*)|$2|) { | |
2182 | local($cmd) = $1; | |
2183 | $cmd =~ y/A-Z/a-z/; # Canonicalize to lower case | |
2184 | # The 'define' command | |
2185 | if ($cmd eq 'define') { | |
2186 | chop; | |
2187 | $userdef{$_}++ if $Keep[$status]; | |
2188 | return 0; | |
2189 | } | |
2190 | # The 'if' command | |
2191 | elsif ($cmd eq 'if') { | |
2192 | # We always evaluate, in order to find possible errors | |
2193 | $value = &evaluate($_); | |
2194 | if (!$Keep[$status]) { | |
2195 | # We have to skip until next 'end' | |
2196 | push(@state, $SKIP); # Record structure | |
2197 | return 0; | |
2198 | } | |
2199 | if ($value) { # True | |
2200 | push(@state, $IF); | |
2201 | return 0; | |
2202 | } else { # False | |
2203 | push(@state, $NOT); | |
2204 | return 0; | |
2205 | } | |
2206 | } | |
2207 | # The 'else' command | |
2208 | elsif ($cmd eq 'else') { | |
2209 | &error("expression after 'else' ignored") if /\S/; | |
2210 | $state[$#state] = $SKIP if $state[$#state] == $IF; | |
2211 | return 0 if $state[$#state] == $SKIP; | |
2212 | if ($state[$#state] == $OUT) { | |
2213 | &error("unexpected 'else'"); | |
2214 | return 0; | |
2215 | } | |
2216 | $state[$#state] = $ELSE; | |
2217 | return 0; | |
2218 | } | |
2219 | # The 'elsif' command | |
2220 | elsif ($cmd eq 'elsif') { | |
2221 | # We always evaluate, in order to find possible errors | |
2222 | $value = &evaluate($_); | |
2223 | $state[$#state] = $SKIP if $state[$#state] == $IF; | |
2224 | return 0 if $state[$#state] == $SKIP; | |
2225 | if ($state[$#state] == $OUT) { | |
2226 | &error("unexpected 'elsif'"); | |
2227 | return 0; | |
2228 | } | |
2229 | if ($value) { # True | |
2230 | $state[$#state] = $IF; | |
2231 | return 0; | |
2232 | } else { # False | |
2233 | $state[$#state] = $NOT; | |
2234 | return 0; | |
2235 | } | |
2236 | } | |
2237 | # The 'end' command | |
2238 | elsif ($cmd eq 'end') { | |
2239 | &error("expression after 'end' ignored") if /\S/; | |
2240 | pop(@state); | |
2241 | &error("unexpected 'end'") if $#state < 0; | |
2242 | return 0; | |
2243 | } | |
2244 | # Unknown command | |
2245 | else { | |
2246 | &error("unknown command '$cmd'"); | |
2247 | return 0; | |
2248 | } | |
2249 | } | |
2250 | $Keep[$status]; | |
2251 | } | |
2252 | ||
2253 | sub main'load_readpackage { | |
2254 | package main; | |
2255 | if (! -f '.package') { | |
2256 | if ( | |
2257 | -f '../.package' || | |
2258 | -f '../../.package' || | |
2259 | -f '../../../.package' || | |
2260 | -f '../../../../.package' | |
2261 | ) { | |
2262 | die "Run in top level directory only.\n"; | |
2263 | } else { | |
2264 | die "No .package file! Run packinit.\n"; | |
2265 | } | |
2266 | } | |
2267 | open(PACKAGE,'.package'); | |
2268 | while (<PACKAGE>) { | |
2269 | next if /^:/; | |
2270 | next if /^#/; | |
2271 | if (($var,$val) = /^\s*(\w+)=(.*)/) { | |
2272 | $val = "\"$val\"" unless $val =~ /^['"]/; | |
2273 | eval "\$$var = $val;"; | |
2274 | } | |
2275 | } | |
2276 | close PACKAGE; | |
2277 | } | |
2278 | ||
2279 | sub main'load_manifake { | |
2280 | package main; | |
2281 | # make MANIFEST and MANIFEST.new say the same thing | |
2282 | if (! -f $NEWMANI) { | |
2283 | if (-f $MANI) { | |
2284 | open(IN,$MANI) || die "Can't open $MANI"; | |
2285 | open(OUT,">$NEWMANI") || die "Can't create $NEWMANI"; | |
2286 | while (<IN>) { | |
2287 | if (/---/) { | |
2288 | # Everything until now was a header... | |
2289 | close OUT; | |
2290 | open(OUT,">$NEWMANI") || | |
2291 | die "Can't recreate $NEWMANI"; | |
2292 | next; | |
2293 | } | |
2294 | s/^\s*(\S+\s+)[0-9]*\s*(.*)/$1$2/; | |
2295 | print OUT; | |
2296 | print OUT "\n" unless /\n$/; # If no description | |
2297 | } | |
2298 | close IN; | |
2299 | close OUT; | |
2300 | } | |
2301 | else { | |
2302 | die "You need to make a $NEWMANI file, with names and descriptions.\n"; | |
2303 | } | |
2304 | } | |
2305 | } | |
2306 | ||
2307 | # Perform ~name expansion ala ksh... | |
2308 | # (banish csh from your vocabulary ;-) | |
2309 | sub main'load_tilda_expand { | |
2310 | package main; | |
2311 | local($path) = @_; | |
2312 | return $path unless $path =~ /^~/; | |
2313 | $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e; # ~name | |
2314 | $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e; # ~ | |
2315 | $path; | |
2316 | } | |
2317 | ||
2318 | # Set up profile components into %Profile, add any profile-supplied options | |
2319 | # into @ARGV and return the command invocation name. | |
2320 | sub main'load_profile { | |
2321 | package main; | |
2322 | local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile'); | |
2323 | local($me) = $0; # Command name | |
2324 | $me =~ s|.*/(.*)|$1|; # Keep only base name | |
2325 | return $me unless -s $profile; | |
2326 | local(*PROFILE); # Local file descriptor | |
2327 | local($options) = ''; # Options we get back from profile | |
2328 | unless (open(PROFILE, $profile)) { | |
2329 | warn "$me: cannot open $profile: $!\n"; | |
2330 | return; | |
2331 | } | |
2332 | local($_); | |
2333 | local($component); | |
2334 | while (<PROFILE>) { | |
2335 | next if /^\s*#/; # Skip comments | |
2336 | next unless /^$me/o; | |
2337 | if (s/^$me://o) { # progname: options | |
2338 | chop; | |
2339 | $options .= $_; # Merge options if more than one line | |
2340 | } | |
2341 | elsif (s/^$me-([^:]+)://o) { # progname-component: value | |
2342 | $component = $1; | |
2343 | chop; | |
2344 | s/^\s+//; # Trim leading and trailing spaces | |
2345 | s/\s+$//; | |
2346 | $Profile{$component} = $_; | |
2347 | } | |
2348 | } | |
2349 | close PROFILE; | |
2350 | return unless $options; | |
2351 | require 'shellwords.pl'; | |
2352 | local(@opts); | |
2353 | eval '@opts = &shellwords($options)'; # Protect against mismatched quotes | |
2354 | unshift(@ARGV, @opts); | |
2355 | return $me; # Return our invocation name | |
2356 | } | |
2357 | ||
2358 | # | |
2359 | # End of dataloading section. | |
2360 | # | |
2361 |