Commit | Line | Data |
---|---|---|
6092c506 | 1 | #!/usr/bin/perl |
459d3fb5 | 2 | |
a8ae8817 DH |
3 | use FindBin; |
4 | ||
5 | $p5_metaconfig_base = "$FindBin::Bin/../"; | |
6 | chdir "$p5_metaconfig_base/perl" || | |
7 | die "perl/ directory missing in $p5_metaconfig_base\n"; | |
459d3fb5 MBT |
8 | |
9 | # | |
10 | # This perl program uses dynamic loading [generated by perload] | |
11 | # | |
12 | ||
13 | $ENV{LC_ALL} = 'C'; | |
14 | ||
15 | # $Id$ | |
16 | # | |
17 | # Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi | |
18 | # | |
19 | # You may redistribute only under the terms of the Artistic Licence, | |
20 | # as specified in the README file that comes with the distribution. | |
21 | # You may reuse parts of this distribution only within the terms of | |
22 | # that same Artistic Licence; a copy of which may be found at the root | |
23 | # of the source tree for dist 4.0. | |
24 | # | |
25 | # Original Author: Harlan Stenn <harlan@mumps.pfcs.com> | |
26 | # | |
27 | # $Log: mlint.SH,v $ | |
28 | # Revision 3.0.1.3 1994/05/06 15:20:42 ram | |
29 | # patch23: added -L switch to override public unit repository path | |
30 | # | |
31 | # Revision 3.0.1.2 1994/01/24 14:21:00 ram | |
32 | # patch16: added ~/.dist_profile awareness | |
33 | # | |
34 | # Revision 3.0.1.1 1993/08/19 06:42:27 ram | |
35 | # patch1: leading config.sh searching was not aborting properly | |
36 | # | |
37 | # Revision 3.0 1993/08/18 12:10:17 ram | |
38 | # Baseline for dist 3.0 netwide release. | |
39 | # | |
40 | ||
41 | # Perload ON | |
42 | ||
a8ae8817 | 43 | $MC = "$p5_metaconfig_base/dist"; |
459d3fb5 MBT |
44 | $version = '3.5'; |
45 | $patchlevel = '0'; | |
46 | $revision = ''; | |
47 | $grep = '/usr/bin/grep'; | |
48 | &profile; # Read ~/.dist_profile | |
49 | ||
50 | use Getopt::Std; | |
51 | &usage unless getopts("hklVL:"); | |
52 | ||
53 | if ($opt_V) { | |
54 | print STDERR "metalint $version-$revision\n"; | |
55 | exit 0; | |
56 | } elsif ($opt_h) { | |
57 | &usage; | |
58 | } | |
59 | ||
60 | chop($date = `date`); | |
61 | $MC = $opt_L if $opt_L; # May override library path | |
62 | $MC = &tilda_expand($MC); # ~name expansion | |
63 | chop($WD = `pwd`); # Working directory | |
64 | chdir $MC || die "Can't chdir to $MC: $!\n"; | |
65 | chop($MC = `pwd`); # Real metalint lib path (no symbolic links) | |
66 | chdir $WD || die "Can't chdir back to $WD: $!\n"; | |
67 | ||
68 | &init; # Various initializations | |
69 | `mkdir .MT 2>&1` unless -d '.MT'; # For private temporary files | |
70 | ||
71 | &locate_units; # Fill in @ARGV with a unit list | |
72 | &extract_dependencies; # Extract dependencies from units | |
73 | &sanity_checks; # Perform sanity checks | |
74 | ||
75 | if ($opt_k) { | |
76 | print "Leaving subdirectory .MT unremoved so you can peruse it.\n" | |
77 | unless $opt_s; | |
78 | } else { | |
79 | `rm -rf .MT 2>&1`; | |
80 | } | |
81 | print "Done.\n" unless $opt_s; | |
82 | ||
83 | sub main'init { &auto_main'init; } | |
84 | sub auto_main'init { &main'dataload; } | |
85 | ||
86 | sub main'init_except { &auto_main'init_except; } | |
87 | sub auto_main'init_except { &main'dataload; } | |
88 | ||
89 | sub main'usage { &auto_main'usage; } | |
90 | sub auto_main'usage { &main'dataload; } | |
91 | ||
92 | package locate; | |
93 | ||
94 | sub main'locate_units { &auto_main'locate_units; } | |
95 | sub auto_main'locate_units { &main'dataload; } | |
96 | ||
97 | sub locate'dump_list { &auto_locate'dump_list; } | |
98 | sub auto_locate'dump_list { &main'dataload; } | |
99 | ||
100 | sub locate'private_units { &auto_locate'private_units; } | |
101 | sub auto_locate'private_units { &main'dataload; } | |
102 | ||
103 | sub locate'public_units { &auto_locate'public_units; } | |
104 | sub auto_locate'public_units { &main'dataload; } | |
105 | ||
106 | sub locate'units_path { &auto_locate'units_path; } | |
107 | sub auto_locate'units_path { &main'dataload; } | |
108 | ||
109 | package main; | |
110 | ||
111 | sub main'init_extraction { &auto_main'init_extraction; } | |
112 | sub auto_main'init_extraction { &main'dataload; } | |
113 | ||
114 | sub main'end_extraction { &auto_main'end_extraction; } | |
115 | sub auto_main'end_extraction { &main'dataload; } | |
116 | ||
117 | sub main'p_make { &auto_main'p_make; } | |
118 | sub auto_main'p_make { &main'dataload; } | |
119 | ||
120 | sub main'p_obsolete { &auto_main'p_obsolete; } | |
121 | sub auto_main'p_obsolete { &main'dataload; } | |
122 | ||
123 | sub main'p_shell { &auto_main'p_shell; } | |
124 | sub auto_main'p_shell { &main'dataload; } | |
125 | ||
126 | sub main'p_c { &auto_main'p_c; } | |
127 | sub auto_main'p_c { &main'dataload; } | |
128 | ||
129 | sub main'p_config { &auto_main'p_config; } | |
130 | sub auto_main'p_config { &main'dataload; } | |
131 | ||
132 | sub main'p_magic { &auto_main'p_magic; } | |
133 | sub auto_main'p_magic { &main'dataload; } | |
134 | ||
135 | sub main'p_init { &auto_main'p_init; } | |
136 | sub auto_main'p_init { &main'dataload; } | |
137 | ||
138 | sub main'p_default { &auto_main'p_default; } | |
139 | sub auto_main'p_default { &main'dataload; } | |
140 | ||
141 | sub main'p_visible { &auto_main'p_visible; } | |
142 | sub auto_main'p_visible { &main'dataload; } | |
143 | ||
144 | sub main'p_wanted { &auto_main'p_wanted; } | |
145 | sub auto_main'p_wanted { &main'dataload; } | |
146 | ||
147 | sub main'p_layout { &auto_main'p_layout; } | |
148 | sub auto_main'p_layout { &main'dataload; } | |
149 | ||
150 | sub main'p_public { &auto_main'p_public; } | |
151 | sub auto_main'p_public { &main'dataload; } | |
152 | ||
153 | sub main'p_library { &auto_main'p_library; } | |
154 | sub auto_main'p_library { &main'dataload; } | |
155 | ||
156 | sub main'p_include { &auto_main'p_include; } | |
157 | sub auto_main'p_include { &main'dataload; } | |
158 | ||
159 | sub main'p_temp { &auto_main'p_temp; } | |
160 | sub auto_main'p_temp { &main'dataload; } | |
161 | ||
162 | sub main'p_file { &auto_main'p_file; } | |
163 | sub auto_main'p_file { &main'dataload; } | |
164 | ||
165 | sub main'p_lint { &auto_main'p_lint; } | |
166 | sub auto_main'p_lint { &main'dataload; } | |
167 | ||
168 | sub main'p_body { &auto_main'p_body; } | |
169 | sub auto_main'p_body { &main'dataload; } | |
170 | ||
171 | sub main'p_end { &auto_main'p_end; } | |
172 | sub auto_main'p_end { &main'dataload; } | |
173 | ||
174 | sub main'p_unknown { &auto_main'p_unknown; } | |
175 | sub auto_main'p_unknown { &main'dataload; } | |
176 | ||
177 | sub main'sanity_checks { &auto_main'sanity_checks; } | |
178 | sub auto_main'sanity_checks { &main'dataload; } | |
179 | ||
180 | sub main'check_last_declaration { &auto_main'check_last_declaration; } | |
181 | sub auto_main'check_last_declaration { &main'dataload; } | |
182 | ||
183 | sub main'check_definition { &auto_main'check_definition; } | |
184 | sub auto_main'check_definition { &main'dataload; } | |
185 | ||
186 | sub main'declared { &auto_main'declared; } | |
187 | sub auto_main'declared { &main'dataload; } | |
188 | ||
189 | sub main'defined { &auto_main'defined; } | |
190 | sub auto_main'defined { &main'dataload; } | |
191 | ||
192 | sub main'wanted { &auto_main'wanted; } | |
193 | sub auto_main'wanted { &main'dataload; } | |
194 | ||
195 | sub main'visible { &auto_main'visible; } | |
196 | sub auto_main'visible { &main'dataload; } | |
197 | ||
198 | sub main'explore { &auto_main'explore; } | |
199 | sub auto_main'explore { &main'dataload; } | |
200 | ||
201 | sub main'init_depend { &auto_main'init_depend; } | |
202 | sub auto_main'init_depend { &main'dataload; } | |
203 | ||
204 | sub main'extract_dependencies { &auto_main'extract_dependencies; } | |
205 | sub auto_main'extract_dependencies { &main'dataload; } | |
206 | ||
207 | sub main'complete_line { &auto_main'complete_line; } | |
208 | sub auto_main'complete_line { &main'dataload; } | |
209 | ||
210 | sub main'record_obsolete { &auto_main'record_obsolete; } | |
211 | sub auto_main'record_obsolete { &main'dataload; } | |
212 | ||
213 | sub main'dump_obsolete { &auto_main'dump_obsolete; } | |
214 | sub auto_main'dump_obsolete { &main'dataload; } | |
215 | ||
216 | # | |
217 | # Topological sort of Makefile dependencies with cycle enhancing. | |
218 | # | |
219 | ||
220 | package tsort; | |
221 | ||
222 | sub main'tsort { &auto_main'tsort; } | |
223 | sub auto_main'tsort { &main'dataload; } | |
224 | ||
225 | sub tsort'resync { &auto_tsort'resync; } | |
226 | sub auto_tsort'resync { &main'dataload; } | |
227 | ||
228 | sub tsort'sort { &auto_tsort'sort; } | |
229 | sub auto_tsort'sort { &main'dataload; } | |
230 | ||
231 | sub tsort'extract_cycle { &auto_tsort'extract_cycle; } | |
232 | sub auto_tsort'extract_cycle { &main'dataload; } | |
233 | ||
234 | sub tsort'outline_cycle { &auto_tsort'outline_cycle; } | |
235 | sub auto_tsort'outline_cycle { &main'dataload; } | |
236 | ||
237 | sub tsort'visit { &auto_tsort'visit; } | |
238 | sub auto_tsort'visit { &main'dataload; } | |
239 | ||
240 | sub tsort'sort_by_value { &auto_tsort'sort_by_value; } | |
241 | sub auto_tsort'sort_by_value { &main'dataload; } | |
242 | ||
243 | package main; | |
244 | ||
245 | 1; | |
246 | sub main'tilda_expand { &auto_main'tilda_expand; } | |
247 | sub auto_main'tilda_expand { &main'dataload; } | |
248 | ||
249 | sub main'profile { &auto_main'profile; } | |
250 | sub auto_main'profile { &main'dataload; } | |
251 | ||
252 | # Load the calling function from DATA segment and call it. This function is | |
253 | # called only once per routine to be loaded. | |
254 | sub main'dataload { | |
255 | local($__packname__) = (caller(1))[3]; | |
256 | $__packname__ =~ s/::/'/; | |
257 | local($__rpackname__) = $__packname__; | |
258 | local($__at__) = $@; | |
259 | $__rpackname__ =~ s/^auto_//; | |
260 | &perload'load_from_data($__rpackname__); | |
261 | local($__fun__) = "$__rpackname__"; | |
262 | $__fun__ =~ s/'/'load_/; | |
263 | eval "*$__packname__ = *$__fun__;"; # Change symbol table entry | |
264 | die $@ if $@; # Should not happen | |
265 | $@ = $__at__; # Restore value $@ had on entrance | |
266 | &$__fun__; # Call newly loaded function | |
267 | } | |
268 | ||
269 | # Load function name given as argument, fatal error if not existent | |
270 | sub perload'load_from_data { | |
271 | package perload; | |
272 | local($pos) = $Datapos{$_[0]}; # Offset within DATA | |
273 | # Avoid side effects by protecting special variables which will be changed | |
274 | # by the dataloading operation. | |
275 | local($., $_, $@); | |
276 | $pos = &fetch_function_code unless $pos; | |
277 | die "Function $_[0] not found in data section.\n" unless $pos; | |
278 | die "Cannot seek to $pos into data section.\n" | |
279 | unless seek(main'DATA, $pos, 0); | |
280 | local($/) = "\n}"; | |
281 | local($body) = scalar(<main'DATA>); | |
282 | die "End of file found while loading $_[0].\n" unless $body =~ /^\}$/m; | |
283 | eval $body; # Load function into perl space | |
284 | chop($@) && die "$@, while parsing code of $_[0].\n"; | |
285 | } | |
286 | ||
287 | # This function is called only once, and fills in the %Datapos array with | |
288 | # the offset of each of the dataloaded routines held in the data section. | |
289 | sub perload'fetch_function_code { | |
290 | package perload; | |
291 | local($start) = 0; | |
292 | local($., $_); | |
293 | while (<main'DATA>) { # First move to start of offset table | |
294 | next if /^#/; | |
295 | last if /^$/ && ++$start > 2; # Skip two blank line after end token | |
296 | } | |
297 | $start = tell(main'DATA); # Offsets in table are relative to here | |
298 | local($key, $value); | |
299 | while (<main'DATA>) { # Load the offset table | |
300 | last if /^$/; # Ends with a single blank line | |
301 | ($key, $value) = split(' '); | |
302 | $Datapos{$key} = $value + $start; | |
303 | } | |
304 | $Datapos{$_[0]}; # All that pain to get this offset... | |
305 | } | |
306 | ||
307 | # | |
308 | # The perl compiler stops here. | |
309 | # | |
310 | ||
311 | __END__ | |
312 | ||
313 | # | |
314 | # Beyond this point lie functions we may never compile. | |
315 | # | |
316 | ||
317 | # | |
318 | # DO NOT CHANGE A IOTA BEYOND THIS COMMENT! | |
319 | # The following table lists offsets of functions within the data section. | |
320 | # Should modifications be needed, change original code and rerun perload | |
321 | # with the -o option to regenerate a proper offset table. | |
322 | # | |
323 | ||
324 | locate'dump_list 3713 | |
325 | locate'private_units 3846 | |
326 | locate'public_units 4633 | |
327 | locate'units_path 6126 | |
328 | main'check_definition 54773 | |
329 | main'check_last_declaration 54230 | |
330 | main'complete_line 60930 | |
331 | main'declared 55125 | |
332 | main'defined 55233 | |
333 | main'dump_obsolete 62573 | |
334 | main'end_extraction 11310 | |
335 | main'explore 56023 | |
336 | main'extract_dependencies 58072 | |
337 | main'init 2172 | |
338 | main'init_depend 56922 | |
339 | main'init_except 2398 | |
340 | main'init_extraction 7640 | |
341 | main'locate_units 3096 | |
342 | main'p_body 30108 | |
343 | main'p_c 16407 | |
344 | main'p_config 18051 | |
345 | main'p_default 20997 | |
346 | main'p_end 37191 | |
347 | main'p_file 25637 | |
348 | main'p_include 25132 | |
349 | main'p_init 20701 | |
350 | main'p_layout 24552 | |
351 | main'p_library 24994 | |
352 | main'p_lint 27612 | |
353 | main'p_magic 20094 | |
354 | main'p_make 11385 | |
355 | main'p_obsolete 15251 | |
356 | main'p_public 24918 | |
357 | main'p_shell 15408 | |
358 | main'p_temp 25209 | |
359 | main'p_unknown 42721 | |
360 | main'p_visible 21587 | |
361 | main'p_wanted 23362 | |
362 | main'profile 68613 | |
363 | main'record_obsolete 61520 | |
364 | main'sanity_checks 42966 | |
365 | main'tilda_expand 68258 | |
366 | main'tsort 64364 | |
367 | main'usage 2696 | |
368 | main'visible 55770 | |
369 | main'wanted 55361 | |
370 | tsort'extract_cycle 65932 | |
371 | tsort'outline_cycle 66900 | |
372 | tsort'resync 65029 | |
373 | tsort'sort 65253 | |
374 | tsort'sort_by_value 68052 | |
375 | tsort'visit 67522 | |
376 | ||
377 | # | |
378 | # End of offset table and beginning of dataloading section. | |
379 | # | |
380 | ||
381 | # General initializations | |
382 | sub main'load_init { | |
383 | package main; | |
384 | &init_except; # Token which have upper-cased letters | |
385 | &init_depend; # The %Depend array records control line handling | |
386 | } | |
387 | ||
388 | # Record the exceptions -- all symbols but these are lower case | |
389 | sub main'load_init_except { | |
390 | package main; | |
391 | $Except{'Author'}++; | |
392 | $Except{'Date'}++; | |
393 | $Except{'Header'}++; | |
394 | $Except{'Id'}++; | |
395 | $Except{'Locker'}++; | |
396 | $Except{'Log'}++; | |
397 | $Except{'RCSfile'}++; | |
398 | $Except{'Revision'}++; | |
399 | $Except{'Source'}++; | |
400 | $Except{'State'}++; | |
401 | } | |
402 | ||
403 | # Print out metalint's usage and exits | |
404 | sub main'load_usage { | |
405 | package main; | |
406 | print STDERR <<EOM; | |
407 | Usage: metalint [-hklsV] [-L dir] | |
408 | -h : print this help message and exits. | |
409 | -k : keep temporary directory. | |
410 | -l : also report problems from library units. | |
411 | -s : silent mode. | |
412 | -L : specify main units repository. | |
413 | -V : print version number and exits. | |
414 | EOM | |
415 | exit 1; | |
416 | } | |
417 | ||
418 | # Locate the units and push their path in @ARGV (sorted alphabetically) | |
419 | sub main'load_locate_units { | |
420 | package locate; | |
421 | print "Locating units...\n" unless $main'opt_s; | |
422 | local(*WD) = *main'WD; # Current working directory | |
423 | local(*MC) = *main'MC; # Public metaconfig library | |
424 | undef %myUlist; # Records private units paths | |
425 | undef %myUseen; # Records private/public conflicts | |
426 | &private_units; # Locate private units in @myUlist | |
427 | &public_units; # Locate public units in @ARGV | |
428 | @ARGV = sort @ARGV; # Sort it alphabetically | |
429 | push(@ARGV, sort @myUlist); # Append user's units sorted | |
430 | &dump_list if $main'opt_v; # Dump the list of units | |
431 | } | |
432 | ||
433 | # Dump the list of units on stdout | |
434 | sub locate'load_dump_list { | |
435 | package locate; | |
436 | print "\t"; | |
437 | $, = "\n\t"; | |
438 | print @ARGV; | |
439 | $, = ''; | |
440 | print "\n"; | |
441 | } | |
442 | ||
443 | # Scan private units | |
444 | sub locate'load_private_units { | |
445 | package locate; | |
446 | return unless -d 'U'; # Nothing to be done if no 'U' entry | |
447 | local(*ARGV) = *myUlist; # Really fill in @myUlist | |
448 | local($MC) = $WD; # We are really in the working directory | |
449 | &units_path("U"); # Locate units in the U directory | |
450 | local($unit_name); # Unit's name (without .U) | |
451 | local(@kept); # Array of kept units | |
452 | # Loop over the units and remove duplicates (the first one seen is the one | |
453 | # we keep). Also set the %myUseen H table to record private units seen. | |
454 | foreach (@ARGV) { | |
455 | ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path | |
456 | next if $myUseen{$unit_name}; # Already recorded | |
457 | $myUseen{$unit_name} = 1; # Record pirvate unit | |
458 | push(@kept, $_); # Keep this unit | |
459 | } | |
460 | @ARGV = @kept; | |
461 | } | |
462 | ||
463 | # Scan public units | |
464 | sub locate'load_public_units { | |
465 | package locate; | |
466 | chdir($MC) || die "Can't find directory $MC.\n"; | |
467 | &units_path("U"); # Locate units in public U directory | |
468 | chdir($WD) || die "Can't go back to directory $WD.\n"; | |
469 | local($path); # Relative path from $WD | |
470 | local($unit_name); # Unit's name (without .U) | |
471 | local(*Unit) = *main'Unit; # Unit is a global from main package | |
472 | local(@kept); # Units kept | |
473 | local(%warned); # Units which have already issued a message | |
474 | # Loop over all the units and keep only the ones that were not found in | |
475 | # the user's U directory. As it is possible two or more units with the same | |
476 | # name be found in | |
477 | foreach (@ARGV) { | |
478 | ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path | |
479 | next if $warned{$unit_name}; # We have already seen this unit | |
480 | $warned{$unit_name} = 1; # Remember we have warned the user | |
481 | if ($myUseen{$unit_name}) { # User already has a private unit | |
482 | $path = $Unit{$unit_name}; # Extract user's unit path | |
483 | next if $path eq $_; # Same path, we must be in mcon/ | |
484 | $path =~ s|^$WD/||o; # Weed out leading working dir path | |
485 | print " Your private $path overrides the public one.\n" | |
486 | unless $main'opt_s; | |
487 | } else { | |
488 | push(@kept, $_); # We may keep this one | |
489 | } | |
490 | } | |
491 | @ARGV = @kept; | |
492 | } | |
493 | ||
494 | # Recursively locate units in the directory. Each file ending with .U has to be | |
495 | # a unit. Others are stat()'ed, and if they are a directory, they are also | |
496 | # scanned through. The $MC and @ARGV variable are dynamically set by the caller. | |
497 | sub locate'load_units_path { | |
498 | package locate; | |
499 | local($dir) = @_; # Directory where units are to be found | |
500 | local(@contents); # Contents of the directory | |
501 | local($unit_name); # Unit's name, without final .U | |
502 | local($path); # Full path of a unit | |
503 | local(*Unit) = *main'Unit; # Unit is a global from main package | |
504 | unless (opendir(DIR, $dir)) { | |
505 | warn("Cannot open directory $dir.\n"); | |
506 | return; | |
507 | } | |
508 | print "Locating in $MC/$dir...\n" if $main'opt_v; | |
509 | @contents = readdir DIR; # Slurp the whole thing | |
510 | closedir DIR; # And close dir, ready for recursion | |
511 | foreach (@contents) { | |
512 | next if $_ eq '.' || $_ eq '..'; | |
513 | if (/\.U$/) { # A unit, definitely | |
514 | ($unit_name) = /^(.*)\.U$/; | |
515 | $path = "$MC/$dir/$_"; # Full path of unit | |
516 | push(@ARGV, $path); # Record its path | |
517 | if (defined $Unit{$unit_name}) { # Already seen this unit | |
518 | if ($main'opt_v) { | |
519 | ($path) = $Unit{$unit_name} =~ m|^(.*)/.*|; | |
520 | print " We've already seen $unit_name.U in $path.\n"; | |
521 | } | |
522 | } else { | |
523 | $Unit{$unit_name} = $path; # Map name to path | |
524 | } | |
525 | next; | |
526 | } | |
527 | # We have found a file which does not look like a unit. If it is a | |
528 | # directory, then scan it. Otherwise skip the file. | |
529 | unless (-d "$dir/$_") { | |
530 | print " Skipping file $_ in $dir.\n" if $main'opt_v; | |
531 | next; | |
532 | } | |
533 | &units_path("$dir/$_"); | |
534 | print "Back to $MC/$dir...\n" if $main'opt_v; | |
535 | } | |
536 | } | |
537 | ||
538 | # Initialize the extraction process by setting some variables. | |
539 | # We return a string to be eval'ed to do more customized initializations. | |
540 | sub main'load_init_extraction { | |
541 | package main; | |
542 | $c_symbol = ''; # Current symbol seen in ?C: lines | |
543 | $s_symbol = ''; # Current symbol seen in ?S: lines | |
544 | $m_symbol = ''; # Current symbol seen in ?M: lines | |
545 | $h_section = 0; # 0 = no ?H: yet, 1 = in ?H:, 2 = ?H:. seen | |
546 | $h_section_warned = 0; # Whether we warned about terminated ?H: section | |
547 | $heredoc = ''; # Last "here" document symbol seen | |
548 | $heredoc_nosubst = 0; # True for <<'EOM' here docs | |
549 | $heredoc_line = 0; # Line were last "here" document started | |
550 | $last_interpreted = 0; # True when last line was an '@' one | |
551 | $past_first_line = 0; # True when first body line was already seen | |
552 | $wiped_unit = 0; # True if unit will be "wiped" for macro subst | |
553 | %csym = (); # C symbols described | |
554 | %ssym = (); # Shell symbols described | |
555 | %hcsym = (); # C symbols used by ?H: lines | |
556 | %hssym = (); # Shell symbols used by ?H: lines | |
557 | %msym = (); # Magic symbols defined by ?M: lines | |
558 | %mdep = (); # C symbol dependencies introduced by ?M: | |
559 | %symset = (); # Records all the shell symbol set | |
560 | %symused = (); # Records all the shell symbol used | |
561 | %tempseen = (); # Temporary shell variable seen | |
562 | %fileseen = (); # Produced files seen | |
563 | %fileused = (); # Files used, by unit (private UU files) | |
564 | %filemisused = (); # Files not used as ./file or ...UU/file | |
565 | %filetmp = (); # Local temporary files in ?F: directives | |
566 | %filesetin = (); # Lists units defining a temporary file | |
567 | %filecreated = (); # Records files created in this unit | |
568 | %prodfile = (); # Unit where a given file is said to be created | |
569 | %defseen = (); # Symbol defintions claimed | |
570 | %lintset = (); # Symbols declared set by a ?LINT: line | |
571 | %lintsdesc = (); # Symbols declared described by a ?LINT: line | |
572 | %lintcdesc = (); # Symbols declared described by a ?LINT: line | |
573 | %lintseen = (); # Symbols declared known by a ?LINT: line | |
574 | %lintchange = (); # Symbols declared changed by a ?LINT: line | |
575 | %lintuse = (); # Symbols declared used by unit | |
576 | %lintextern = (); # Symbols known to be externally defined | |
577 | %lintcreated = (); # Files declared as created by a ?LINT: line | |
578 | %linthere = (); # Unclosed here document from ?LINT: line | |
579 | %lintnothere = (); # False here document names, from ?LINT: line | |
580 | %lintfused = (); # Records files markedas used in ?LINT: line | |
581 | %lintchange_used = (); # Tracks symbols for which %lintchange was used | |
582 | %lintuse_used = (); # Tracks symbols for which %lintuse was used | |
583 | %lintseen_used = (); # Tracks symbols for which %lintseen was used | |
584 | %lintcdesc_used = (); # Tracks symbols for which %lintcdesc was used | |
585 | %lintsdesc_used = (); # Tracks symbols for which %lintsdesc was used | |
586 | %lintset_used = (); # Tracks symbols for which %lintset was used | |
587 | %lintnocomment = (); # Signals it's OK for unit to lack a : comment | |
588 | %condsym = (); # Records all the conditional symbols | |
589 | %condseen = (); # Records conditional dependencies | |
590 | %depseen = (); # Records full dependencies | |
591 | %shvisible = (); # Records units making a symbol visible | |
592 | %shspecial = (); # Records special units listed as wanted | |
593 | %shdepend = (); # Records units listed in one's dependency list | |
594 | %shmaster = (); # List of units defining a shell symbol | |
595 | %cmaster = (); # List of units defining a C symbol | |
596 | %symdep = (); # Records units where symbol is a dependency | |
597 | @make = (); # Records make dependency lines | |
598 | $body = 'p_body'; # Procedure to handle body | |
599 | $ending = 'p_end'; # Called at the end of each unit | |
600 | @wiping = qw( # The keywords we recognize for "wiped" units | |
601 | PACKAGENAME | |
602 | MAINTLOC | |
603 | VERSION | |
604 | PATCHLEVEL | |
605 | REVISION | |
606 | DATE | |
607 | BASEREV | |
608 | ); | |
609 | } | |
610 | ||
611 | # End the extraction process | |
612 | sub main'load_end_extraction { | |
613 | package main; | |
614 | } | |
615 | ||
616 | # Process the ?MAKE: line | |
617 | sub main'load_p_make { | |
618 | package main; | |
619 | local($_) = @_; | |
620 | local(@ary); # Locally defined symbols | |
621 | local(@dep); # Dependencies | |
622 | local($where) = "\"$file\", line $. (?MAKE:)"; | |
623 | unless (/^[\w+ ]*:/) { | |
624 | $wiped_unit++ if /^\t+-pick\s+wipe\b/; | |
625 | return; # We only want the main dependency rule | |
626 | } | |
627 | warn "$where: ignoring duplicate dependency listing line.\n" | |
628 | if $makeseen{$unit}++; | |
629 | return if $makeseen{$unit} > 1; | |
630 | ||
631 | # Reset those once for every unit | |
632 | # (assuming there is only one depend line) | |
633 | $h_section = 0; # 0 = no ?H: yet, 1 = in ?H:, 2 = ?H:. seen | |
634 | $h_section_warned = 0; # Whether we warned about terminated ?H: section | |
635 | $wiped_unit = 0; # Whether macros like "<MAINTLOC> will be wiped | |
636 | undef %condseen; | |
637 | undef %depseen; | |
638 | undef %defseen; | |
639 | undef %tempseen; | |
640 | undef %symset; | |
641 | undef %symused; | |
642 | undef %csym; | |
643 | undef %ssym; | |
644 | undef %hcsym; | |
645 | undef %hssym; | |
646 | undef %lintuse; | |
647 | undef %lintuse_used; | |
648 | undef %lintseen; | |
649 | undef %lintchange; | |
650 | undef %lintchange_used; | |
651 | undef %lintextern; | |
652 | undef %lintcreated; | |
653 | undef %fileseen; | |
654 | undef %lintseen_used; | |
655 | undef %filetmp; | |
656 | undef %filecreated; | |
657 | undef %linthere; | |
658 | undef %lintnothere; | |
659 | undef %lintfused; | |
660 | undef %lintsdesc; | |
661 | undef %lintsdesc_used; | |
662 | undef %lintcdesc; | |
663 | undef %lintcdesc_used; | |
664 | undef %lintset; | |
665 | undef %lintset_used; | |
666 | ||
667 | s|^\s*||; # Remove leading spaces | |
668 | chop; | |
669 | s/:(.*)//; | |
670 | @dep = split(' ', $1); # Dependencies | |
671 | @ary = split(' '); # Locally defined symbols | |
672 | local($nowarn); # True when +Special is seen | |
673 | foreach $sym (@ary) { | |
674 | # Ignore "internal use only" symbols as far as metalint goes. | |
675 | # Actually, we record the presence of a '+' in front of a special | |
676 | # unit name and use that as a hint to suppress the presence of that | |
677 | # special unit in the defined symbol section. | |
678 | $nowarn = ($sym =~ s/^\+//); | |
679 | ||
680 | # We record for each shell symbol the list of units which claim to make | |
681 | # it, so as to report duplicates. | |
682 | if ($sym =~ /^[_a-z]/ || $Except{$sym}) { | |
683 | $shmaster{"\$$sym"} .= "$unit "; | |
684 | ++$defseen{$sym}; | |
685 | } else { | |
686 | warn "$where: special unit '$sym' should not be listed as made.\n" | |
687 | unless $sym eq $unit || $nowarn; | |
688 | } | |
689 | } | |
690 | # Record dependencies for later perusal | |
691 | push(@make, join(' ', @ary) . ':' . join(' ', @dep)); | |
692 | foreach $sym (@dep) { | |
693 | if ($sym =~ /^\+[_A-Za-z]/) { | |
694 | $sym =~ s|^\+||; | |
695 | ++$condseen{$sym}; # Conditional symbol wanted | |
696 | ++$condsym{$sym}; # %condsym has a greater lifetime | |
697 | } else { | |
698 | ++$depseen{$sym}; # Full dependency | |
699 | } | |
700 | ||
701 | # Each 'wanted' special unit (i.e. one starting with a capital letter) | |
702 | # is remembered, so as to prevent exported symbols from being reported | |
703 | # as "undefined". For instance, Myread exports $dflt, $ans and $rp. | |
704 | $shspecial{$unit} .= "$sym " if substr($sym, 0, 1) =~ /^[A-Z]/; | |
705 | ||
706 | # Record all known dependencies (special or not) for this unit | |
707 | $shdepend{$unit} .= "$sym "; | |
708 | ||
709 | # Remember where wanted symbol is defined, so that we can report | |
710 | # stale dependencies later on (i.e. dependencies which refer to non- | |
711 | # existent symbols). | |
712 | $symdep{$sym} .= "$unit "; # This symbol is wanted here | |
713 | } | |
714 | # Make sure we do not want a symbol twice, nor do we want it once as a full | |
715 | # dependency and once as a conditional dependency. | |
716 | foreach $sym (@dep) { | |
717 | if ($sym =~ /^\+[_A-Za-z]/) { | |
718 | $sym =~ s|^\+||; | |
719 | warn "$where: '+$sym' is listed $condseen{$sym} times.\n" | |
720 | if $condseen{$sym} > 1; | |
721 | $condseen{$sym} = 1 if $condseen{$sym}; # Avoid multiple messages | |
722 | } else { | |
723 | warn "$where: '$sym' is listed $depseen{$sym} times.\n" | |
724 | if $depseen{$sym} > 1; | |
725 | $depseen{$sym} = 1 if $depseen{$sym}; # Avoid multiple messages | |
726 | } | |
727 | warn "$where: '$sym' listed as both conditional and full dependency.\n" | |
728 | if $condseen{$sym} && $depseen{$sym}; | |
729 | } | |
730 | # Make sure every unit "inherits" from the symbols exported by 'Init'. | |
731 | $shspecial{$unit} .= 'Init ' unless $shspecial{$unit} =~ /Init\b/; | |
732 | } | |
733 | ||
734 | # Process the ?O: line | |
735 | sub main'load_p_obsolete { | |
736 | package main; | |
737 | local($_) = @_; | |
738 | chop; | |
739 | $Obsolete{"$unit.U"} = $_; # Message to print if unit is used | |
740 | } | |
741 | ||
742 | # Process the ?S: lines | |
743 | sub main'load_p_shell { | |
744 | package main; | |
745 | local($_) = @_; | |
746 | local($where) = "\"$file\", line $. (?S:)"; | |
747 | warn "$where: directive should come after ?MAKE declarations.\n" | |
748 | unless $makeseen{$unit}; | |
749 | if (/^(\w+)\s*(\(.*\))*\s*:/) { | |
750 | &check_last_declaration; | |
751 | $s_symbol = $1; | |
752 | print " ?S: $s_symbol\n" if $opt_d; | |
753 | # Make sure we do not define symbol twice and that the symbol is indeed | |
754 | # listed in the ?MAKE: line. | |
755 | warn "$where: duplicate description for variable '\$$s_symbol'.\n" | |
756 | if $ssym{$s_symbol}++; | |
757 | unless ($defseen{$s_symbol}) { | |
758 | warn "$where: variable '\$$s_symbol' is not listed " . | |
759 | "on ?MAKE: line.\n" unless $lintseen{$s_symbol}; | |
760 | $lintseen_used{$s_symbol}++ if $lintseen{$s_symbol}; | |
761 | } | |
762 | # Deal with obsolete symbol list (enclosed between parenthesis) | |
763 | &record_obsolete("\$$_") if /\(/; | |
764 | } else { | |
765 | unless ($s_symbol) { | |
766 | warn "$where: syntax error in ?S: construct.\n"; | |
767 | return; | |
768 | } | |
769 | } | |
770 | ||
771 | m|^\.\s*$| && ($s_symbol = ''); # End of comment | |
772 | } | |
773 | ||
774 | # Process the ?C: lines | |
775 | sub main'load_p_c { | |
776 | package main; | |
777 | local($_) = @_; | |
778 | local($where) = "\"$file\", line $. (?C:)"; | |
779 | warn "$where: directive should come after ?MAKE declarations.\n" | |
780 | unless $makeseen{$unit}; | |
781 | # The previous ?H: section, if present, must have been closed | |
782 | if ($h_section && $h_section != 2) { | |
783 | warn "$where: unclosed ?H: section.\n"; | |
784 | } | |
785 | $h_section = 0; | |
786 | if (s/^(\w+)\s*~\s*(\S+)\s*(.*):/$1 $3:/) { | |
787 | &check_last_declaration; | |
788 | $c_symbol = $2; # Alias for definition in config.h | |
789 | # Record symbol definition for further duplicate spotting | |
790 | $cmaster{$1} .= "$unit " unless $csym{$1}; | |
791 | print " ?C: $1 ~ $c_symbol\n" if $opt_d; | |
792 | # Make sure we do not define symbol twice | |
793 | warn "$where: duplicate description for symbol '$1'.\n" | |
794 | if $csym{$1}++; | |
795 | # Deal with obsolete symbol list (enclosed between parenthesis) | |
796 | &record_obsolete("$_") if /\(/; | |
797 | } elsif (/^(\w+)\s*(\(.*\))*\s*:/) { | |
798 | &check_last_declaration; | |
799 | $c_symbol = $1; | |
800 | # Record symbol definition for further duplicate spotting | |
801 | $cmaster{$c_symbol} .= "$unit " unless $csym{$c_symbol}; | |
802 | print " ?C: $c_symbol\n" if $opt_d; | |
803 | # Make sure we do not define symbol twice | |
804 | warn "$where: duplicate description for symbol '$c_symbol'.\n" | |
805 | if $csym{$c_symbol}++; | |
806 | # Deal with obsolete symbol list (enclosed between parenthesis) | |
807 | &record_obsolete("$_") if /\(/; | |
808 | } else { | |
809 | unless ($c_symbol) { | |
810 | warn "$where: syntax error in ?C: construct.\n"; | |
811 | return; | |
812 | } | |
813 | } | |
814 | ||
815 | s|^(\w+)|?$c_symbol:/* $1| || # Start of comment | |
816 | (s|^\.\s*$|?$c_symbol: */\n| && ($c_symbol = '', 1)) || # End of comment | |
817 | s|^(.*)|?$c_symbol: *$1|; # Middle of comment | |
818 | } | |
819 | ||
820 | # Process the ?H: lines | |
821 | sub main'load_p_config { | |
822 | package main; | |
823 | local($_) = @_; | |
824 | local($where) = "\"$file\", line $. (?H)" unless $where; | |
825 | warn "$where: directive should come after ?MAKE declarations.\n" | |
826 | unless $makeseen{$unit}; | |
827 | unless ($h_section){ # Entering ?H: section | |
828 | $h_section = 1; | |
829 | $h_section_warned = 0; | |
830 | } | |
831 | if ($h_section == 2) { | |
832 | warn "$where: section was already terminated by '?H:.'.\n" | |
833 | unless $h_section_warned++; | |
834 | return; | |
835 | } | |
836 | if ($_ eq ".\n") { | |
837 | $h_section = 2; # Marks terminated ?H: section | |
838 | return; | |
839 | } | |
840 | (my $constraint) = m/^\?(\w+):/; | |
841 | s/^\?\w+://; # Remove leading '?var:' constraint | |
842 | if (m|^#\$(\w+)\s+(\w+).*\$(\w+)|) { | |
843 | # Case: #$d_var VAR "$var" | |
844 | warn "$where: symbol '$2' was already defined.\n" if $hcsym{$2}++; | |
845 | &check_definition("$1"); | |
846 | &check_definition("$3"); | |
847 | } elsif (m|^#define\s+(\w+)\((.*)\)\s+\$(\w+)|) { | |
848 | # Case: #define VAR(x) $var | |
849 | warn "$where: symbol '$1' was already defined.\n" if $hcsym{$1}++; | |
850 | &check_definition("$3"); | |
851 | } elsif (m|^#\$define\s+(\w+)|) { | |
852 | # Case: #$define VAR | |
853 | warn "$where: symbol '$1' was already defined.\n" if $hcsym{$1}++; | |
854 | } elsif (m|^#\$(\w+)\s+(\w+)|) { | |
855 | # Case: #$d_var VAR | |
856 | warn "$where: symbol '$2' was already defined.\n" if $hcsym{$2}++; | |
857 | &check_definition("$1"); | |
858 | } elsif (m|^#define\s+(\w+).*\$(\w+)|) { | |
859 | # Case: #define VAR "$var" | |
860 | warn "$where: symbol '$1' was already defined.\n" if $hcsym{$1}++; | |
861 | &check_definition("$2"); | |
862 | } elsif (m|^#define\s+(\w+)|) { | |
863 | # Case: #define VAR | |
864 | $hcsym{$1}++; # Multiple occurrences may be legitimate | |
865 | } else { | |
866 | if (/^#/) { | |
867 | warn "$where: uncommon cpp line should be protected with '?%<:'.\n" | |
868 | if $constraint eq ''; | |
869 | } elsif (!/^\@(if|elsif|else|end)\b/) { | |
870 | warn "$where: line should not be listed here but in '?C:'.\n"; | |
871 | } | |
872 | } | |
873 | ||
874 | # Ensure the constraint is either %< (unit base name) or a known symbol. | |
875 | if ($constraint ne '' && $constraint ne $unit) { | |
876 | warn "$where: constraint '$constraint' is an unknown symbol.\n" | |
877 | unless $csym{$constraint} || $ssym{$constraint}; | |
878 | } | |
879 | } | |
880 | ||
881 | # Process the ?M: lines | |
882 | sub main'load_p_magic { | |
883 | package main; | |
884 | local($_) = @_; | |
885 | local($where) = "\"$file\", line $. (?M)"; | |
886 | warn "$where: directive should come after ?MAKE declarations.\n" | |
887 | unless $makeseen{$unit}; | |
888 | if (/^(\w+):\s*([\w\s]*)\n$/) { | |
889 | &check_last_declaration; | |
890 | $m_symbol = $1; | |
891 | $msym{$1} = "$unit"; # p_wanted ensure we do not define symbol twice | |
892 | $mdep{$1} = $2; # Save C symbol dependencies | |
893 | &p_wanted("$unit:$m_symbol"); | |
894 | } else { | |
895 | unless ($m_symbol) { | |
896 | warn "$where: syntax error in ?M: construct.\n"; | |
897 | return; | |
898 | } | |
899 | } | |
900 | m|^\.\s*$| && ($m_symbol = ''); # End of comment | |
901 | } | |
902 | ||
903 | # Process the ?INIT: lines | |
904 | sub main'load_p_init { | |
905 | package main; | |
906 | local($_) = @_; | |
907 | local($where) = "\"$file\", line $. (?INIT)"; | |
908 | warn "$where: directive should come after ?MAKE declarations.\n" | |
909 | unless $makeseen{$unit}; | |
910 | &p_body($_, 1); # Pass it along as a body line (leading ?INIT: removed) | |
911 | } | |
912 | ||
913 | # Process the ?D: lines | |
914 | sub main'load_p_default { | |
915 | package main; | |
916 | local($_) = @_; | |
917 | local($where) = "\"$file\", line $. (?D)"; | |
918 | warn "$where: directive should come after ?MAKE declarations.\n" | |
919 | unless $makeseen{$unit}; | |
920 | local($sym) = /^(\w+)=/; | |
921 | $hasdefault{$sym}++; | |
922 | unless ($defseen{$sym}) { | |
923 | warn "$where: variable '\$$sym' is not listed " . | |
924 | "on ?MAKE: line.\n" unless $lintseen{$sym}; | |
925 | $lintseen_used{$sym}++ if $lintseen{$sym}; | |
926 | } | |
927 | s/^\w+=//; # So that p_body does not consider variable as being set | |
928 | &p_body($_, 1); # Pass it along as a body line (leading ?D: + var removed) | |
929 | } | |
930 | ||
931 | # Process the ?V: lines | |
932 | sub main'load_p_visible { | |
933 | package main; | |
934 | local($where) = "\"$file\", line $. (?V)"; | |
935 | warn "$where: directive should come after ?MAKE declarations.\n" | |
936 | unless $makeseen{$unit}; | |
937 | ||
938 | # A visible symbol can freely be manipulated by any unit which includes the | |
939 | # current unit in its dependencies. Symbols before ':' may be only used for | |
940 | # reading while symbols after ':' may be used for both reading and writing. | |
941 | # The array %shvisible records symbols as keys. Read-only symbols have a | |
942 | # leading '$' while read-write symbols are recorded as-is. | |
943 | ||
944 | unless (substr($unit, 0, 1) =~ /^[A-Z]/) { | |
945 | warn "$where: visible declaration in non-special unit ignored.\n"; | |
946 | return; | |
947 | } | |
948 | local($read_only) = $_[0] =~ /^([^:]*):?/; | |
949 | local($read_write) = $_[0] =~ /:(.*)/; | |
950 | local(@rsym) = split(' ', $read_only); | |
951 | local(@rwsym) = split(' ', $read_write); | |
952 | local($w); | |
953 | foreach (@rsym) { # Read only symbols | |
954 | warn "$where: wanted variable '\$$_' made visible.\n" if &wanted($_); | |
955 | warn "$where: defined variable '\$$_' made visible.\n" | |
956 | if &defined($_) && !$lintseen{$_}; | |
957 | $w = $shvisible{"\$$_"}; | |
958 | warn "$where: variable '\$$_' already made visible by unit $w.\n" if $w; | |
959 | $w = $shvisible{$_}; | |
960 | warn "$where: variable '\$$_' already read-write visible in $w.\n" if $w; | |
961 | $shvisible{"\$$_"} = $unit unless $w; | |
962 | } | |
963 | foreach (@rwsym) { # Read/write symbols | |
964 | warn "$where: wanted variable '\$$_' made visible.\n" if &wanted($_); | |
965 | warn "$where: defined variable '\$$_' made visible.\n" | |
966 | if &defined($_) && !$lintseen{$_}; | |
967 | $w = $shvisible{$_}; | |
968 | warn "$where: variable '\$$_' already made visible by unit $w.\n" if $w; | |
969 | $w = $shvisible{"\$$_"}; | |
970 | warn "$where: variable '\$$_' already read-only visible in $w.\n" if $w; | |
971 | $shvisible{$_} = $unit unless $w; | |
972 | } | |
973 | } | |
974 | ||
975 | # Process the ?W: lines | |
976 | sub main'load_p_wanted { | |
977 | package main; | |
978 | local($where) = "\"$file\", line $. (?W)" unless $where; | |
979 | warn "$where: directive should come after ?MAKE declarations.\n" | |
980 | unless $makeseen{$unit}; | |
981 | # Somehow, we should check that none of the symbols to activate are stale | |
982 | # ones, i.e. they all finally resolve to some known target -- FIXME | |
983 | local($active) = $_[0] =~ /^([^:]*):/; # Symbols to activate | |
984 | local($look_symbols) = $_[0] =~ /:(.*)/; # When those are used | |
985 | local(@symbols) = split(' ', $look_symbols); | |
986 | # A "?W:symbol" line asks metaconfig to define 'symbol' in the wanted file | |
987 | # as a C target iff that word is found within the sources. This is mainly | |
988 | # intended for the built-in interpreter to check for definedness. | |
989 | local($w); | |
990 | foreach (@symbols) { | |
991 | warn "$where: variable '\$$_' already wanted.\n" if &wanted($_); | |
992 | warn "$where: variable '\$$_' also locally defined.\n" if &defined($_); | |
993 | $w = $cwanted{$_}; | |
994 | if ($msym{$_} ne '') { | |
995 | warn "$where: symbol '$_' already listed on a ?M: line in '$w'.\n" | |
996 | if $w; | |
997 | } else { | |
998 | warn "$where: variable '\$$_' already listed on a ?W: line in '$w'.\n" | |
999 | if $w; | |
1000 | } | |
1001 | $cwanted{$_} = $unit unless $w; | |
1002 | } | |
1003 | } | |
1004 | ||
1005 | # Process the ?Y: lines | |
1006 | sub main'load_p_layout { | |
1007 | package main; | |
1008 | local($where) = "\"$file\", line $. (?Y)"; | |
1009 | warn "$where: directive should come after ?MAKE declarations.\n" | |
1010 | unless $makeseen{$unit}; | |
1011 | local($_) = @_; | |
1012 | chop; | |
1013 | s/^\s+//; | |
1014 | tr/A-Z/a-z/; # Layouts are record in lowercase | |
1015 | warn "$where: unknown layout directive '$_'.\n" | |
1016 | unless defined $Lcmp{$_}; | |
1017 | } | |
1018 | ||
1019 | # Process the ?P: lines | |
1020 | sub main'load_p_public { | |
1021 | package main; | |
1022 | # FIXME | |
1023 | } | |
1024 | ||
1025 | # Process the ?L: lines | |
1026 | sub main'load_p_library { | |
1027 | package main; | |
1028 | # There should not be any '-l' in front of the library name | |
1029 | # FIXME | |
1030 | } | |
1031 | ||
1032 | # Process the ?I: lines | |
1033 | sub main'load_p_include { | |
1034 | package main; | |
1035 | # FIXME | |
1036 | } | |
1037 | ||
1038 | # Process the ?T: lines | |
1039 | sub main'load_p_temp { | |
1040 | package main; | |
1041 | local($where) = "\"$file\", line $. (?T:)"; | |
1042 | warn "$where: directive should come after ?MAKE declarations.\n" | |
1043 | unless $makeseen{$unit}; | |
1044 | local($_) = @_; | |
1045 | local(@sym) = split(' ', $_); | |
1046 | foreach $sym (@sym) { | |
1047 | warn "$where: temporary symbol '\$$sym' multiply declared.\n" | |
1048 | if $tempseen{$sym}++ == 1; | |
1049 | $tempmaster{$sym} .= "$unit " if $tempseen{$sym} == 1; | |
1050 | } | |
1051 | } | |
1052 | ||
1053 | # Process the ?F: lines | |
1054 | sub main'load_p_file { | |
1055 | package main; | |
1056 | local($where) = "\"$file\", line $. (?F:)"; | |
1057 | warn "$where: directive should come after ?MAKE declarations.\n" | |
1058 | unless $makeseen{$unit}; | |
1059 | local($_) = @_; | |
1060 | local(@files) = split(' ', $_); | |
1061 | local($uufile); # Name of file produced in the UU directory | |
1062 | local($tmpfile); # Name of a temporary file | |
1063 | # We care only about UU files, i.e. files produced in the UU directory | |
1064 | # and which are identified by the convention ./filename. Files !filename | |
1065 | # are not produced, i.e. they are temporary or externally provided. | |
1066 | # The %prodfile table records all the files produced, so we may detect | |
1067 | # inconsistencies between units, while %filemaster records the (first) unit | |
1068 | # defining a given UU file to make sure that (special) unit is named in the | |
1069 | # dependency line when that UU file if used. Duplicates will be caught in | |
1070 | # the sanity check phase thanks to %prodfile. | |
1071 | # Temporary files are recorded in %filesetin, so that we may later compare | |
1072 | # the list with the UU files to detect possible overwrites. | |
1073 | my $is_special = substr($unit, 0, 1) =~ /^[A-Z]/; | |
1074 | foreach $file (@files) { | |
1075 | warn "$where: produced file '$file' multiply declared.\n" | |
1076 | if $fileseen{$file}++ == 1; | |
1077 | if (($tmpfile = $file) =~ s/^!//) { | |
1078 | $filetmp{$tmpfile} = 'x '; | |
1079 | $filesetin{$tmpfile} .= "$unit " if $fileseen{$file} == 1; | |
1080 | next; # Is not a UU file for sure, so skip | |
1081 | } | |
1082 | $prodfile{$file} .= "$unit " if $fileseen{$file} == 1; | |
1083 | ($uufile = $file) =~ s|^\./(\S+)$|$1|; | |
1084 | next if $file eq $uufile; # Don't care about non-UU files | |
1085 | unless ($is_special || $lintcreated{$uufile}) { | |
1086 | warn "$where: UU file '$uufile' in non-special unit ignored.\n"; | |
1087 | delete $lintcreated{$uufile}; # Detect spurious LINT | |
1088 | next; | |
1089 | } | |
1090 | delete $lintcreated{$uufile} if !$is_special; # Detect spurious LINT | |
1091 | $filemaster{$uufile} = $unit unless defined $filemaster{$uufile}; | |
1092 | $filecreated{$uufile} = 'a'; # Will be automagically incremented | |
1093 | } | |
1094 | } | |
1095 | ||
1096 | # Process the ?LINT: lines | |
1097 | sub main'load_p_lint { | |
1098 | package main; | |
1099 | local($_) = @_; | |
1100 | local(@sym); | |
1101 | local($where) = "\"$file\", line $. (?LINT:)"; | |
1102 | s/^\s+//; # Strip leading spaces | |
1103 | unless ($makeseen{$unit}) { | |
1104 | warn "$where: directive should come after ?MAKE declarations.\n" | |
1105 | unless m/^empty/; | |
1106 | } | |
1107 | if (s/^set//) { # Listed variables are set | |
1108 | @sym = split(' ', $_); # Spurious ones will be flagged | |
1109 | foreach (@sym) { | |
1110 | $lintset{$_}++; # Shell variable set | |
1111 | } | |
1112 | } elsif (s/^desc\w+//) { # Listed shell variables are described | |
1113 | @sym = split(' ', $_); # Spurious ones will be flagged | |
1114 | foreach (@sym) { | |
1115 | $lintsdesc{$_}++; # Shell variable described | |
1116 | } | |
1117 | } elsif (s/^creat\w+//) { # Listed created files in regular units | |
1118 | @sym = split(' ', $_); | |
1119 | foreach (@sym) { | |
1120 | $lintcreated{$_}++; # Persistent UU file created | |
1121 | } | |
1122 | } elsif (s/^known//) { # Listed C variables are described | |
1123 | @sym = split(' ', $_); # Spurious ones will be flagged | |
1124 | foreach (@sym) { | |
1125 | $lintcdesc{$_}++; # C symbol described | |
1126 | } | |
1127 | } elsif (s/^change//) { # Shell variable ok to be changed | |
1128 | @sym = split(' ', $_); # Spurious ones will be flagged | |
1129 | foreach (@sym) { | |
1130 | $lintchange{$_}++; # Do not complain if changed | |
1131 | } | |
1132 | } elsif (s/^extern//) { # Variables known to be externally defined | |
1133 | @sym = split(' ', $_); | |
1134 | foreach (@sym) { | |
1135 | $lintextern{$_}++; # Do not complain if used in a ?H: line | |
1136 | } | |
1137 | } elsif (s/^usefile//) { # Files marked as being used | |
1138 | @sym = split(' ', $_); | |
1139 | foreach (@sym) { | |
1140 | $lintfused{$_}++; | |
1141 | } | |
1142 | } elsif (s/^use//) { # Variables declared as used by unit | |
1143 | @sym = split(' ', $_); # Spurious ones will be flagged | |
1144 | foreach (@sym) { | |
1145 | $lintuse{$_}++; # Do not complain if on ?MAKE and not used | |
1146 | } | |
1147 | } elsif (s/^def\w+//) { # Listed variables are defined | |
1148 | @sym = split(' ', $_); # Spurious ones will be flagged | |
1149 | foreach (@sym) { | |
1150 | $lintseen{$_}++; # Shell variable defined in this unit | |
1151 | } | |
1152 | } elsif (m/^empty/) { # Empty unit file | |
1153 | $lintempty{$unit}++; | |
1154 | } elsif (m/^unclosed/) { # Unclosed here-documents | |
1155 | @sym = split(' ', $_); | |
1156 | foreach (@sym) { | |
1157 | $linthere{$_}++; | |
1158 | } | |
1159 | } elsif (s/^nothere//) { # Not a here-document name | |
1160 | @sym = split(' ', $_); | |
1161 | foreach (@sym) { | |
1162 | $lintnothere{$_}++; | |
1163 | } | |
1164 | } elsif (s/^nocomment//) { # OK if leading unit ': comment' missing | |
1165 | $lintnocomment{$unit}++; | |
1166 | } else { | |
1167 | local($where) = "\"$file\", line $." unless $where; | |
1168 | local($word) = /^(\w+)/; | |
1169 | warn "$where: unknown LINT request '$word' ignored.\n"; | |
1170 | } | |
1171 | } | |
1172 | ||
1173 | # Process the body of the unit | |
1174 | sub main'load_p_body { | |
1175 | package main; | |
1176 | return unless $makeseen{$unit}; | |
1177 | local($_, $special) = @_; | |
1178 | local($where) = "\"$file\", line $." unless $where; | |
1179 | # Ensure there is no control line in the body of the unit | |
1180 | local($control) = /^\?([\w\-]+):/; | |
1181 | local($known) = $control ? $Depend{$control} : ""; | |
1182 | warn "$where: control sequence '?$control:' ignored within body.\n" | |
1183 | if $known && !/^\?X:|^\?LINT:/; | |
1184 | if (s/^\?LINT://) { # ?LINT directives allowed within body | |
1185 | $_ .= &complete_line(FILE) if s/\\\s*$//; | |
1186 | &p_lint($_); | |
1187 | } | |
1188 | return if $known; | |
1189 | # First non-special line should be a ': description' line | |
1190 | unless ($special || /^\?/ || /^@/) { | |
1191 | warn "$where: first body line should be a general ': description'.\n" | |
1192 | unless $past_first_line++ || $lintnocomment{$unit} || /^:\s+\w+/; | |
1193 | } | |
1194 | # Ensure ': comment' lines do not hold any meta-character | |
1195 | # We assume ":)" introduces a case statement. | |
1196 | if (/^\s*:/ && !/^\s*:\)/) { | |
1197 | warn "$where: missing space after ':' to make it a comment.\n" | |
1198 | unless /^\s*:\s/; | |
1199 | s/\\.//g; # simplistic ignoring of "escaped" chars | |
1200 | s/".*?"//g; | |
1201 | s/'.*?'//g; | |
1202 | if ($wiped_unit) { | |
1203 | s/<\$\w+>//g; | |
1204 | foreach my $wipe (@wiping) { | |
1205 | s/<$wipe>//g; | |
1206 | } | |
1207 | } | |
1208 | warn "$where: found unquoted meta-character $1 on comment line.\n" | |
1209 | while s/([`()<>;&\{\}\|])//g; | |
1210 | warn "$where: found dangling quote on ':' comment line.\n" if /['"]/; | |
1211 | return; | |
1212 | } | |
1213 | # Ingnore interpreted lines and their continuations | |
1214 | if ($last_interpreted) { | |
1215 | return if /\\$/; # Still part of the interpreted line | |
1216 | $last_interpreted = 0; # End of interpreted lines | |
1217 | return; # This line was the last interpreted | |
1218 | } | |
1219 | # Look for interpreted lines and ignore them | |
1220 | if (/^@/) { | |
1221 | $last_interpreted = /\\$/; # Set flag if line is continued | |
1222 | return; # And skip this line | |
1223 | } | |
1224 | # Detect ending of "here" documents | |
1225 | if ($heredoc ne '' && $_ eq "$heredoc\n") { | |
1226 | $heredoc = ''; # Close here-document | |
1227 | $heredoc_nosubst = 0; | |
1228 | return; | |
1229 | } | |
1230 | # Detect beginning of "here" document | |
1231 | my $began_here = 0; | |
1232 | if ($heredoc eq '') { | |
1233 | if (/<<\s*''/) { | |
1234 | # Discourage it, because we're not processing those... | |
1235 | warn "$where: empty here-document name discouraged.\n"; | |
1236 | } elsif (/<<\s*'([^']+)'/ && !$lintnothere{$1}) { | |
1237 | $heredoc = $1; | |
1238 | $heredoc_nosubst = 1; | |
1239 | $began_here++; | |
1240 | } elsif (/<<\s*(\S+)/ && !$lintnothere{$1}) { | |
1241 | $heredoc = $1; | |
1242 | $began_here++; | |
1243 | } | |
1244 | # Continue, as we need to look for possible ">file" on the same line | |
1245 | # as a possible here document, as in "cat <<EOM >file". | |
1246 | } else { | |
1247 | return if $heredoc_nosubst; # Completely opaque to interpretation | |
1248 | } | |
1249 | $heredoc_line = $. if $began_here; | |
1250 | ||
1251 | # If we've just entered a here document and we're generating a file | |
1252 | # that is exported by the unit, then we need to monitor the variables | |
1253 | # used to make sure there's no missing dependency. | |
1254 | $heredoc_nosubst = 0 | |
1255 | if $began_here && />>?\s*(\S+)/ && $filemaster{$1} eq $unit; | |
1256 | ||
1257 | # From now on, do all substitutes with ':' since it would be dangerous | |
1258 | # to remove things plain and simple. It could yields false matches | |
1259 | # afterwards... | |
1260 | ||
1261 | my $check_vars = 1; | |
1262 | $chek_vars = 0 if $heredoc_nosubst && !$began_here; | |
1263 | ||
1264 | # Record any attempt made to set a shell variable | |
1265 | local($sym); | |
1266 | while ($check_vars && s/(\W?)(\w+)=/$1:/) { | |
1267 | my $before = $1; | |
1268 | $sym = $2; | |
1269 | next unless $before eq '' || $before =~ /["'` \t]/; | |
1270 | next if $sym =~ /^\d+/; # Ignore $1 and friends | |
1271 | $symset{$sym}++; # Shell variable set | |
1272 | # Not part of a $cc -DWHATEVER line and not made nor temporary | |
1273 | unless ($sym =~ /^D/ || &defined($sym)) { | |
1274 | if (&wanted($sym)) { | |
1275 | warn "$where: variable '\$$sym' is changed.\n" | |
1276 | unless $lintchange{$sym}; | |
1277 | $lintchange_used{$sym}++ if $lintchange{$sym}; | |
1278 | } else { | |
1279 | # Record that the variable is set but not listed locally. | |
1280 | if ($shset{$unit} !~ /\b$sym\b/) { | |
1281 | $shset{$unit} .= "$sym " unless $lintchange{$sym}; | |
1282 | $lintchange_used{$sym}++ if $lintchange{$sym}; | |
1283 | } | |
1284 | } | |
1285 | } | |
1286 | } | |
1287 | # Now look at the shell variables used: can be $var or ${var} or ${var: | |
1288 | local($var); | |
1289 | local($line) = $_; | |
1290 | while ($check_vars && s/\$\{?(\w+)[\}:]?/$1/) { | |
1291 | $var = $1; | |
1292 | next if $var =~ /^\d+/; # Ignore $1 and friends | |
1293 | # Record variable as undeclared but do not issue a message right now. | |
1294 | # That variable could be exported via ?V: (as $dflt in Myread) or be | |
1295 | # defined by a special unit (like $inlibc by unit Inlibc). | |
1296 | $shunknown{$unit} .= "$var " unless | |
1297 | $lintextern{$var} || &declared($var) || | |
1298 | $shunknown{$unit} =~ /\b$var\b/; | |
1299 | $shused{$unit} .= "\$$var " unless $shused{$unit} =~ /\$$var\b/; | |
1300 | } | |
1301 | ||
1302 | local($file); | |
1303 | ||
1304 | if ($heredoc ne '' && !$began_here) { | |
1305 | # Still in here-document | |
1306 | # Just look for included files from C programs expected to be local | |
1307 | # in case they missed the special unit that produces these files. | |
1308 | if (s!#(\s*)include(\s+)"([\w.]+)"!!) { | |
1309 | $file = $3; | |
1310 | $fileused{$unit} .= "$file " unless | |
1311 | $filetmp{$file} || $fileused{$unit} =~ /\b$file\b/; | |
1312 | } | |
1313 | return; | |
1314 | } | |
1315 | ||
1316 | # Now look at private files used by the unit (./file or ..../UU/file) | |
1317 | # We look at things like '. ./myread' and `./loc ...` as well as "< file" | |
1318 | $_ = $line; | |
1319 | s/<\S+?>//g; # <header.h> would set-off our <file detection | |
1320 | while ( | |
1321 | s!#(\s*)include(\s+)"([\w.]+)"!! || | |
1322 | s!(\.\s+|`\s*)(\S*UU|\.)/([^\$/`\s;]+)\s*!! || | |
1323 | s!(`\s*\$?)cat\s+(\./)?([^\$/`\s;]+)\s*`!! || | |
1324 | s!(\s+)(\./)([^\$/`\s;]+)\s*!! || | |
1325 | s!(\s+)<\s*(\./)?([^<\$/`'"\s;]+)!! | |
1326 | ) { | |
1327 | $file = $3; | |
1328 | # Found some ". ./file" or `./file` execution, `$cat file`, or even | |
1329 | # "blah <file"... | |
1330 | # Record file as used. Later on, we will make sure we had the right | |
1331 | # to use that file: either we are in the unit that defines it, or we | |
1332 | # include the unit that creates it in our dependencies, relying on ?F:. | |
1333 | if ($file =~ /^\w/) { | |
1334 | $fileused{$unit} .= "$file " unless | |
1335 | $filetmp{$file} || $fileused{$unit} =~ /\b$file\b/; | |
1336 | } | |
1337 | # Mark temporary file as being used, to spot useless local declarations | |
1338 | $filetmp{$file} .= ' used' | |
1339 | if defined $filetmp{$file} && $filetmp{$file} !~ /\bused/; | |
1340 | } | |
1341 | # Try to detect things like . myread or `loc` to warn that they | |
1342 | # should rather use . ./myread and `./loc`. Also things like 'if prog', | |
1343 | # or usage in conditional expressions such as || and &&. Be sure the file | |
1344 | # name is always in $2... | |
1345 | while ( | |
1346 | s!(\.\s+|`\s*)([^\$/`\s;]+)\s*!: ! || # . myread or `loc` | |
1347 | s!(if|\|\||&&)\s+([^\$/`\s;]+)\s*!: ! # if prog, || prog, && prog | |
1348 | ) { | |
1349 | $file = $2; | |
1350 | if ($file =~ /^\w/) { | |
1351 | $filemisused{$unit} .= "$file " unless | |
1352 | $filetmp{$file} || $filemisused{$unit} =~ /\b$file\b/; | |
1353 | } | |
1354 | # Temporary files should be used with ./ anyway | |
1355 | $filetmp{$file} .= ' misused' | |
1356 | if defined $filetmp{$file} && $filetmp{$file} !~ /\bmisused/; | |
1357 | } | |
1358 | # Locate file creation, >>file or >file | |
1359 | while (s!>>?\s*([^\$/`\s;]+)\s*!: !) { | |
1360 | $file = $1; | |
1361 | next if $file =~ /&\d+/; # skip >&4 and friends | |
1362 | $filecreated{$file}++; | |
1363 | } | |
1364 | # Look for mentions of known temporary files to avoid complaining | |
1365 | # that they were not used. | |
1366 | while (s!\s+(\S+)!!) { | |
1367 | $file = $1; | |
1368 | $filetmp{$file} .= ' used' | |
1369 | if defined $filetmp{$file} && $filetmp{$file} !~ /\bused/; | |
1370 | } | |
1371 | } | |
1372 | ||
1373 | # Called at the end of each unit | |
1374 | sub main'load_p_end { | |
1375 | package main; | |
1376 | local($last) = @_; # Last processed line | |
1377 | local($where) = "\"$file\""; | |
1378 | ||
1379 | # The ?H: section, if present, must have been closed | |
1380 | if ($h_section && $h_section != 2) { | |
1381 | warn "$where: unclosed ?H: section.\n"; | |
1382 | } | |
1383 | $h_section = 0; # For next unit, which may be empty | |
1384 | ||
1385 | # All opened here-documents must be closed. | |
1386 | if ($heredoc ne '') { | |
1387 | my $q = $heredoc_nosubst ? "'" : ""; | |
1388 | warn "$where: unclosed here-document $q$heredoc$q " . | |
1389 | "started line $heredoc_line.\n" | |
1390 | unless $linthere{$heredoc}; | |
1391 | } | |
1392 | ||
1393 | # Reinitialize for next unit. | |
1394 | $heredoc = ''; | |
1395 | $heredoc_nosubst = 0; | |
1396 | $past_first_line = 0; | |
1397 | $last_interpreted = 0; | |
1398 | ||
1399 | unless ($makeseen{$unit}) { | |
1400 | warn "$where: no ?MAKE: line describing dependencies.\n" | |
1401 | unless $lintempty{$unit}; | |
1402 | return; | |
1403 | } | |
1404 | ||
1405 | # Each unit should end with a blank line. Unfortunately, some units | |
1406 | # may also end with an '@end' request and have the blank line above it. | |
1407 | # Currently, we do not have enough information to correctly diagnose | |
1408 | # whether it is valid or not so just skip it. | |
1409 | # Same thing for U/Obsol_sh.U which ends with a shell comment. | |
1410 | ||
1411 | warn "$where: not ending with a blank line.\n" unless | |
1412 | $last =~ /^\s*$/ || $last =~ /^\@end/ || $last =~ /^#|\?/; | |
1413 | ||
1414 | # For EMACS users. It would be fatal to the Configure script... | |
1415 | warn "$where: last line not ending with a new-line character.\n" | |
1416 | unless $last =~ /\n$/; | |
1417 | ||
1418 | # Make sure every shell symbol described in ?MAKE had a description | |
1419 | foreach $sym (sort keys %defseen) { | |
1420 | unless ($ssym{$sym}) { | |
1421 | warn "$where: symbol '\$$sym' was not described.\n" | |
1422 | unless $lintsdesc{$sym}; | |
1423 | $lintsdesc_used{$sym}++ if $lintsdesc{$sym}; | |
1424 | } | |
1425 | } | |
1426 | # Ensure all the C symbols defined by ?H: lines have a description | |
1427 | foreach $sym (sort keys %hcsym) { | |
1428 | unless ($csym{$sym}) { | |
1429 | warn "$where: C symbol '$sym' was not described.\n" | |
1430 | unless $lintcdesc{$sym}; | |
1431 | $lintcdesc_used{$sym}++ if $lintcdesc{$sym}; | |
1432 | } | |
1433 | } | |
1434 | # Ensure all the C symbols described by ?C: lines are defined in ?H: | |
1435 | foreach $sym (sort keys %csym) { | |
1436 | warn "$where: C symbol '$sym' was not defined by any ?H: line.\n" | |
1437 | unless $hcsym{$sym}; | |
1438 | } | |
1439 | # Make sure each defined symbol was set, unless it starts with an | |
1440 | # upper-case letter in which case it is not a "true" shell symbol. | |
1441 | # I don't care about the special symbols defined in %Except as I know | |
1442 | # they are handled correctly. | |
1443 | foreach $sym (sort keys %defseen) { | |
1444 | unless ($symset{$sym} || substr($sym, 0, 1) =~ /^[A-Z]/) { | |
1445 | warn "$where: variable '\$$sym' should have been set.\n" | |
1446 | unless $lintset{$sym}; | |
1447 | $lintset_used{$sym}++ if $lintset{$sym}; | |
1448 | } | |
1449 | } | |
1450 | # Make sure every non-special unit declared as wanted is indeed needed | |
1451 | foreach $sym (sort keys %depseen) { | |
1452 | if ($shused{$unit} !~ /\$$sym\b/ && substr($sym, 0, 1) !~ /^[A-Z]/) { | |
1453 | warn "$where: unused dependency variable '\$$sym'.\n" unless | |
1454 | $lintchange{$sym} || $lintuse{$sym}; | |
1455 | $lintchange_used{$sym}++ if $lintchange{$sym}; | |
1456 | $lintuse_used{$sym}++ if $lintuse{$sym}; | |
1457 | } | |
1458 | } | |
1459 | # Idem for conditionally wanted symbols | |
1460 | foreach $sym (sort keys %condseen) { | |
1461 | if ($shused{$unit} !~ /\$$sym\b/ && substr($sym, 0, 1) !~ /^[A-Z]/) { | |
1462 | warn "$where: unused conditional variable '\$$sym'.\n" unless | |
1463 | $lintchange{$sym} || $lintuse{$sym}; | |
1464 | $lintchange_used{$sym}++ if $lintchange{$sym}; | |
1465 | $lintuse_used{$sym}++ if $lintuse{$sym}; | |
1466 | } | |
1467 | } | |
1468 | # Idem for temporary symbols | |
1469 | foreach $sym (sort keys %tempseen) { | |
1470 | if ($shused{$unit} !~ /\$$sym\b/ && !$symset{$sym}) { | |
1471 | warn "$where: unused temporary variable '\$$sym'.\n" unless | |
1472 | $lintuse{$sym}; | |
1473 | $lintuse_used{$sym}++ if $lintuse{$sym}; | |
1474 | } | |
1475 | } | |
1476 | # Idem for local files | |
1477 | foreach $file (sort keys %filetmp) { | |
1478 | warn "$where: mis-used temporary file '$file'.\n" if | |
1479 | $filetmp{$file} =~ /\bmisused/; | |
1480 | warn "$where: unused temporary file '$file'.\n" unless | |
1481 | $lintfused{$file} || | |
1482 | $filetmp{$file} =~ /\bused/ || $filetmp{$file} =~ /\bmisused/; | |
1483 | } | |
1484 | # Make sure each private file listed as created on ?F: is really created. | |
1485 | # When found, a private UU file is entered in the %filecreated array | |
1486 | # with value 'a'. Each time a file creation occurs in the unit, an | |
1487 | # increment is done on that value. Since 'a'++ -> 'b', a numeric value | |
1488 | # in %filecreated means a non-local file, which is skipped. An 'a' means | |
1489 | # the file was not created... | |
1490 | local($value); | |
1491 | foreach $file (sort keys %filecreated) { | |
1492 | $value = $filecreated{$file}; | |
1493 | next if $value > 0; # Skip non UU-files. | |
1494 | warn "$where: file '$file' was not created.\n" if $value eq 'a'; | |
1495 | } | |
1496 | # Check whether some of the LINT directives were useful | |
1497 | foreach my $sym (sort keys %lintcreated) { | |
1498 | warn "$where: spurious 'LINT create $sym' directive.\n"; | |
1499 | } | |
1500 | foreach my $sym (sort keys %lintuse) { | |
1501 | warn "$where: spurious 'LINT use $sym' directive.\n" | |
1502 | unless $lintuse_used{$sym}; | |
1503 | } | |
1504 | foreach my $sym (sort keys %lintchange) { | |
1505 | warn "$where: spurious 'LINT change $sym' directive.\n" | |
1506 | unless $lintchange_used{$sym}; | |
1507 | } | |
1508 | foreach my $sym (sort keys %lintseen) { | |
1509 | warn "$where: spurious 'LINT define $sym' directive.\n" | |
1510 | unless $lintseen_used{$sym}; | |
1511 | } | |
1512 | foreach my $sym (sort keys %lintsdesc) { | |
1513 | warn "$where: spurious 'LINT describe $sym' directive.\n" | |
1514 | unless $lintsdesc_used{$sym}; | |
1515 | } | |
1516 | foreach my $sym (sort keys %lintcdesc) { | |
1517 | warn "$where: spurious 'LINT known $sym' directive.\n" | |
1518 | unless $lintcdesc_used{$sym}; | |
1519 | } | |
1520 | foreach my $sym (sort keys %lintset) { | |
1521 | warn "$where: spurious 'LINT set $sym' directive.\n" | |
1522 | unless $lintset_used{$sym}; | |
1523 | } | |
1524 | } | |
1525 | ||
1526 | # An unknown control line sequence was found (held in $proc) | |
1527 | sub main'load_p_unknown { | |
1528 | package main; | |
1529 | warn "\"$file\", line $.: unknown control sequence '?$proc:'.\n"; | |
1530 | } | |
1531 | ||
1532 | # Run sanity checks, to make sure every conditional symbol has a suitable | |
1533 | # default value. Also ensure every symbol was defined once. | |
1534 | sub main'load_sanity_checks { | |
1535 | package main; | |
1536 | print "Sanity checks...\n"; | |
1537 | local($key, $value); | |
1538 | local($w); | |
1539 | local(%message); # Record messages on a per-unit basis | |
1540 | local(%said); # Avoid duplicate messages | |
1541 | # Warn about symbols ever used in conditional dependency with no default | |
1542 | while (($key, $value) = each(%condsym)) { | |
1543 | unless ($hasdefault{$key}) { | |
1544 | $w = (split(' ', $shmaster{"\$$key"}))[0]; | |
1545 | $message{$w} .= "#$key "; | |
1546 | } | |
1547 | } | |
1548 | # Warn about any undeclared variables. They are all listed in %shunknown, | |
1549 | # being the values while the unit where they appear is the key. If the | |
1550 | # symbol is defined by any of the special units included or made visible, | |
1551 | # then no warning is issued. | |
1552 | local($defined); # True if symbol is defined in one unit | |
1553 | local($where); # List of units where symbol is defined | |
1554 | local($myself); # The name of the current unit if itself special | |
1555 | local($visible); # Symbol made visible via a ?V: line | |
1556 | foreach $unit (sort keys %shunknown) { | |
1557 | foreach $sym (split(' ', $shunknown{$unit})) { | |
1558 | $defined = 0; | |
1559 | $where = $shmaster{"\$$sym"}; | |
1560 | $defined = 1 if $tempmaster{"\$$sym"} =~ /$unit\b/; | |
1561 | $myself = substr($unit, 0, 1) =~ /^[A-Z]/ ? $unit : ''; | |
1562 | # Symbol has to be either defined within one of the special units | |
1563 | # listed in the dependencies or exported via a ?V: line. | |
1564 | unless ($defined) { | |
1565 | $defined = &visible($sym, $unit); | |
1566 | $spneeded{$unit}++ if $defined; | |
1567 | } | |
1568 | $message{$unit} .= "\$$sym " unless $defined; | |
1569 | } | |
1570 | } | |
1571 | ||
1572 | # Warn about any undeclared files. Files used in one unit are all within | |
1573 | # the %fileused table, indexed by unit. If a file is used, it must either | |
1574 | # be in the unit that declared it (relying on %filemaster for that) or | |
1575 | # the unit listed in %filemaster must be part of our dependency. | |
1576 | %said = (); | |
1577 | foreach $unit (sort keys %fileused) { | |
1578 | foreach $file (split(' ', $fileused{$unit})) { | |
1579 | $defined = 0; | |
1580 | $where = $filemaster{$file}; # Where file is created | |
1581 | $defined = 1 if $unit eq $where; # We're in the unit defining it | |
1582 | # Private UU files may be only be created by special units | |
1583 | foreach $special (split(' ', $shspecial{$unit})) { | |
1584 | last if $defined; | |
1585 | $defined = 1 if $where eq $special; | |
1586 | } | |
1587 | # Exceptions to above rule possible via a ?LINT:create hint, | |
1588 | # so parse all known dependencies for the unit... | |
1589 | foreach $depend (split(' ', $shdepend{$unit})) { | |
1590 | last if $defined; | |
1591 | $defined = 1 if $where eq $depend; | |
1592 | } | |
1593 | $message{$unit} .= "\@$file " unless | |
1594 | $defined || $said{"$unit/$file"}++; # Unknown file | |
1595 | } | |
1596 | } | |
1597 | undef %fileused; | |
1598 | ||
1599 | # Warn about any misused files, kept in %filemisused | |
1600 | foreach $unit (sort keys %filemisused) { | |
1601 | foreach $file (split(' ', $filemisused{$unit})) { | |
1602 | next unless defined $filemaster{$file}; # Skip non UU-files | |
1603 | $message{$unit} .= "\@\@$file "; # Misused file | |
1604 | } | |
1605 | } | |
1606 | undef %filemisused; | |
1607 | ||
1608 | # Warn about temporary files which could be created and inadvertently | |
1609 | # override a private UU file (listed in %filemaster). | |
1610 | foreach $tmpfile (keys %filesetin) { | |
1611 | next unless defined $filemaster{$tmpfile}; | |
1612 | $where = $filemaster{$tmpfile}; | |
1613 | foreach $unit (split(' ', $filesetin{$tmpfile})) { | |
1614 | $message{$unit} .= "\@\@\@$where:$tmpfile "; | |
1615 | } | |
1616 | } | |
1617 | undef %filesetin; | |
1618 | ||
1619 | # Warn about any set variable which was not listed. | |
1620 | foreach $unit (sort keys %shset) { | |
1621 | symbol: foreach $sym (split(' ', $shset{$unit})) { | |
1622 | next if $shvisible{$sym}; | |
1623 | $defined = 0; | |
1624 | # Symbol has to be either defined within one of the special units | |
1625 | # listed in the dependencies or exported read-write via a ?V: line. | |
1626 | # If symbol is exported read-only, report the attempt to set it. | |
1627 | $where = $shmaster{"\$$sym"}; | |
1628 | study $where; | |
1629 | foreach $special (split(' ', $shspecial{$unit})) { | |
1630 | $defined = 1 if $where =~ /\b$special\b/; | |
1631 | last if $defined; | |
1632 | } | |
1633 | $visible = 0; | |
1634 | $defined = $visible = &visible($sym, $unit) unless $defined; | |
1635 | if ($visible && $shvisible{"\$$sym"} ne '') { | |
1636 | # We are allowed to set a read-only symbol in the unit which | |
1637 | # declared it... | |
1638 | next symbol if $shvisible{"\$$sym"} eq $unit; | |
1639 | $message{$unit} .= "\&$sym "; # Read-only symbol set | |
1640 | next symbol; | |
1641 | } | |
1642 | $message{$unit} .= "$sym " unless $defined; | |
1643 | } | |
1644 | } | |
1645 | # Warn about any obsolete variable which may be used | |
1646 | foreach $unit (sort keys %shused) { | |
1647 | foreach $sym (split(' ', $shused{$unit})) { | |
1648 | $message{$unit} .= "!$sym " if $Obsolete{$sym} ne ''; | |
1649 | } | |
1650 | } | |
1651 | ||
1652 | # Warn about stale dependencies, and prepare successor and predecessor | |
1653 | # tables for later topological sort. | |
1654 | ||
1655 | local($targets, $deps); | |
1656 | local(%Succ); # Successors | |
1657 | local(%Prec); # Predecessors | |
1658 | ||
1659 | # Split dependencies and build successors array. | |
1660 | foreach $make (@make) { | |
1661 | ($targets, $deps) = $make =~ m|(.*):\s*(.*)|; | |
1662 | $deps =~ s/\+(\w)/$1/g; # Remove conditional targets | |
1663 | foreach $target (split(' ', $targets)) { | |
1664 | $Succ{$target} .= $deps . ' '; | |
1665 | } | |
1666 | } | |
1667 | ||
1668 | # Special setup for the End target, which normally has a $W dependency for | |
1669 | # wanted symbols. In order to detect all the possible cycles, we forge a | |
1670 | # huge dependency by making ALL the regular symbols (i.e. those whose first | |
1671 | # letter is not uppercased) wanted. | |
1672 | ||
1673 | local($allwant) = ''; | |
1674 | { | |
1675 | local($sym, $val); | |
1676 | while (($sym, $val) = each %shmaster) { | |
1677 | $sym =~ s/^\$//; | |
1678 | $allwant .= "$sym " if $val ne ''; | |
1679 | } | |
1680 | } | |
1681 | ||
1682 | $Succ{'End'} =~ s/\$W/$allwant/; | |
1683 | ||
1684 | # Initialize precursors, and spot symbols impossible to 'make', i.e. those | |
1685 | # symbols listed in the successors and with no 'make' target. The data | |
1686 | # structures %Prec and %Succ will also be used by the cycle lookup code, | |
1687 | # in other words, the topological sort. | |
1688 | foreach $target (keys %Succ) { | |
1689 | $Prec{$target} += 0; # Ensure key is recorded without disturbing. | |
1690 | foreach $succ (split(' ', $Succ{$target})) { | |
1691 | $Prec{$succ}++; # Successor has one more precursor | |
1692 | unless (defined $Succ{$succ} || $said{$succ}++) { | |
1693 | foreach $unit (split(' ', $symdep{$succ})) { | |
1694 | $message{$unit} .= "?$succ "; # Stale ?MAKE: dependency | |
1695 | } | |
1696 | } | |
1697 | } | |
1698 | } | |
1699 | undef %symdep; | |
1700 | ||
1701 | # Check all ?M: dependencies to spot stale ones | |
1702 | %said = (); | |
1703 | while (($key, $value) = each(%msym)) { | |
1704 | next if $value eq ''; # Value is unit name where ?M: occurred | |
1705 | foreach $sym (split(' ', $mdep{$key})) { # Loop on C dependencies | |
1706 | next if $cmaster{$sym} || $said{$sym}; | |
1707 | $message{$value} .= "??$sym "; # Stale ?M: dependency | |
1708 | $said{$sym}++; | |
1709 | } | |
1710 | } | |
1711 | ||
1712 | undef %said; | |
1713 | undef %mdep; | |
1714 | undef %msym; | |
1715 | ||
1716 | # Now actually emit all the warnings | |
1717 | local($uv); # Unit defining visible symbol or private file | |
1718 | local($w); # Were we are signaling an error | |
1719 | foreach $unit (sort keys %message) { | |
1720 | undef %said; | |
1721 | $w = "\"$unit.U\""; | |
1722 | foreach (split(' ', $message{$unit})) { | |
1723 | if (s/^#//) { | |
1724 | warn "$w: symbol '\$$_' has no default value.\n"; | |
1725 | } elsif (s/^\?\?//) { | |
1726 | warn "$w: stale ?M: dependency '$_'.\n"; | |
1727 | } elsif (s/^\?//) { | |
1728 | warn "$w: stale ?MAKE: dependency '$_'.\n"; | |
1729 | } elsif (s/^\$//) { | |
1730 | if ($shmaster{"\$$_"} ne '') { | |
1731 | warn "$w: symbol '\$$_' missing from ?MAKE.\n"; | |
1732 | } elsif (($uv = $shvisible{$_}) ne '') { | |
1733 | warn "$w: missing $uv from ?MAKE for visible '\$$_'.\n"; | |
1734 | } elsif (($uv = $shvisible{"\$$_"}) ne '') { | |
1735 | warn "$w: missing $uv from ?MAKE for visible '\$$_'.\n"; | |
1736 | } else { | |
1737 | warn "\"$unit.U\": unknown symbol '\$$_'.\n"; | |
1738 | } | |
1739 | ++$said{$_}; | |
1740 | } elsif (s/^\&//) { | |
1741 | warn "\"$unit.U\": read-only symbol '\$$_' is set.\n"; | |
1742 | ++$said{$_}; | |
1743 | } elsif (s/^!//) { | |
1744 | warn "\"$unit.U\": obsolete symbol '$_' is used.\n"; | |
1745 | ++$said{$_}; | |
1746 | } elsif (s/^\@\@\@//) { | |
1747 | $uv = '?'; # To spot format errors | |
1748 | s/^(\w+):// && ($uv = $1); | |
1749 | warn "$w: local file '$_' may override the one set by $uv.U.\n"; | |
1750 | } elsif (s/^\@\@//) { | |
1751 | $uv = $filemaster{$_}; | |
1752 | warn "$w: you might not always get file '$_' from $uv.U.\n"; | |
1753 | } elsif (s/^\@//) { | |
1754 | if ($uv = $filemaster{$_}) { | |
1755 | warn "$w: missing $uv from ?MAKE for private file '$_'.\n"; | |
1756 | } else { | |
1757 | warn "$w: unknown private file '$_'.\n"; | |
1758 | } | |
1759 | ++$said{"\@$_"}; | |
1760 | } else { | |
1761 | warn "\"$unit.U\": undeclared symbol '\$$_' is set.\n" | |
1762 | unless $said{$_}; | |
1763 | } | |
1764 | } | |
1765 | } | |
1766 | ||
1767 | # Memory cleanup | |
1768 | undef %message; | |
1769 | undef %said; | |
1770 | undef %shused; | |
1771 | undef %shset; | |
1772 | undef %shspecial; | |
1773 | undef %shvisible; | |
1774 | undef %filemaster; | |
1775 | ||
1776 | # Spot multiply defined C symbols | |
1777 | foreach $sym (keys %cmaster) { | |
1778 | @sym = split(' ', $cmaster{$sym}); | |
1779 | if (@sym > 1) { | |
1780 | warn "C symbol '$sym' is defined in the following units:\n"; | |
1781 | foreach (@sym) { | |
1782 | print STDERR "\t$_.U\n"; | |
1783 | } | |
1784 | } | |
1785 | } | |
1786 | undef %cmaster; # Memory cleanup | |
1787 | ||
1788 | # Warn about multiply defined symbols. There are three kind of symbols: | |
1789 | # target symbols, obsolete symbols and temporary symbols. | |
1790 | # For each of these sets, we make sure the intersection with the other sets | |
1791 | # is empty. Besides, we make sure target symbols are only defined once. | |
1792 | ||
1793 | local(@sym); | |
1794 | foreach $sym (keys %shmaster) { | |
1795 | @sym = split(' ', $shmaster{$sym}); | |
1796 | if (@sym > 1) { | |
1797 | warn "Shell symbol '$sym' is defined in the following units:\n"; | |
1798 | foreach (@sym) { | |
1799 | print STDERR "\t$_.U\n"; | |
1800 | } | |
1801 | } | |
1802 | $message{$sym} .= 'so ' if $Obsolete{$sym}; | |
1803 | $message{$sym} .= 'st ' if $tempmaster{$sym}; | |
1804 | } | |
1805 | foreach $sym (keys %tempmaster) { | |
1806 | $message{$sym} .= 'ot ' if $Obsolete{$sym}; | |
1807 | } | |
1808 | local($_); | |
1809 | while (($sym, $_) = each %message) { | |
1810 | if (/so/) { | |
1811 | if (/ot/) { | |
1812 | warn "Shell symbol '$sym' is altogether:\n"; | |
1813 | @sym = split(' ', $shmaster{$sym}); | |
1814 | @sym = grep(s/$/.U/, @sym); | |
1815 | print STDERR "...defined in: ", join(', ', @sym), "\n"; | |
1816 | print STDERR "...obsoleted by $Obsolete{$sym}.\n"; | |
1817 | @sym = split(' ', $tempmaster{$sym}); | |
1818 | @sym = grep(s/$/.U/, @sym); | |
1819 | print STDERR "...used as temporary in:", join(', ', @sym), "\n"; | |
1820 | } else { | |
1821 | warn "Shell symbol '$sym' is both defined and obsoleted:\n"; | |
1822 | @sym = split(' ', $shmaster{$sym}); | |
1823 | @sym = grep(s/$/.U/, @sym); | |
1824 | print STDERR "...defined in: ", join(', ', @sym), "\n"; | |
1825 | print STDERR "...obsoleted by $Obsolete{$sym}.\n"; | |
1826 | } | |
1827 | } elsif (/st/) { # Cannot be ot as it would imply so | |
1828 | warn "Shell symbol '$sym' is both defined and used as temporary:\n"; | |
1829 | @sym = split(' ', $shmaster{$sym}); | |
1830 | @sym = grep(s/$/.U/, @sym); | |
1831 | print STDERR "...defined in: ", join(', ', @sym), "\n"; | |
1832 | @sym = split(' ', $tempmaster{$sym}); | |
1833 | @sym = grep(s/$/.U/, @sym); | |
1834 | print STDERR "...used as temporary in:", join(', ', @sym), "\n"; | |
1835 | } elsif (/ot/) { | |
1836 | warn "Shell symbol '$sym' obsoleted also used as temporary:\n"; | |
1837 | print STDERR "...obsoleted by $Obsolete{$sym}.\n"; | |
1838 | @sym = split(' ', $tempmaster{$sym}); | |
1839 | @sym = grep(s/$/.U/, @sym); | |
1840 | print STDERR "...used as temporary in:", join(', ', @sym), "\n"; | |
1841 | } | |
1842 | } | |
1843 | ||
1844 | # Spot multiply defined files, either private or public ones | |
1845 | foreach $file (keys %prodfile) { | |
1846 | @sym = split(' ', $prodfile{$file}); | |
1847 | if (@sym > 1) { | |
1848 | warn "File '$file' is defined in the following units:\n"; | |
1849 | foreach (@sym) { | |
1850 | print STDERR "\t$_\n"; | |
1851 | } | |
1852 | } | |
1853 | } | |
1854 | undef %prodfile; | |
1855 | ||
1856 | ||
1857 | # Memory cleanup (we still need %shmaster for tsort) | |
1858 | undef %message; | |
1859 | undef %tempmaster; | |
1860 | undef %Obsolete; | |
1861 | ||
1862 | # Make sure there is no dependency cycle | |
1863 | print "Looking for dependency cycles...\n"; | |
1864 | &tsort(*Succ, *Prec); # Destroys info from %Prec | |
1865 | } | |
1866 | ||
1867 | # Make sure last declaration ended correctly with a ?S:. or ?C:. line. | |
1868 | # The variable '$where' was correctly positionned by the calling routine. | |
1869 | sub main'load_check_last_declaration { | |
1870 | package main; | |
1871 | warn "$where: definition of '\$$s_symbol' not closed by '?S:.'.\n" | |
1872 | if $s_symbol ne ''; | |
1873 | warn "$where: definition of '$c_symbol' not closed by '?C:.'.\n" | |
1874 | if $c_symbol ne ''; | |
1875 | warn "$where: magic definition of '$m_symbol' not closed by '?M:.'.\n" | |
1876 | if $m_symbol ne ''; | |
1877 | $s_symbol = $c_symbol = $m_symbol = ''; | |
1878 | } | |
1879 | ||
1880 | # Make sure the variable is mentionned on the ?MAKE line, if possible in the | |
1881 | # definition section. | |
1882 | # The variable '$where' was correctly positionned by the calling routine. | |
1883 | sub main'load_check_definition { | |
1884 | package main; | |
1885 | local($var) = @_; | |
1886 | warn "$where: variable '\$$var' not even listed on ?MAKE: line.\n" | |
1887 | unless $defseen{$var} || $condseen{$var} || $depseen{$var}; | |
1888 | warn "$where: variable '\$$var' is defined externally.\n" | |
1889 | if !$lintextern{$var} && !$defseen{$var} && &wanted($var); | |
1890 | } | |
1891 | ||
1892 | # Is symbol declared somewhere? | |
1893 | sub main'load_declared { | |
1894 | package main; | |
1895 | &defined($_[0]) || &wanted($_[0]); | |
1896 | } | |
1897 | ||
1898 | # Is symbol defined by unit? | |
1899 | sub main'load_defined { | |
1900 | package main; | |
1901 | $tempseen{$_[0]} || $defseen{$_[0]} || $lintseen{$_[0]}; | |
1902 | } | |
1903 | ||
1904 | # Is symbol wanted by unit? | |
1905 | sub main'load_wanted { | |
1906 | package main; | |
1907 | $depseen{$_[0]} || $condseen{$_[0]}; | |
1908 | } | |
1909 | ||
1910 | # Is symbol visible from the unit? | |
1911 | # Locate visible symbols throughout the special units. Each unit having | |
1912 | # some special dependencies (special units wanted) have an entry in the | |
1913 | # %shspecial array, listing all those special dependencies. And each | |
1914 | # symbol made visible by ONE special unit has an entry in the %shvisible | |
1915 | # array. | |
1916 | sub main'load_visible { | |
1917 | package main; | |
1918 | local($symbol, $unit) = @_; | |
1919 | local(%explored); # Special units we've already explored | |
1920 | &explore($symbol, $unit); # Perform recursive search | |
1921 | } | |
1922 | ||
1923 | # Recursively explore the dependencies to locate a visible symbol | |
1924 | sub main'load_explore { | |
1925 | package main; | |
1926 | local($symbol, $unit) = @_; | |
1927 | # If unit was already explored, we know it has not been found by following | |
1928 | # that path. | |
1929 | return 0 if defined $explored{$unit}; | |
1930 | $explored{$unit} = 0; # Assume nothing found in this unit | |
1931 | local($specials) = $shspecial{$unit}; | |
1932 | # Don't waste any time if unit does not have any special units listed | |
1933 | # in its dependencies. | |
1934 | return 0 unless $specials; | |
1935 | foreach $special (split(' ', $specials)) { | |
1936 | return 1 if ( | |
1937 | $shvisible{"\$$symbol"} eq $unit || | |
1938 | $shvisible{$symbol} eq $unit || | |
1939 | &explore($symbol, $special) | |
1940 | ); | |
1941 | } | |
1942 | 0; | |
1943 | } | |
1944 | ||
1945 | # The %Depend array records the functions we use to process the configuration | |
1946 | # lines in the unit, with a special meaning. It is important that all the | |
1947 | # known control symbols be listed below, so that metalint does not complain. | |
1948 | # The %Lcmp array contains valid layouts and their comparaison value. | |
1949 | sub main'load_init_depend { | |
1950 | package main; | |
1951 | %Depend = ( | |
1952 | 'MAKE', 'p_make', # The ?MAKE: line records dependencies | |
1953 | 'INIT', 'p_init', # Initializations printed verbatim | |
1954 | 'LINT', 'p_lint', # Hints for metalint | |
1955 | 'RCS', 'p_ignore', # RCS comments are ignored | |
1956 | 'C', 'p_c', # C symbols | |
1957 | 'D', 'p_default', # Default value for conditional symbols | |
1958 | 'E', 'p_example', # Example of usage | |
1959 | 'F', 'p_file', # Produced files | |
1960 | 'H', 'p_config', # Process the config.h lines | |
1961 | 'I', 'p_include', # Added includes | |
1962 | 'L', 'p_library', # Added libraries | |
1963 | 'M', 'p_magic', # Process the confmagic.h lines | |
1964 | 'O', 'p_obsolete', # Unit obsolescence | |
1965 | 'P', 'p_public', # Location of PD implementation file | |
1966 | 'S', 'p_shell', # Shell variables | |
1967 | 'T', 'p_temp', # Shell temporaries used | |
1968 | 'V', 'p_visible', # Visible symbols like 'rp', 'dflt' | |
1969 | 'W', 'p_wanted', # Wanted value for interpreter | |
1970 | 'X', 'p_ignore', # User comment is ignored | |
1971 | 'Y', 'p_layout', # User-defined layout preference | |
1972 | ); | |
1973 | %Lcmp = ( | |
1974 | 'top', -1, | |
1975 | 'default', 0, | |
1976 | 'bottom', 1, | |
1977 | ); | |
1978 | } | |
1979 | ||
1980 | # Extract dependencies from units held in @ARGV | |
1981 | sub main'load_extract_dependencies { | |
1982 | package main; | |
1983 | local($proc); # Procedure used to handle a ctrl line | |
1984 | local($file); # Current file scanned | |
1985 | local($dir, $unit); # Directory and unit's name | |
1986 | local($old_version) = 0; # True when old-version unit detected | |
1987 | local($mc) = "$MC/U"; # Public metaconfig directory | |
1988 | local($line); # Last processed line for metalint | |
1989 | ||
1990 | printf "Extracting dependency lists from %d units...\n", $#ARGV+1 | |
1991 | unless $opt_s; | |
1992 | ||
1993 | chdir $WD; # Back to working directory | |
1994 | &init_extraction; # Initialize extraction files | |
1995 | $dependencies = ' ' x (50 * @ARGV); # Pre-extend | |
1996 | $dependencies = ''; | |
1997 | ||
1998 | # We do not want to use the <> construct here, because we need the | |
1999 | # name of the opened files (to get the unit's name) and we want to | |
2000 | # reset the line number for each files, and do some pre-processing. | |
2001 | ||
2002 | file: while ($file = shift(@ARGV)) { | |
2003 | close FILE; # Reset line number | |
2004 | $old_version = 0; # True if unit is an old version | |
2005 | if (open(FILE, $file)) { | |
2006 | ($dir, $unit) = ('', $file) | |
2007 | unless ($dir, $unit) = ($file =~ m|(.*)/(.*)|); | |
2008 | $unit =~ s|\.U$||; # Remove extension | |
2009 | } else { | |
2010 | warn("Can't open $file.\n"); | |
2011 | } | |
2012 | # If unit is in the standard public directory, keep only the unit name | |
2013 | $file = "$unit.U" if $dir eq $mc; | |
2014 | print "$dir/$unit.U:\n" if $opt_d; | |
2015 | line: while (<FILE>) { | |
2016 | $line = $_; # Save last processed unit line | |
2017 | if (s/^\?([\w\-]+)://) { # We may have found a control line | |
2018 | $proc = $Depend{$1}; # Look for a procedure to handle it | |
2019 | unless ($proc) { # Unknown control line | |
2020 | $proc = $1; # p_unknown expects symbol in '$proc' | |
2021 | eval '&p_unknown'; # Signal error (metalint only) | |
2022 | next line; # And go on next line | |
2023 | } | |
2024 | # Long lines may be escaped with a final backslash | |
2025 | $_ .= &complete_line(FILE) if s/\\\s*$//; | |
2026 | # Run macros substitutions | |
2027 | s/%</$unit/g; # %< expands into the unit's name | |
2028 | if (s/%\*/$unit/) { | |
2029 | # %* expanded into the entire set of defined symbols | |
2030 | # in the old version. Now it is only the unit's name. | |
2031 | ++$old_version; | |
2032 | } | |
2033 | eval { &$proc($_) }; # Process the line | |
2034 | } else { | |
2035 | next file unless $body; # No procedure to handle body | |
2036 | do { | |
2037 | $line = $_; # Save last processed unit line | |
2038 | eval { &$body($_) } ; # From now on, it's the unit body | |
2039 | } while (defined ($_ = <FILE>)); | |
2040 | next file; | |
2041 | } | |
2042 | } | |
2043 | } continue { | |
2044 | warn(" Warning: $file is a pre-3.0 version.\n") if $old_version; | |
2045 | &$ending($line) if $ending; # Post-processing for metalint | |
2046 | } | |
2047 | ||
2048 | &end_extraction; # End the extraction process | |
2049 | } | |
2050 | ||
2051 | # The first line was escaped with a final \ character. Every following line | |
2052 | # is to be appended to it (until we found a real \n not escaped). Note that | |
2053 | # the leading spaces of the continuation line are removed, so any space should | |
2054 | # be added before the former \ if needed. | |
2055 | sub main'load_complete_line { | |
2056 | package main; | |
2057 | local($file) = @_; # File where lines come from | |
2058 | local($_); | |
2059 | local($read) = ''; # Concatenation of all the continuation lines found | |
2060 | while (<$file>) { | |
2061 | s/^\s+//; # Remove leading spaces | |
2062 | if (s/\\\s*$//) { # Still followed by a continuation line | |
2063 | $read .= $_; | |
2064 | } else { # We've reached the end of the continuation | |
2065 | return $read . $_; | |
2066 | } | |
2067 | } | |
2068 | } | |
2069 | ||
2070 | # Record obsolete symbols association (new versus old), that is to say for a | |
2071 | # given old symbol, $Obsolete{'old'} = new symbol to be used. A '$' is prepended | |
2072 | # for all shell variables | |
2073 | sub main'load_record_obsolete { | |
2074 | package main; | |
2075 | local($_) = @_; | |
2076 | local(@obsoleted); # List of obsolete symbols | |
2077 | local($symbol); # New symbol which must be used | |
2078 | local($dollar) = s/^\$// ? '$':''; # The '$' or a null string | |
2079 | # Syntax for obsolete symbols specification is | |
2080 | # list of symbols (obsolete ones): | |
2081 | if (/^(\w+)\s*\((.*)\)\s*:$/) { | |
2082 | $symbol = "$dollar$1"; | |
2083 | @obsoleted = split(' ', $2); # List of obsolete symbols | |
2084 | } else { | |
2085 | if (/^(\w+)\s*\((.*):$/) { | |
2086 | warn "\"$file\", line $.: final ')' before ':' missing.\n"; | |
2087 | $symbol = "$dollar$1"; | |
2088 | @obsoleted = split(' ', $2); | |
2089 | } else { | |
2090 | warn "\"$file\", line $.: syntax error.\n"; | |
2091 | return; | |
2092 | } | |
2093 | } | |
2094 | foreach $val (@obsoleted) { | |
2095 | $_ = $dollar . $val; | |
2096 | if (defined $Obsolete{$_}) { | |
2097 | warn "\"$file\", line $.: '$_' already obsoleted by '$Obsolete{$_}'.\n"; | |
2098 | } else { | |
2099 | $Obsolete{$_} = $symbol; # Record (old, new) tuple | |
2100 | } | |
2101 | } | |
2102 | } | |
2103 | ||
2104 | # Dump obsolete symbols used in file 'Obsolete'. Also write Obsol_h.U and | |
2105 | # Obsol_sh.U to record old versus new mappings if the -o option was used. | |
2106 | sub main'load_dump_obsolete { | |
2107 | package main; | |
2108 | unless (-f 'Obsolete') { | |
2109 | open(OBSOLETE, ">Obsolete") || die "Can't create Obsolete.\n"; | |
2110 | } | |
2111 | open(OBSOL_H, ">.MT/Obsol_h.U") || die "Can't create .MT/Obsol_h.U.\n"; | |
2112 | open(OBSOL_SH, ">.MT/Obsol_sh.U") || die "Can't create .MT/Obsol_sh.U.\n"; | |
2113 | local($file); # File where obsolete symbol was found | |
2114 | local($old); # Name of this old symbol | |
2115 | local($new); # Value of the new symbol to be used | |
2116 | # Leave a blank line at the top so that anny added ^L will stand on a line | |
2117 | # by itself (the formatting process adds a ^L when a new page is needed). | |
2118 | format OBSOLETE_TOP = | |
2119 | ||
2120 | File | Old symbol | New symbol | |
2121 | -----------------------------------+----------------------+--------------------- | |
2122 | . | |
2123 | format OBSOLETE = | |
2124 | @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | |
2125 | $file, $old, $new | |
2126 | . | |
2127 | local(%seen); | |
2128 | foreach $key (sort keys %ofound) { | |
2129 | ($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/); | |
2130 | write(OBSOLETE) unless $file eq 'XXX'; | |
2131 | next unless $opt_o; # Obsolete mapping done only with -o | |
2132 | next if $seen{$old}++; # Already remapped, thank you | |
2133 | if ($new =~ s/^\$//) { # We found an obsolete shell symbol | |
2134 | $old =~ s/^\$//; | |
2135 | print OBSOL_SH "$old=\"\$$new\"\n"; | |
2136 | } else { # We found an obsolete C symbol | |
2137 | print OBSOL_H "#ifdef $new\n"; | |
2138 | print OBSOL_H "#define $old $new\n"; | |
2139 | print OBSOL_H "#endif\n\n"; | |
2140 | } | |
2141 | } | |
2142 | close OBSOLETE; | |
2143 | close OBSOL_H; | |
2144 | close OBSOL_SH; | |
2145 | if (-s 'Obsolete') { | |
2146 | print "*** Obsolete symbols found -- see file 'Obsolete' for a list.\n"; | |
2147 | } else { | |
2148 | unlink 'Obsolete'; | |
2149 | } | |
2150 | undef %ofound; # Not needed any more | |
2151 | } | |
2152 | ||
2153 | # Perform the topological sort of the items and outline cycles. | |
2154 | sub main'load_tsort { | |
2155 | package tsort; | |
2156 | local(*Succ, *Prec) = @_; # Tables of succesors and predecessors | |
2157 | local(@Out); # The outsider set | |
2158 | local(@keys); # Current active precursors | |
2159 | local($item); # Item to sort | |
2160 | ||
2161 | for (@keys = keys %Prec; @keys || @Out; @keys = keys %Prec) { | |
2162 | &resync; # Resynchronize outsiders | |
2163 | if (@Out == 0) { # Cycle detected | |
2164 | &extract_cycle(*Prec, *Succ); | |
2165 | next; | |
2166 | } | |
2167 | $item = shift(@Out); # Sort current item (don't care which one) | |
2168 | &sort($item); # Update internal structures | |
2169 | } | |
2170 | } | |
2171 | ||
2172 | # Resynchronize the outsiders stack (those items that have no more precursors). | |
2173 | # If the outsiders stack becomes empty, then there is a cycle. | |
2174 | sub tsort'load_resync { | |
2175 | package tsort; | |
2176 | foreach $target (keys %Prec) { | |
2177 | if ($Prec{$target} == 0) { | |
2178 | delete $Prec{$target}; # We're done with this item | |
2179 | push(@Out, $target); # Ready to be sorted | |
2180 | } | |
2181 | } | |
2182 | } | |
2183 | ||
2184 | # Sort item | |
2185 | sub tsort'load_sort { | |
2186 | package tsort; | |
2187 | local($item) = @_; | |
2188 | print "(ok) $item\n" if $main'opt_d && !$Cycle; | |
2189 | print "(fx) $item\n" if $main'opt_d && $Cycle; | |
2190 | foreach $succ (split(' ', $Succ{$item})) { | |
2191 | # The test for definedness is necessary, since when a cycle is found, | |
2192 | # one item is forced out of %Prec. If we had the guarantee of no | |
2193 | # cycle, the the test would not be necessary and no decrementation | |
2194 | # could go past 0. | |
2195 | $Prec{$succ}-- if defined $Prec{$succ}; | |
2196 | } | |
2197 | } | |
2198 | ||
2199 | # Extract cycle... We look through the %Prec array and find all those items | |
2200 | # with the same lowest value. Those are a cycle, so we dump them, and make | |
2201 | # them new outsiders by resetting their count to 0. | |
2202 | sub tsort'load_extract_cycle { | |
2203 | package tsort; | |
2204 | local(*Prec, *Succ) = @_; | |
2205 | local($item) = (&sort_by_value(*Prec))[0]; | |
2206 | local($min) = $Prec{$item}; # Minimum value | |
2207 | local($key, $value); | |
2208 | local(%candidate); # Superset of the cycle we found | |
2209 | warn " Cycle found for:\n"; | |
2210 | $Cycle++; | |
2211 | while (($key, $value) = each %Prec) { | |
2212 | $candidate{$key}++ if $value == $min; | |
2213 | } | |
2214 | local(%state); # State of visited nodes (1 = cycle, -1 = dead) | |
2215 | local($CYCLE) = 1; # Possible member of a cycle | |
2216 | local($DEAD) = -1; # Dead end, no cycling possible | |
2217 | foreach $key (keys %candidate) { | |
2218 | last if $CYCLE == &visit($key, $Succ{$key}); | |
2219 | } | |
2220 | while (($key, $value) = each %candidate) { | |
2221 | next unless $state{$key} == $CYCLE; | |
2222 | $Prec{$key} = 0; # Members of cycle are new outsiders | |
2223 | warn "\t(#$Cycle) $key\n"; | |
2224 | } | |
2225 | local(%involved); # Items involved in the cycle... | |
2226 | while (($key, $value) = each %state) { | |
2227 | $involved{$key}++ if $state{$key} == $CYCLE; | |
2228 | } | |
2229 | &outline_cycle(*Succ, *involved); | |
2230 | } | |
2231 | ||
2232 | sub tsort'load_outline_cycle { | |
2233 | package tsort; | |
2234 | local(*Succ, *member) = @_; | |
2235 | local($key, $value); | |
2236 | local($depends); | |
2237 | local($unit); | |
2238 | warn " Cycle involves:\n"; | |
2239 | while (($key, $value) = each %Succ) { | |
2240 | next unless $member{$key}; | |
2241 | $depends = ''; | |
2242 | foreach $item (split(' ', $value)) { | |
2243 | $depends .= "$item " if $member{$item}; | |
2244 | } | |
2245 | $unit = $main'shmaster{"\$$key"}; | |
2246 | $unit =~ s/\s+$//; | |
2247 | $unit = '?' if $unit eq ''; | |
2248 | warn "\t($unit) $key: $depends\n"; | |
2249 | } | |
2250 | } | |
2251 | ||
2252 | # Visit a tree node, following all its successors, until we find a cycle. | |
2253 | # Return $CYCLE if the exploration of the node leaded to a cycle, $DEAD | |
2254 | # otherwise. | |
2255 | sub tsort'load_visit { | |
2256 | package tsort; | |
2257 | local($node, $children) = @_; # A node and its children | |
2258 | # If we have already visited the node, return the status value attached | |
2259 | # to it. | |
2260 | return $state{$node} if $state{$node}; | |
2261 | $state{$node} = $CYCLE; # Assume member of cycle | |
2262 | local($all_dead) = 1; # Set to 0 if at least one cycle found | |
2263 | foreach $child (split(' ', $children)) { | |
2264 | $all_dead = 0 if $CYCLE == &visit($child, $Succ{$child}); | |
2265 | } | |
2266 | $state{$node} = $DEAD if $all_dead; | |
2267 | $state{$node}; | |
2268 | } | |
2269 | ||
2270 | # Sort associative array by value | |
2271 | sub tsort'load_sort_by_value { | |
2272 | package tsort; | |
2273 | local(*x) = @_; | |
2274 | sub _by_value { $x{$a} <=> $x{$b}; } | |
2275 | sort _by_value keys %x; | |
2276 | } | |
2277 | ||
2278 | # Perform ~name expansion ala ksh... | |
2279 | # (banish csh from your vocabulary ;-) | |
2280 | sub main'load_tilda_expand { | |
2281 | package main; | |
2282 | local($path) = @_; | |
2283 | return $path unless $path =~ /^~/; | |
2284 | $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e; # ~name | |
2285 | $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e; # ~ | |
2286 | $path; | |
2287 | } | |
2288 | ||
2289 | # Set up profile components into %Profile, add any profile-supplied options | |
2290 | # into @ARGV and return the command invocation name. | |
2291 | sub main'load_profile { | |
2292 | package main; | |
2293 | local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile'); | |
2294 | local($me) = $0; # Command name | |
2295 | $me =~ s|.*/(.*)|$1|; # Keep only base name | |
2296 | return $me unless -s $profile; | |
2297 | local(*PROFILE); # Local file descriptor | |
2298 | local($options) = ''; # Options we get back from profile | |
2299 | unless (open(PROFILE, $profile)) { | |
2300 | warn "$me: cannot open $profile: $!\n"; | |
2301 | return; | |
2302 | } | |
2303 | local($_); | |
2304 | local($component); | |
2305 | while (<PROFILE>) { | |
2306 | next if /^\s*#/; # Skip comments | |
2307 | next unless /^$me/o; | |
2308 | if (s/^$me://o) { # progname: options | |
2309 | chop; | |
2310 | $options .= $_; # Merge options if more than one line | |
2311 | } | |
2312 | elsif (s/^$me-([^:]+)://o) { # progname-component: value | |
2313 | $component = $1; | |
2314 | chop; | |
2315 | s/^\s+//; # Trim leading and trailing spaces | |
2316 | s/\s+$//; | |
2317 | $Profile{$component} = $_; | |
2318 | } | |
2319 | } | |
2320 | close PROFILE; | |
2321 | return unless $options; | |
2322 | require 'shellwords.pl'; | |
2323 | local(@opts); | |
2324 | eval '@opts = &shellwords($options)'; # Protect against mismatched quotes | |
2325 | unshift(@ARGV, @opts); | |
2326 | return $me; # Return our invocation name | |
2327 | } | |
2328 | ||
2329 | # | |
2330 | # End of dataloading section. | |
2331 | # | |
2332 |