1 | #!/usr/bin/perl |
---|
2 | |
---|
3 | use strict; |
---|
4 | use warnings; |
---|
5 | # use diagnostics; |
---|
6 | |
---|
7 | # my $debug_verboose; |
---|
8 | |
---|
9 | # BEGIN { |
---|
10 | # $debug_verboose = 1; |
---|
11 | # $SIG{__DIE__} = sub { |
---|
12 | # require Carp; |
---|
13 | # if ($debug_verboose>0) { Carp::confess(@_); } # with backtrace |
---|
14 | # else { Carp::croak(@_); } |
---|
15 | # } |
---|
16 | # } |
---|
17 | |
---|
18 | |
---|
19 | # -------------------------------------------------------------------------------- |
---|
20 | |
---|
21 | my $ARBHOME = $ENV{ARBHOME}; |
---|
22 | if (not defined $ARBHOME) { die "Environmentvariable ARBHOME has be defined"; } |
---|
23 | if (not -d $ARBHOME) { die "ARBHOME ('$ARBHOME') does not point to a valid directory"; } |
---|
24 | |
---|
25 | # -------------------------------------------------------------------------------- |
---|
26 | |
---|
27 | my @pictures = (); # contains all .fig |
---|
28 | my @pixmaps = (); # contains all .xpm |
---|
29 | my @helpfiles = (); # contains all .help, .pdf, .pdf.gz, .ps, .ps.gz |
---|
30 | |
---|
31 | my %known = (); # contains all files contained in arrays above |
---|
32 | my %unknown = (); # contains all other files found in scanned directories |
---|
33 | |
---|
34 | my %picture = (); # key=subdir/name (as used in code), value=index into @pictures |
---|
35 | my %pixmap = (); # key=subdir/name (as used in code), value=index into @pixmaps |
---|
36 | my %helpfile = (); # key=subdir/name (as used in code), value=index into @helpfiles |
---|
37 | |
---|
38 | my %used = (); # key=file, value=1 -> used in code, value=2 -> used in helpfile |
---|
39 | |
---|
40 | my %full2rel = (); # key=full resource, value=relative resource (w/o rootdir) |
---|
41 | my %rel2full = (); # opposite |
---|
42 | |
---|
43 | # -------------------------------------------------------------------------------- |
---|
44 | |
---|
45 | sub scanFiles(\@$$$$); |
---|
46 | sub scanFiles(\@$$$$) { |
---|
47 | my ($files_r,$dir,$mask,$recurse,$ignoreLinks) = @_; |
---|
48 | |
---|
49 | my $reg = qr/$mask/; |
---|
50 | |
---|
51 | my @subdirs = (); |
---|
52 | opendir(DIR,$dir) || die "can't read directory '$dir' (Reason: $!)"; |
---|
53 | foreach (readdir(DIR)) { |
---|
54 | if ($_ ne '.' and $_ ne '..') { |
---|
55 | my $full = $dir.'/'.$_; |
---|
56 | if (-d $full) { |
---|
57 | if (/unused/o) { |
---|
58 | print "Ignoring resource directory '$full' (assuming it contains unused things)\n"; |
---|
59 | } |
---|
60 | elsif (not (/^.svn$/o or /^CVS$/o)) { |
---|
61 | push @subdirs, $full; |
---|
62 | } |
---|
63 | } |
---|
64 | else { |
---|
65 | if ($ignoreLinks==0 || not -l $full) { |
---|
66 | if ($_ =~ $reg) { |
---|
67 | push @$files_r, $full; |
---|
68 | $known{$full} = 1; |
---|
69 | if (defined $unknown{$full}) { delete $unknown{$full}; } |
---|
70 | } |
---|
71 | elsif (/^Makefile$/o or /\.pl$/o) { |
---|
72 | ; # ignore |
---|
73 | } |
---|
74 | elsif (not defined $known{$full}) { |
---|
75 | $unknown{$full} = 1; |
---|
76 | } |
---|
77 | } |
---|
78 | } |
---|
79 | } |
---|
80 | } |
---|
81 | closedir(DIR); |
---|
82 | |
---|
83 | if ($recurse==1) { |
---|
84 | foreach (@subdirs) { |
---|
85 | scanFiles(@$files_r, $_, $mask, $recurse, $ignoreLinks); |
---|
86 | } |
---|
87 | } |
---|
88 | } |
---|
89 | |
---|
90 | sub scanFilesAndIndex(\%\@$$$$) { |
---|
91 | my ($index_r,$files_r,$dir,$mask,$recurse,$ignoreLinks) = @_; |
---|
92 | scanFiles(@$files_r,$dir,$mask,$recurse,$ignoreLinks); |
---|
93 | |
---|
94 | my $len = length($dir)+1; # plus '/' |
---|
95 | my $count = scalar(@$files_r); |
---|
96 | for (my $c=0; $c<$count; $c++) { |
---|
97 | my $rel = substr($$files_r[$c], $len); |
---|
98 | $$index_r{$rel} = $c; |
---|
99 | # print "full='".$$files_r[$c]."' idx='$c' rel='$rel'\n"; |
---|
100 | } |
---|
101 | } |
---|
102 | |
---|
103 | sub scanExistingRessources() { |
---|
104 | scanFilesAndIndex(%picture, @pictures, $ARBHOME.'/lib/pictures', '.*\.(fig|vfont)$', 1, 0); |
---|
105 | scanFilesAndIndex(%pixmap, @pixmaps, $ARBHOME.'/lib/pixmaps', '.*\.(xpm|png)$', 1, 0); |
---|
106 | scanFilesAndIndex(%helpfile, @helpfiles, $ARBHOME.'/HELP_SOURCE/oldhelp', '.*\.(hlp|ps|pdf|ps\.gz|pdf\.gz)$', 1, 0); |
---|
107 | scanFilesAndIndex(%helpfile, @helpfiles, $ARBHOME.'/HELP_SOURCE/genhelp', '.*\.(hlp|ps|pdf|ps\.gz|pdf\.gz)$', 1, 0); |
---|
108 | |
---|
109 | foreach (sort keys %unknown) { |
---|
110 | if (/readme[^\/]*$/i) { ; } # ignore readme files |
---|
111 | elsif (/\/genhelp\/.*(footer|header)$/o) { ; } # ignore files used for help generation |
---|
112 | elsif (/\.bak$/o) { ; } # ignore bak files |
---|
113 | elsif (/\.svg$/o) { ; } # ignore svg files (used as source to create png) |
---|
114 | else { |
---|
115 | print "$_:0: Unhandled file in resource directory\n"; |
---|
116 | } |
---|
117 | } |
---|
118 | |
---|
119 | foreach (keys %picture) { my $full = $pictures [$picture{$_}]; $full2rel{$full} = $_; } |
---|
120 | foreach (keys %pixmap) { my $full = $pixmaps [$pixmap{$_}]; $full2rel{$full} = $_; } |
---|
121 | foreach (keys %helpfile) { my $full = $helpfiles[$helpfile{$_}]; $full2rel{$full} = $_; } |
---|
122 | |
---|
123 | foreach (keys %full2rel) { |
---|
124 | my $rel = $full2rel{$_}; |
---|
125 | die if not defined $rel; |
---|
126 | if (exists $rel2full{$rel}) { |
---|
127 | print "$_:0: Error: resource name clashes with ...\n"; |
---|
128 | print $rel2full{$rel}.":0: ... this one\n"; |
---|
129 | } |
---|
130 | else { |
---|
131 | $rel2full{$rel} = $_; |
---|
132 | } |
---|
133 | } |
---|
134 | } |
---|
135 | |
---|
136 | # -------------------------------------------------------------------------------- |
---|
137 | |
---|
138 | my $reg_parser = qr/([\(\),\\\"\'\;\{]|\/\*|\/\/)/; |
---|
139 | my $reg_parse_dquotes = qr/(\\.|\")/; |
---|
140 | my $reg_parse_squotes = qr/(\\.|\')/; |
---|
141 | my $reg_parse_eoc = qr/\*\//; |
---|
142 | |
---|
143 | sub scanNextToken(\$\@\$); |
---|
144 | sub scanNextToken(\$\@\$) { |
---|
145 | my ($rest_r,$file_r,$lineNr_r) = @_; |
---|
146 | # scans for the next token (tokens are '(', ')', ',', ';' and '{') |
---|
147 | # and returns it together with it's prefix |
---|
148 | # modifies rest_r and lineNr_r |
---|
149 | # if no token is found until EOF, token will be 'undef' |
---|
150 | # reads over comments |
---|
151 | |
---|
152 | my $prefix = ''; |
---|
153 | my $match = undef; |
---|
154 | if ($$rest_r =~ $reg_parser) { |
---|
155 | my ($preTok,$tok) = ($`,$&); |
---|
156 | $$rest_r = $'; |
---|
157 | |
---|
158 | if ($tok eq '(' or $tok eq ')' or $tok eq ',' or $tok eq ';' or $tok eq '{') { # accept wanted tokens |
---|
159 | $prefix .= $preTok; |
---|
160 | $match = $tok; |
---|
161 | } |
---|
162 | elsif ($tok eq '\\') { # skip escaped chars |
---|
163 | $prefix .= $preTok.$tok.substr($$rest_r,0,1); |
---|
164 | $$rest_r = substr($$rest_r,1); |
---|
165 | } |
---|
166 | elsif ($tok eq '/*') { # skip /**/-comments |
---|
167 | $prefix .= $preTok; |
---|
168 | # print "prefix='$prefix' preTok='$preTok' rest_r='$$rest_r'\n"; |
---|
169 | my $found = 0; |
---|
170 | while ($found==0) { |
---|
171 | if ($$rest_r =~ $reg_parse_eoc) { |
---|
172 | # print "\$`='$`' \$&='$&' \$'='$''\n"; |
---|
173 | if (not $& eq '*/') { die "expected to see '*/', parsed '$&' from '$$rest_r' (this is a bug in check_resources.pl!)"; } |
---|
174 | $$rest_r = $'; |
---|
175 | $found = 1; |
---|
176 | } |
---|
177 | else { |
---|
178 | $$rest_r = $$file_r[$$lineNr_r++]; |
---|
179 | chomp($$rest_r); |
---|
180 | # print "Continue in next line (while searching '*/'): '$$rest_r'\n"; |
---|
181 | if (not defined $$rest_r) { die "Unclosed '/*'"; } |
---|
182 | } |
---|
183 | } |
---|
184 | } |
---|
185 | elsif ($tok eq '//') { |
---|
186 | $prefix .= $preTok; |
---|
187 | $$rest_r = $$file_r[$$lineNr_r++]; |
---|
188 | chomp($$rest_r); |
---|
189 | # print "Continue in next line (skipping '//'): '$$rest_r'\n"; |
---|
190 | } |
---|
191 | elsif ($tok eq '"') { |
---|
192 | $prefix .= $preTok.$tok; |
---|
193 | my $closed_dquote = 0; |
---|
194 | while ($closed_dquote==0) { |
---|
195 | if ($$rest_r =~ $reg_parse_dquotes) { |
---|
196 | $prefix .= $`.$&; |
---|
197 | $$rest_r = $'; |
---|
198 | if ($& eq '"') { $closed_dquote = 1; } |
---|
199 | } |
---|
200 | else { die "Missing '\"'"; } |
---|
201 | } |
---|
202 | } |
---|
203 | elsif ($tok eq '\'') { |
---|
204 | $prefix .= $preTok.$tok; |
---|
205 | my $closed_squote = 0; |
---|
206 | while ($closed_squote==0) { |
---|
207 | if ($$rest_r =~ $reg_parse_squotes) { |
---|
208 | $prefix .= $`.$&; |
---|
209 | $$rest_r = $'; |
---|
210 | if ($& eq '\'') { $closed_squote = 1; } |
---|
211 | } |
---|
212 | else { die "Missing '\''"; } |
---|
213 | } |
---|
214 | } |
---|
215 | else { |
---|
216 | die "Unknown token '$tok'"; |
---|
217 | } |
---|
218 | |
---|
219 | if (not defined $match) { # continue |
---|
220 | my $nextPrefix; |
---|
221 | ($nextPrefix,$match) = scanNextToken($$rest_r, @$file_r, $$lineNr_r); |
---|
222 | $prefix .= $nextPrefix; |
---|
223 | } |
---|
224 | } |
---|
225 | else { |
---|
226 | $prefix .= $$rest_r; |
---|
227 | $$rest_r = $$file_r[$$lineNr_r++]; |
---|
228 | chomp($$rest_r); |
---|
229 | # print "Continue in next line: '$$rest_r'\n"; |
---|
230 | if (defined $$rest_r) { # not EOF yet |
---|
231 | my $p; |
---|
232 | ($p,$match) = scanNextToken($$rest_r,@$file_r,$$lineNr_r); |
---|
233 | $prefix .= $p; |
---|
234 | } |
---|
235 | } |
---|
236 | |
---|
237 | return ($prefix,$match); |
---|
238 | } |
---|
239 | |
---|
240 | sub scanParams($\@$\$) { |
---|
241 | my ($rest,$file_r,$lineNr,$calltype_r) = @_; |
---|
242 | |
---|
243 | $$calltype_r = 0; # no params |
---|
244 | |
---|
245 | my ($prefix,$token); |
---|
246 | my @params = (); |
---|
247 | eval { |
---|
248 | ($prefix,$token) = scanNextToken($rest,@$file_r,$lineNr); |
---|
249 | }; |
---|
250 | if (!$@ and $token eq '(') { |
---|
251 | if (trim($prefix) ne '') { |
---|
252 | # print "Found prefix '$prefix' before potential parameter list - assume it's sth else\n"; |
---|
253 | } |
---|
254 | else { |
---|
255 | my $openParens = 1; |
---|
256 | my $prevPrefix = ''; |
---|
257 | while ($openParens>0) { |
---|
258 | ($prefix,$token) = scanNextToken($rest,@$file_r,$lineNr); |
---|
259 | my $seen_eop = 0; |
---|
260 | |
---|
261 | if (not defined $token) { die "EOF reached while scanning parameter list"; } |
---|
262 | elsif ($token eq ')') { $openParens--; if ($openParens==0) { $seen_eop = 1; } } |
---|
263 | elsif ($token eq '(') { $openParens++; } |
---|
264 | elsif ($token eq ',') { if ($openParens==1) { $seen_eop = 1; } } |
---|
265 | else { die "Unexpected token '$token' (behind '$prefix')"; } |
---|
266 | |
---|
267 | $prevPrefix .= $prefix; |
---|
268 | if ($seen_eop==1) { push @params, $prevPrefix; $prevPrefix = ''; } |
---|
269 | else { $prevPrefix .= $token; } |
---|
270 | } |
---|
271 | |
---|
272 | $$calltype_r = 1; |
---|
273 | eval { |
---|
274 | ($prefix,$token) = scanNextToken($rest,@$file_r,$lineNr); |
---|
275 | }; |
---|
276 | if ($@) { |
---|
277 | @params = (); |
---|
278 | } |
---|
279 | else { |
---|
280 | if ($token eq ';') { $$calltype_r = 2; } # accepted call |
---|
281 | elsif ($token eq '{') { $$calltype_r = 3; } # function def |
---|
282 | elsif ($token eq ')') { $$calltype_r = 2; } # accepted ("othercall(call())") |
---|
283 | elsif ($token eq ',') { $$calltype_r = 2; } # accepted ("othercall(call(),...)") |
---|
284 | else { |
---|
285 | if ($prefix =~ /__ATTR_/o) { |
---|
286 | $$calltype_r = 3; # function def |
---|
287 | } |
---|
288 | else { |
---|
289 | die "unknown token behind call: '$token' (possible call; ignored due to this error; prefix='$prefix')\n"; |
---|
290 | } |
---|
291 | } |
---|
292 | } |
---|
293 | } |
---|
294 | } |
---|
295 | |
---|
296 | return @params; |
---|
297 | } |
---|
298 | |
---|
299 | sub trim($) { |
---|
300 | my ($str) = @_; |
---|
301 | $str =~ s/^\s+//g; |
---|
302 | $str =~ s/\s+$//g; |
---|
303 | return $str; |
---|
304 | } |
---|
305 | |
---|
306 | sub isQuoted($); |
---|
307 | sub isQuoted($) { |
---|
308 | my ($str) = @_; |
---|
309 | if ($str =~ /^\"(.*)\"$/o) { return $1; } |
---|
310 | if ($str =~ /^\(\s*AW_CL\s*\)\s*/o) { |
---|
311 | return isQuoted($'); |
---|
312 | } |
---|
313 | if ($str =~ 'AW_POPUP_HELP') { return 'AW_POPUP_HELP'; } |
---|
314 | return undef; |
---|
315 | } |
---|
316 | |
---|
317 | # -------------------------------------------------------------------------------- |
---|
318 | |
---|
319 | sub acceptAll($) { |
---|
320 | my ($res_param) = @_; |
---|
321 | return ($res_param); |
---|
322 | } |
---|
323 | sub isPixmapRef($) { |
---|
324 | my ($res_param) = @_; |
---|
325 | if ($res_param =~ /^#/) { return ($'); } |
---|
326 | return (); |
---|
327 | } |
---|
328 | sub isIconRes($) { |
---|
329 | my ($res_param) = @_; |
---|
330 | my $base = 'icons/'.$res_param; |
---|
331 | return ($base.'.xpm', $base.'.png'); |
---|
332 | } |
---|
333 | sub isHelpRef($) { |
---|
334 | my ($res_param) = @_; |
---|
335 | if ($res_param =~ /\.(hlp|ps|pdf)$/o) { return ($res_param); } |
---|
336 | return (); |
---|
337 | } |
---|
338 | |
---|
339 | my @defs = |
---|
340 | ( |
---|
341 | # regexp for function, param numbers, expectInIndex, isRessource, |
---|
342 | [ qr/\b(AW_help_popup)\b/, [ 2 ], \%helpfile, \&isHelpRef, ], |
---|
343 | [ qr/\b(create_button)\b/, [ 2 ], \%pixmap, \&isPixmapRef, ], |
---|
344 | [ qr/\b(create_mode)\b/, [ 1 ], \%pixmap, \&acceptAll, ], |
---|
345 | [ qr/\b(create_mode)\b/, [ 2 ], \%helpfile, \&isHelpRef, ], |
---|
346 | [ qr/\b(create_toggle)\b/, [ -2, -3 ], \%pixmap, \&isPixmapRef, ], |
---|
347 | [ qr/\b(help_text)\b/, [ 1 ], \%helpfile, \&isHelpRef, ], |
---|
348 | [ qr/\b(makeHelpCallback)\b/, [ 1 ], \%helpfile, \&isHelpRef, ], |
---|
349 | [ qr/\b(AWT_create_root)\b/, [ 2 ], \%pixmap, \&isIconRes, ], |
---|
350 | [ qr/\b(insert_help_topic)\b/, [ 3 ], \%helpfile, \&isHelpRef, ], |
---|
351 | [ qr/\b(insert_menu_topic)\b/, [ 2 ], \%pixmap, \&isPixmapRef, ], |
---|
352 | [ qr/\b(insert_menu_topic)\b/, [ 4 ], \%helpfile, \&isHelpRef, ], |
---|
353 | [ qr/\b(insert_mark_topic)\b/, [ 7 ], \%helpfile, \&isHelpRef, ], |
---|
354 | [ qr/\b(GEN_insert_extract_submenu)\b/, [ 6 ], \%helpfile, \&isHelpRef, ], |
---|
355 | [ qr/\b(GEN_insert_mark_submenu)\b/, [ 6 ], \%helpfile, \&isHelpRef, ], |
---|
356 | [ qr/\b(AW_advice)\b/, [ -4 ], \%helpfile, \&isHelpRef, ], |
---|
357 | [ qr/\b(add_help)\b/, [ 1 ], \%helpfile, \&isHelpRef, ], |
---|
358 | [ qr/\b(insert_toggle)\b/, [ 1 ], \%pixmap, \&isPixmapRef, ], |
---|
359 | [ qr/\b(load_xfig)\b/, [ 1 ], \%picture, \&acceptAll, ], |
---|
360 | |
---|
361 | # pseudos (used in comment to mark a resource as used) |
---|
362 | [ qr/\b(uses_hlp_res)\b/, [ 1, -2, -3, -4, -5 ], \%helpfile, \&isHelpRef, ], |
---|
363 | # [ qr/\b(uses_pic_res)\b/, [ 1, -2, -3, -4, -5 ], \%picture, \&acceptAll, ], |
---|
364 | [ qr/\b(uses_pix_res)\b/, [ 1, -2, -3, -4, -5 ], \%pixmap, \&acceptAll, ], |
---|
365 | ); |
---|
366 | |
---|
367 | # - param numbers is [1..n] or [-1..-n] for optional params |
---|
368 | # - isRessource gets the unquoted potential resource (without possible '(AW_CL)'-cast) and |
---|
369 | # returns the plain resource name or undef (if it's definitely no resource) |
---|
370 | |
---|
371 | my $defs = scalar(@defs); |
---|
372 | my $errors = 0; |
---|
373 | my $LOC = 0; |
---|
374 | my $showSpecialWarnings = 0; |
---|
375 | |
---|
376 | my @ruleMatched = (); |
---|
377 | |
---|
378 | sub scanCodeFile($) { |
---|
379 | my ($file) = @_; |
---|
380 | open(FILE,'<'.$file) || die "can't read '$file' (Reason: $!)"; |
---|
381 | |
---|
382 | my @file = <FILE>; |
---|
383 | my $flines = scalar(@file); |
---|
384 | unshift @file, undef; # line 0 |
---|
385 | |
---|
386 | my $lineNr = 0; |
---|
387 | eval { |
---|
388 | for ($lineNr=1; $lineNr<=$flines; $lineNr++) { |
---|
389 | my $line = $file[$lineNr]; |
---|
390 | # if ($line =~ /kernlin/io) { print "$file:$lineNr: Custom-Search: ".trim($line)."\n"; } # used to test this script |
---|
391 | |
---|
392 | for (my $d=0; $d<$defs; $d++) { |
---|
393 | my $def_r = $defs[$d]; |
---|
394 | my $reg = $$def_r[0]; |
---|
395 | if ($line =~ $reg) { |
---|
396 | my $rest = $'; |
---|
397 | my $match = $&; |
---|
398 | # print "reg='$reg'\n"; |
---|
399 | # print "$file:$lineNr: Match def #$d: $line"; |
---|
400 | |
---|
401 | chomp($rest); |
---|
402 | my $calltype; |
---|
403 | my @params = scanParams($rest,@file,$lineNr+1,$calltype); |
---|
404 | |
---|
405 | if ($calltype==2) { |
---|
406 | my $pnum_r = $$def_r[1]; |
---|
407 | my $pis = scalar(@$pnum_r); |
---|
408 | for (my $pi=0; $pi<$pis; $pi++) { # for all params referencing a resource |
---|
409 | my $pnum = $$pnum_r[$pi]; |
---|
410 | my $param = $params[$pnum<0 ? -$pnum-1 : $pnum-1]; |
---|
411 | |
---|
412 | if (defined $param) { |
---|
413 | $param = trim($param); |
---|
414 | my $unquoted = isQuoted($param); |
---|
415 | if (defined $unquoted) { |
---|
416 | my $test_r = $$def_r[3]; |
---|
417 | my @unquoted = &$test_r($unquoted); # test if definitely NO resource |
---|
418 | |
---|
419 | if (scalar(@unquoted)>0) { # possible resource(s) |
---|
420 | my $idx_r = $$def_r[2]; # resource index |
---|
421 | my $used = 0; |
---|
422 | UNQUOTED: foreach my $unquoted (@unquoted) { |
---|
423 | my $full_resource_idx = $$idx_r{$unquoted}; |
---|
424 | if (not defined $full_resource_idx and $unquoted =~ /\.(ps|pdf)$/o) { |
---|
425 | $unquoted .= '.gz'; # try zipped version |
---|
426 | $full_resource_idx = $$idx_r{$unquoted}; |
---|
427 | } |
---|
428 | if (defined $full_resource_idx) { # existing resource |
---|
429 | my $full_resource = $rel2full{$unquoted}; |
---|
430 | if (not defined $full_resource) { die "expected resource '$unquoted' to be defined"; } |
---|
431 | $used{$full_resource} = 1; |
---|
432 | $ruleMatched[$d] = 1; |
---|
433 | $used = 1; |
---|
434 | } |
---|
435 | } |
---|
436 | |
---|
437 | if ($used==0) { |
---|
438 | print "$file:$lineNr: Error: Ressource '".$unquoted[0]."' is missing\n"; |
---|
439 | $errors++; |
---|
440 | } |
---|
441 | } |
---|
442 | } |
---|
443 | else { |
---|
444 | if ($showSpecialWarnings==1) { |
---|
445 | print "$file:$lineNr: Warning: Param '$param' is not an explicit resource, can't check\n"; |
---|
446 | # print "Params:\n"; foreach (@params) { print "- param='$_'\n"; } |
---|
447 | } |
---|
448 | } |
---|
449 | } |
---|
450 | else { |
---|
451 | if ($pnum>0) { |
---|
452 | print "$file:$lineNr: Warning: Param #$pnum is missing, can't check (maybe param should be optional)\n"; |
---|
453 | } |
---|
454 | } |
---|
455 | } |
---|
456 | } |
---|
457 | else { |
---|
458 | if ($showSpecialWarnings==1 and $calltype!=3) { # don't warn about function definition |
---|
459 | print "$file:$lineNr: Warning: Matched '$match', but wrong calltype (=$calltype)\n"; |
---|
460 | } |
---|
461 | } |
---|
462 | } |
---|
463 | } |
---|
464 | } |
---|
465 | }; |
---|
466 | if ($@) { |
---|
467 | print "$file:$lineNr: Error: $@\n"; |
---|
468 | $errors++; |
---|
469 | # if ($@ =~ /enough/) { die "enough"; } |
---|
470 | } |
---|
471 | close(FILE); |
---|
472 | $LOC += $flines; |
---|
473 | } |
---|
474 | |
---|
475 | sub autouse($) { |
---|
476 | my ($res) = @_; |
---|
477 | if (not defined $known{$res}) { |
---|
478 | print "Warning: Invalid autouse($res) -- unknown resource\n"; |
---|
479 | } |
---|
480 | else { |
---|
481 | $used{$res} = 1; |
---|
482 | } |
---|
483 | } |
---|
484 | |
---|
485 | sub scanCodeFile_forUnuseds($\$\%) { |
---|
486 | my ($file,$reg_r,$seen_r) = @_; |
---|
487 | open(FILE,'<'.$file) || die "can't read '$file' (Reason: $!)"; |
---|
488 | |
---|
489 | my @file = <FILE>; |
---|
490 | my $flines = scalar(@file); |
---|
491 | unshift @file, undef; # line 0 |
---|
492 | |
---|
493 | my $lineNr = 0; |
---|
494 | for ($lineNr=1; $lineNr<=$flines; $lineNr++) { |
---|
495 | my $line = $file[$lineNr]; |
---|
496 | while ($line =~ $$reg_r) { |
---|
497 | my $res = $&; |
---|
498 | # print "$file:$lineNr: Warning: Checker failed to detect potential usage of resource '$res'\n"; |
---|
499 | my $seen = $$seen_r{$res}; |
---|
500 | if (defined $seen) { $seen .= ",$file:$lineNr"; } |
---|
501 | else { $seen = "$file:$lineNr"; } |
---|
502 | $$seen_r{$res} = $seen; |
---|
503 | $line = $'; |
---|
504 | } |
---|
505 | } |
---|
506 | close(FILE); |
---|
507 | } |
---|
508 | |
---|
509 | my %helpScanned = (); |
---|
510 | my $newHelpRef = 0; |
---|
511 | |
---|
512 | sub referenceHelp($); |
---|
513 | sub referenceHelp($) { |
---|
514 | my ($referred) = @_; |
---|
515 | |
---|
516 | my $full_resource_idx = $helpfile{$referred}; |
---|
517 | if (defined $full_resource_idx) { # existing resource |
---|
518 | my $full_resource = $rel2full{$referred}; |
---|
519 | if (not defined $full_resource) { die "expected resource '$referred' to be defined"; } |
---|
520 | $used{$full_resource} = 1; |
---|
521 | $newHelpRef++; |
---|
522 | } |
---|
523 | else { |
---|
524 | if ($referred =~ /\.(pdf|ps)$/) { |
---|
525 | referenceHelp($referred.'.gz'); |
---|
526 | } |
---|
527 | elsif ($referred =~ /\@/) { |
---|
528 | ; # ignore mail addresses |
---|
529 | } |
---|
530 | elsif ($referred =~ /^(http|file):\/\//o) { |
---|
531 | ; # ignore urls |
---|
532 | } |
---|
533 | else { |
---|
534 | die "Ressource '".$referred."' is missing\n"; |
---|
535 | } |
---|
536 | } |
---|
537 | } |
---|
538 | |
---|
539 | sub scanHelpFile($) { |
---|
540 | my ($file) = @_; |
---|
541 | if ($file =~ /\.hlp$/o) { |
---|
542 | if (defined $used{$file} and not defined $helpScanned{$file}) { |
---|
543 | open(FILE,'<'.$file) || die "can't read '$file' (Reason: $!)"; |
---|
544 | my @file = <FILE>; |
---|
545 | my $flines = scalar(@file); |
---|
546 | unshift @file, undef; # line 0 |
---|
547 | my $lineNr = 0; |
---|
548 | for ($lineNr=1; $lineNr<=$flines; $lineNr++) { |
---|
549 | eval { |
---|
550 | $_ = $file[$lineNr]; |
---|
551 | if (/#/) { $_ = $`; } # skip comments |
---|
552 | if (/^\s*(SUB|UP)\s+(.*)$/o) { |
---|
553 | referenceHelp($2); |
---|
554 | } |
---|
555 | else { |
---|
556 | while (/LINK{([^\}]*)}/o) { |
---|
557 | my $rest = $'; |
---|
558 | referenceHelp($1); |
---|
559 | $_ = $rest; |
---|
560 | } |
---|
561 | } |
---|
562 | }; |
---|
563 | if ($@) { |
---|
564 | chomp($@); |
---|
565 | print "$file:$lineNr: Error: $@\n"; |
---|
566 | $errors++; |
---|
567 | # if ($@ =~ /enough/) { die "enough"; } |
---|
568 | } |
---|
569 | } |
---|
570 | close(FILE); |
---|
571 | $helpScanned{$file} = 1; |
---|
572 | $LOC += $flines; |
---|
573 | } |
---|
574 | } |
---|
575 | } |
---|
576 | |
---|
577 | |
---|
578 | sub scanCode() { |
---|
579 | my @sources = (); |
---|
580 | { |
---|
581 | my %oldKnown = %known; |
---|
582 | scanFiles(@sources, $ARBHOME, '\.[ch](xx|pp){0,1}$', 1, 1); # destroys %known and %unknown |
---|
583 | print 'Checking '.scalar(@sources)." source files.\n"; |
---|
584 | |
---|
585 | %known = %oldKnown; |
---|
586 | %unknown = (); |
---|
587 | } |
---|
588 | |
---|
589 | for (my $d=0; $d<scalar(@defs); ++$d) { $ruleMatched[$d] = 0; } |
---|
590 | @sources = sort @sources; |
---|
591 | foreach (@sources) { scanCodeFile($_); } |
---|
592 | |
---|
593 | { |
---|
594 | my $intro = 0; |
---|
595 | for (my $d=0; $d<scalar(@defs); ++$d) { |
---|
596 | if ($ruleMatched[$d] == 0) { |
---|
597 | if ($intro==0) { print "Some code-rules never applied:"; $intro = 1; } |
---|
598 | print " \#$d"; |
---|
599 | } |
---|
600 | } |
---|
601 | if ($intro==1) { print "\n"; } |
---|
602 | } |
---|
603 | |
---|
604 | $newHelpRef = 1; |
---|
605 | while ($newHelpRef>0) { |
---|
606 | $newHelpRef = 0; |
---|
607 | foreach (@helpfiles) { scanHelpFile($_); } |
---|
608 | } |
---|
609 | |
---|
610 | print "Scanned $LOC LOC.\n"; |
---|
611 | |
---|
612 | autouse($ARBHOME.'/HELP_SOURCE/oldhelp/unittest.hlp'); |
---|
613 | |
---|
614 | if (defined $ENV{GTK}) { # AFTERMERGE: remove this test and resource files below |
---|
615 | autouse($ARBHOME.'/lib/pictures/fileselect.fig'); # gtk version uses builtin fileselector |
---|
616 | autouse($ARBHOME.'/lib/pixmaps/no.xpm'); # gtk version uses builtin toggle |
---|
617 | autouse($ARBHOME.'/lib/pixmaps/yes.xpm'); # gtk version uses builtin toggle |
---|
618 | } |
---|
619 | |
---|
620 | my %unused = (); |
---|
621 | foreach (sort keys %known) { |
---|
622 | if (not defined $used{$_}) { $unused{$_} = 1; } |
---|
623 | } |
---|
624 | |
---|
625 | my $unused = scalar(keys %unused); |
---|
626 | |
---|
627 | if ($unused>0) { |
---|
628 | print "Detected $unused unused resources.\nRunning brute force scan..\n"; |
---|
629 | my $reg_unused = ''; |
---|
630 | foreach (keys %unused) { |
---|
631 | my $rel=$full2rel{$_}; |
---|
632 | if (defined $rel) { |
---|
633 | $reg_unused .= '|'.quotemeta($rel); |
---|
634 | } |
---|
635 | else { |
---|
636 | print "$_:0: Warning: possibly duplicate help in different dirs\n"; |
---|
637 | } |
---|
638 | } |
---|
639 | $reg_unused = substr($reg_unused,1); |
---|
640 | print "reg_unused='$reg_unused'\n"; |
---|
641 | $reg_unused = qr/$reg_unused/; |
---|
642 | |
---|
643 | my %seen_unused = (); |
---|
644 | foreach (@sources) { |
---|
645 | scanCodeFile_forUnuseds($_,$reg_unused, %seen_unused); |
---|
646 | } |
---|
647 | |
---|
648 | foreach (sort keys %unused) { |
---|
649 | my $rel = $full2rel{$_}; |
---|
650 | my $seen = (defined $rel) ? $seen_unused{$rel} : undef; |
---|
651 | if (defined $seen) { |
---|
652 | print "$_:0: Warning: Checker failed to detect resource usage\n"; |
---|
653 | my @seen = split(',',$seen); |
---|
654 | my %seen = map { $_ => 1; } @seen; |
---|
655 | foreach (sort keys %seen) { |
---|
656 | print "$_: Warning: '$rel' possibly used here\n"; |
---|
657 | } |
---|
658 | } |
---|
659 | else { |
---|
660 | print "$_:0: Error: Ressource is most likely unused\n"; |
---|
661 | $errors++; |
---|
662 | } |
---|
663 | } |
---|
664 | } |
---|
665 | else { |
---|
666 | print "All found resources are referenced from code :-)\n" |
---|
667 | } |
---|
668 | } |
---|
669 | |
---|
670 | sub main() { |
---|
671 | print "Checking ARB resources\n"; |
---|
672 | |
---|
673 | scanExistingRessources(); |
---|
674 | print ' - '.scalar(@pictures)." pictures\n"; |
---|
675 | print ' - '.scalar(@pixmaps)." images\n"; |
---|
676 | print ' - '.scalar(@helpfiles)." helpfiles\n"; |
---|
677 | |
---|
678 | scanCode(); |
---|
679 | if ($errors>0) { die "$errors errors detected by resource checker\n"; } |
---|
680 | } |
---|
681 | |
---|
682 | main(); |
---|