1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
#!/usr/bin/perl -n
BEGIN {
while ($ARGV[0] =~ /-I(.*)/) {
push @I, $1;
shift;
}
unshift @INC, @I;
$NO_CW = $ARGV[0] eq "-no_cw" and shift;
$USES = $ARGV[0] eq "-uses" and shift;
@exclude_calls = qw(chomp chop chr crypt hex index lc lcfirst length oct ord pack reverse rindex sprintf substr uc ucfirst pos quotemeta split study abs atan2 cos exp hex int log oct rand sin sqrt srand pop push shift splice unshift grep join map reverse sort unpack delete each exists keys values binmode close closedir dbmclose dbmopen die eof fileno flock format getc print printf read readdir rewinddir seek seekdir select syscall sysread sysseek syswrite tell telldir truncate warn write pack read syscall sysread syswrite unpack vec chdir chmod chown chroot fcntl glob ioctl link lstat mkdir open opendir readlink rename rmdir stat symlink umask unlink utime caller continue die do dump eval exit goto last next redo return sub wantarray caller import local my package use defined dump eval formline local my reset scalar undef wantarray alarm exec fork getpgrp getppid getpriority kill pipe setpgrp setpriority sleep system times wait waitpid do import no package require use bless dbmclose dbmopen package ref tie tied untie use accept bind connect getpeername getsockname getsockopt listen recv send setsockopt shutdown socket socketpair msgctl msgget msgrcv msgsnd semctl semget semop shmctl shmget shmread shmwrite endgrent endhostent endnetent endpwent getgrent getgrgid getgrnam getlogin getpwent getpwnam getpwuid setgrent setpwent endprotoent endservent gethostbyaddr gethostbyname gethostent getnetbyaddr getnetbyname getnetent getprotobyname getprotobynumber getprotoent getservbyname getservbyport getservent sethostent setnetent setprotoent setservent gmtime localtime time times abs bless chomp chr exists formline glob import lc lcfirst map my no prototype qx qw readline readpipe ref sysopen tie tied uc ucfirst untie use qq Dumper packdrake Eth);
@exclude_calls{@exclude_calls} = undef;
@exclude_uses = qw(globals diagnostics strict vars lib Carp Config Exporter Socket Locale::GetText CORE POSIX Gtk Data::Dumper Net::FTP Gtk::XmHTML Gtk::Gdk Gtk::Gdk::ImlibImage Newt Newt::Component Newt::Grid DynaLoader IO::Socket packdrake);
while ($ARGV[0] =~ /-exclude(.*)/) {
push @exclude_uses, $1;
shift;
}
@exclude_uses{@exclude_uses} = undef;
if (!$NO_CW) {
foreach (@ARGV) {
system("perl", (map {; "-I", $_ } @I), "-cw", $_);
$? == 0 or die "perl -cw $_ failed\n";
}
}
$package = 'main';
}
chop;
if (/^# perl_checker: RE-EXPORT-ALL/) {
push @re_exported, $package;
}
/^=head/ .. /^=cut/ and next;
/^\s*#/ and next;
if (/^\s*require\s+([\w:]+);/) {
add_use($1);
} elsif (my ($r) = /^\s*require (.*)/) {
$r =~ /'(.*)'/ or err("<<$_>> should be formatted like <<require 'PACKAGE.pm'>>", info());
$r =~ m|'([^/]*)\.pm'| and add_use($1);
next;
}
s/"[^"]*"//g; #"
s/'[^']*'//g; #'
s/\bm\b(.)(.*?)\1//g; # m// operator
s|\(/.*?/|(|g; # m// operator
s{([!=]~|\bif\b)\s*/.*?/}{}g;
s/#.*//;
if (/\blocal\b.*\|\|=/) {
err(q(never use ``local $var ||= <val>'', write ``local $var = $var || <val>''), info());
}
if (/^\s*package ([\w:]+)/) {
$package = $1;
$path{$package} ||= ($ARGV =~ m|(.*/)|)[0];
}
if (/\@EXPORT = qw\((.*)\)/) {
@{$export{$package}}{split ' ', $1} = undef;
}
if (/\@EXPORT_OK = qw\((.*)\)/) {
@{$export_ok{$package}}{split ' ', $1} = undef;
$export_info{$package} = info();
}
if (/%EXPORT_TAGS = \((\w+) => \[ \@EXPORT_OK \]\)/) {
$export_tags{$package}->{$1} = $export_ok{$package};
}
if (/%EXPORT_TAGS = \(\s*$/ .. /^\);$/) {
/\s+(\w+)\s+.*?qw\((.*)\)/;
@{$export_tags{$package}->{$1}}{split ' ', $2} = undef;
$export_tags_info{$package}->{$1} = info();
}
while (/(^|[^\$@\w:>]) # first a char
((\w|:)*\w) # function name
(?=\() # a open parenthesis (zero-width lookahead)
/gx) { add_call($2) unless /$2\(s\)/ } # special case xxxx(s) excluded cuz' of strings containing it
while (/&([\w:]+)/g) { add_call($1); }
#while (/\$(\w+)/g) { add_usevar($1); }
#
#if (/\bmy\b\s*\(?([^=;)]*)/) {
# map {
# s/[ \$@%]//g;
# $defvar{$package}->{$_} = 1;
# } split ',', $1;
#}
/^use\s+([\w:]+);/ and add_use($1);
if (my ($p, $v) = /^use\s([\w:]+)\s+(.*)/) {
$v =~ /^qw\((.*?)\)/ ? add_use($p, $1) : err("<<$_>> should be written <<use $p qw(:A :B ...)>>", info())
if !exists $exclude_uses{$p};
}
if (my ($p, $v) = /^\s*(\S+)->import\((.*)\)/) {
$v =~ /^qw\((.*?)\)/ ? add_use($p, $1) : err("<<$_>> should be written << $p->import(qw(:A :B ...))>>", info());
}
/^\s*sub\s+(\w+)/ and $sub{$package}->{$1} = 1;
if (eof) {
$. = 0;
# $package = "_ano_$ARGV[0]";
}
sub add_call {
$_[0] =~ /^\d/ and return;
exists $exclude_calls{$_[0]} and return;
$call{$package}->{$_[0]} = 1;
$call_info{$package}->{$_[0]} = info()
}
sub add_use {
my ($p, $op) = @_;
exists $exclude_uses{$p} and return;
warn_("uses $p", info()) if $USES;
my $already = $use_info{$package}->{$p};
# warn_("reused " . $already->{file} . " " . $already->{line}, info()) if $already && $ARGV ne $already->{file};
$use{$package}->{$p} = [ @{$use{$package}->{$p}}, split ' ', $op ];
$use_info{$package}->{$p} = info();
$path{$p} and return;
my ($path, $f) = "$p.pm" =~ /(.*::)?(.*)/;
$path =~ s|::|/|g;
$path{$p} = updirs($path{$package}, (($package =~ tr/://) / 2));
foreach ($path{$p}, @INC) {
$_ .= "/" if !m|/$|;
my $file = "$_$path$f";
if (-e $file) {
push @ARGV, $file;
$file2package{$file} = $p;
return;
}
}
err("can't find package $p", info());
}
#sub add_usevar {
# length $_[0] <= 3 and return;
# $usevar{$package}->{$_[0]} = 1;
# $usevar_info{$package}->{$_[0]} = info();
#}
sub info { +{ file => $ARGV, line => $. } }
sub updirs {
my ($p, $i) = @_;
for (; $i && $p =~ s|[^/]+/^||; $i--) {}
for (; $i ; $i--) { $p .= "../"; }
$p;
}
sub err {
$ERR = 1;
&warn_;
}
sub warn_ {
my ($m, $i) = @_;
if ($i) {
print STDERR "$i->{file}:$i->{line}: $m\n";
} else {
print STDERR "$m\n";
}
}
END {
foreach my $package (reverse @re_exported) {
my $h = $export{$package} ||= {};
foreach (keys %{$use{$package}}) {
%$h = (%$h, %{$export{$_}}, map { %$_ } values %{$export_tags{$_}});
}
}
while (my ($package, $v) = each %use) {
while (my ($k, $s) = each %$v) {
@$s and defined($export_tags{$k}) || err("package $k does not export tags");
foreach (@$s) {
s/\"//g;
s/^:// or err("<<use $k qw(@$s ...)>> should be <<use $k qw(:@$s ...)>>", $use_info{$package}->{$k});
exists $export_tags{$k}->{$_} or err("package $k does not export tag $_", $use_info{$package}->{$k});
}
}
}
# while (my ($package, $vars) = each %usevar) {
# my @l = grep { ! $defvar{$package}->{$_} } keys %$vars;
# @l and print "$package: uses vars (", join(' ', @l), ")";
# }
while (my ($package, $calls) = each %call) {
here: foreach my $func_verbatim (keys %$calls) {
my ($pkg, $func) = do {
if ($func_verbatim =~ /(.*)::(.*)/) {
exists $exclude_uses{$1} and next;
exists $use{$package}->{$1} or err("you must <<use $1>> for function $2", $call_info{$package}->{$func_verbatim});
$1, $2;
} else {
$package, $func_verbatim;
}
};
$sub{$pkg}->{$func} and next; # defined in own package
foreach my $k (keys %{$use{$pkg}}) {
exists $export{$k}->{$func} and next here; # ok, exported by $k
foreach (@{$use{$pkg}->{$k}}) {
exists $export_tags{$k}->{$_}->{$func} and next here; # ok, exported by $k in tag $_
}
}
err("$func_verbatim undefined", $call_info{$package}->{$func_verbatim}) if length $func_verbatim > 1;
}
}
$ERR and exit $ERR;
}
|
