diff options
| -rw-r--r-- | MDK/Common/Globals.pm | 6 | ||||
| -rwxr-xr-x | perl_checker | 324 |
2 files changed, 184 insertions, 146 deletions
diff --git a/MDK/Common/Globals.pm b/MDK/Common/Globals.pm index 15ca219..1bda892 100644 --- a/MDK/Common/Globals.pm +++ b/MDK/Common/Globals.pm @@ -1,3 +1,5 @@ +package MDK::Common::Globals; + =head1 NAME Shares constant values between modules @@ -13,12 +15,10 @@ Shares constant values between modules =cut -package MDK::Common::Globals; - sub import { my (undef, $name, @globals) = @_; foreach (@globals) { - $name =~ /^\$/ and die q(usage : use MDK::Common::Globals "group", qw($var1 $var2 ...);); + $name =~ /^\$/ and die qq(usage : use MDK::Common::Globals "group", qw(\$var1 \$var2 ...);\n); s/^\$// or die qq(bad parameter to "use MDK::Common::Globals": missing variable ``$_'' should be written ``\$$_''); #); no strict 'refs'; diff --git a/perl_checker b/perl_checker index 594fc98..26a30cb 100755 --- a/perl_checker +++ b/perl_checker @@ -1,23 +1,33 @@ -#!/usr/bin/perl -n +#!/usr/bin/perl -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; +sub begin { @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 CGI Net::FTP Gtk::XmHTML Gtk::Gdk Gtk::Gdk::ImlibImage Newt Newt::Component Newt::Grid DynaLoader IO::Socket Date::Manip packdrake); - while ($ARGV[0] =~ /-exclude(.*)/) { - push @exclude_uses, $1; - shift; + + while ($ARGV[0] =~ /-I(.*)/) { + push @I, $1; + shift @ARGV; + } + + $NO_CW = $ARGV[0] eq "-no_cw" and shift @ARGV; + $USES = $ARGV[0] eq "-uses" and shift @ARGV; + + + @I = ('.', '..'); + + foreach (@I) { + open F, "$_/.perl_checker" or next; + foreach (<F>) { + chomp; + push @exclude_uses, $_; + } } + + unshift @INC, @I; @exclude_uses{@exclude_uses} = undef; if (!$NO_CW) { @@ -26,154 +36,181 @@ BEGIN { $? == 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; - -$explicit_no_warning = /#-#/; - -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; -} - - -if (/\(\s+[^#\s({\[]/ && !/qq\(/) { - warn_(q(spurious space after opening parenthesis), info()); } -if (/[^#\s)}\]]\s+\)/) { - warn_(q(spurious space before closing parenthesis), info()); -} +begin(); -if (/;([^\s\\].{0,10})/ && !/^sub/ && !/;-\)/ && !/=~/ && !/^\s+;;$/) { - warn_(qq(missing space after ";$1"), info()); -} +while (@ARGV) { + $ARGV = shift @ARGV; -if (/;\s*\}/) { - warn_(q(spurious ";" before closing block), info()); -} + $package = 'main'; + $. = 0; + open F, $ARGV or die "can't open file $ARGV\n"; + while (<F>) { + chop; -if (/(.*\s\{)[^\s{}]/ && !/\{[\d,]+\}/ && !/Usage:/) { #- eg of Usage: cmd {foo|bar} - warn_(qq(missing space after "$1"), info()); -} + if ($. == 1 && $ARGV =~ /\.pm$/ && !/^package\b/) { + warn_(qq(module $ARGV does not have "package xxxx;" on its first line), info()); + } -if (/\{\s[^{}]*[^\s{}]\}/) { - warn_(qq(missing space before "}$'"), info()); -} + if (/^# perl_checker: RE-EXPORT-ALL/) { + push @re_exported, $package; + } -if (/%_\W/ || /[^@]\$_{/) { - err(q(do not use %_), info()); -} -if (/\$_\s*=~/) { - warn_(q(``$_ =~ /regexp/'' can be written ``/regexp/''), info()); -} -if (/\$_\s*!~/) { - warn_(q(``$_ !~ /regexp/'' can be written ``!/regexp/''), info()); -} -if (/my \$\w+\s*=~/ || /my \(\$\w+\)\s*=~/) { - err(q(applying =~ on a new initialized variable is wrong), info()); -} -if (/[}>]{(['"])([a-z][a-z0-9_]*)\1}/i) { - warn_(qq(``{$1$2$1}'' can be written ``{$2}''), info()) - if $2 ne 'x' && $2 ne 'y'; - # special case for {'y'} otherwise the emacs mode goes wild - # special case for {'x'} to have the same as {'y'} (since they usually go together) -} -if (/%\$\w+(->|\{)/ || /%\{([^{}]|\{[^{}]*\})*\}(->|\{)/ || - /@\$\w+->/ || /@\{([^{}]|\{[^{}]*\})*\}->/) { - err(q(bad expression, tell pixel@mandrakesoft.com), info()); -} + /^=head/ .. /^=cut/ and next; + /^\s*#/ and next; -s/"[^"]*"//g; #" -s/'[^']*'//g; #' -s/\bm\b(.)(.*?)\1//g; # m// operator: "m/re/", "m|re|", ... -s/\bs\b(.)(.*?)\1(.*?)\1//g; # s/// operator: "s/re/.../", "s|re|...|", ... -s|\(/.*?/|(|g; # m// operator: "(/re/" -s{([!=]~|\bif\b)\s*/.*?/}{}g; # m// operator: "if /re/", "=~ /re/", "!~ /re/" + $explicit_no_warning = /#-#/; -s/#.*//; + 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; + } -if (/\blength(\s*|\()\@/) { - err(q(never use ``length @l'', it returns the length of the string int(@l)), info()); -} + syntax_warnings(); + drop_strings_and_regexps(); + syntax_warnings_after_removing_strings_and_regexps(); + get_exports(); -if (/\blocal\b.*\|\|=/) { - err(q(never use ``local $var ||= <val>'', write ``local $var = $var || <val>''), 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); } + + + /^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; + } + close F; } -if (/\bsub\b\s*\{[^{}]*\$_(?!\[)/) { - warn_(q(using $_ in a sub is generally bad news), info()) if !/local\s+\$_/; -} +$explicit_no_warning = 0; +end(); -if ((my ($op) = /([<>]{2})/) && (/[+-]\s*[\w\$]+\s*[<>]{2}/ || /[<>]{2}\s*[\w\$]+\s*[+-]/) && !/\<\<[A-Z]/) { # don't warn for here-document alike - err(qq(parentheses needed around operator $op), info()); -} -if (/=.*:\s*\$\w+\s*=/) { - err(q(do not use ``cond ? $v1 = XX1 : $v2 = XX2'' which is parsed as ``(cond ? $v1 = XX1 : $v2) = XX2''), info()); +sub drop_strings_and_regexps { + s/"[^"]*"/"foo"/g; #" + s/'[^']*'/'foo'/g; #' + s/\bqq\([^)]*\)/'foo'/g; + s/\bm\b(.)(.*?)\1/m!foo!/g; # m// operator: "m/re/", "m|re|", ... + s/\bs\b(.)(.*?)\1(.*?)\1/s!foo!bar!/g; # s/// operator: "s/re/.../", "s|re|...|", ... + s|\(/.*?/|(/foo/|g; # m// operator: "(/re/" + s{([!=]~|\bif\b)\s*/.*?/}{$1 /foo/}g; # m// operator: "if /re/", "=~ /re/", "!~ /re/" + + s/#.*//; } -if (/^\s*package ([\w:]+)/) { - $package = $1; - $path{$package} ||= ($ARGV =~ m|(.*/)|)[0]; +sub get_exports { + 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(); + } } - -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(); +sub syntax_warnings { + if (/^\s*my\b[^;]*=\s*(\(\)|undef);/) { + warn_(q(no need to initialize variables, it's done by default), info()); + } + + if (/[^#\s)}\]]\s+\)/) { + warn_(q(spurious space before closing parenthesis), info()); + } + + if (/;\s*\}/) { + warn_(q(spurious ";" before closing block), info()); + } + + if (/(.*\s\{)[^\s{}]/ && !/\{[\d,]+\}/ && !/Usage:/) { #- eg of Usage: cmd {foo|bar} + warn_(qq(missing space after "$1"), info()); + } + + if (/\{\s[^{}]*[^\s{}]\}/) { + warn_(qq(missing space before "}$'"), info()); + } + + if (/%_\W/ || /[^@]\$_{/) { #-# + err(q(do not use %_), info()); #-# + } + if (/\$_\s*=~/) { + warn_(q(``$_ =~ /regexp/'' can be written ``/regexp/''), info()); + } + if (/\$_\s*!~/) { + warn_(q(``$_ !~ /regexp/'' can be written ``!/regexp/''), info()); + } + if (/my \$\w+\s*=~/ || /my \(\$\w+\)\s*=~/) { + err(q(applying =~ on a new initialized variable is wrong), info()); + } + if (/[}>]{(['"])([a-z][a-z0-9_]*)\1}/i) { + warn_(qq(``{$1$2$1}'' can be written ``{$2}''), info()) + if $2 ne 'x' && $2 ne 'y'; + # special case for {'y'} otherwise the emacs mode goes wild + # special case for {'x'} to have the same as {'y'} (since they usually go together) + } + if (/%\$\w+(->|\{)/ || /%\{([^{}]|\{[^{}]*\})*\}(->|\{)/ || + /@\$\w+->/ || /@\{([^{}]|\{[^{}]*\})*\}->/) { + err(q(bad expression, tell pixel@mandrakesoft.com), info()); + } + + if (/\blength(\s*|\()\@/) { + err(q(never use ``length @l'', it returns the length of the string int(@l)), info()); + } + + if (/\blocal\b.*\|\|=/) { + err(q(never use ``local $var ||= <val>'', write ``local $var = $var || <val>''), info()); + } + + if (/\bsub\b\s*\{[^{}]*\$_(?!\[)/) { + warn_(q(using $_ in a sub is generally bad news), info()) if !/local\s+\$_/; + } + + if ((my ($op) = /([<>]{2})/) && (/[+-]\s*[\w\$]+\s*[<>]{2}/ || /[<>]{2}\s*[\w\$]+\s*[+-]/) && !/\<\<[A-Z]/) { # don't warn for here-document alike + err(qq(parentheses needed around operator $op), info()); + } + if (/=.*:\s*\$\w+\s*=/) { + err(q(do not use ``cond ? $v1 = XX1 : $v2 = XX2'' which is parsed as ``(cond ? $v1 = XX1 : $v2) = XX2''), 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; +sub syntax_warnings_after_removing_strings_and_regexps { + if (/([\$@%]\w+=)[^~]/) { + warn_(qq(missing space before "=" in $1), info()); + } + + if (/\(\s+[^#\s({\[]/) { + warn_(q(spurious space after opening parenthesis), info()); + } -if (eof) { - $. = 0; -# $package = "_ano_$ARGV[0]"; + if (/;([^\s\\].{0,10})/ && !/^sub/ && !/;-\)/ && !/^\s+;;$/) { + warn_(qq(missing space after ";$1"), info()); + } } sub add_call { @@ -227,7 +264,7 @@ sub add_use { # $usevar_info{$package}->{$_[0]} = info(); #} -sub info { +{ file => $ARGV, line => $. } } +sub info { { file => $ARGV, line => $. } } sub updirs { my ($p, $i) = @_; @@ -238,14 +275,15 @@ sub updirs { sub err { + return if $explicit_no_warning; + $ERR = 1; &warn_; } sub warn_ { - my ($m, $i) = @_; - return if $explicit_no_warning; + my ($m, $i) = @_; if ($i) { print STDERR "$i->{file}:$i->{line}: $m\n"; } else { @@ -253,7 +291,7 @@ sub warn_ { } } -END { +sub end { foreach my $package (reverse @re_exported) { my $h = $export{$package} ||= {}; %$h = (%$h, |