summaryrefslogtreecommitdiffstats
path: root/t/002goodperl.t
diff options
context:
space:
mode:
Diffstat (limited to 't/002goodperl.t')
-rw-r--r--t/002goodperl.t288
1 files changed, 152 insertions, 136 deletions
diff --git a/t/002goodperl.t b/t/002goodperl.t
index 80d7cf2b9..b2a9d5751 100644
--- a/t/002goodperl.t
+++ b/t/002goodperl.t
@@ -18,169 +18,185 @@ use lib qw(. lib local/lib/perl5 t);
use Support::Files;
-use Test::More tests => (scalar(@Support::Files::testitems)
- + scalar(@Support::Files::test_files)) * 6;
+use Test::More tests =>
+ (scalar(@Support::Files::testitems) + scalar(@Support::Files::test_files))
+ * 6;
my @testitems = (@Support::Files::test_files, @Support::Files::testitems);
my @require_taint = qw(email_in.pl importxml.pl mod_perl.pl whine.pl);
foreach my $file (@testitems) {
- $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
- next if (!$file); # skip null entries
- if (! open (FILE, $file)) {
- ok(0,"could not open $file --WARNING");
+ $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
+ next if (!$file); # skip null entries
+ if (!open(FILE, $file)) {
+ ok(0, "could not open $file --WARNING");
+ }
+ my $file_line1 = <FILE>;
+ close(FILE);
+
+ $file =~ m/.*\.(.*)/;
+ my $ext = $1;
+
+ if ($file_line1 !~ m/^#\!/) {
+ ok(1, "$file does not have a shebang");
+ }
+ else {
+ my $flags;
+ if (!defined $ext || $ext eq 'pl' || $ext eq 'psgi') {
+
+ # standalone programs aren't taint checked yet
+ if (grep { $file eq $_ } @require_taint) {
+ $flags = 'T';
+ }
+ else {
+ $flags = '';
+ }
}
- my $file_line1 = <FILE>;
- close (FILE);
-
- $file =~ m/.*\.(.*)/;
- my $ext = $1;
-
- if ($file_line1 !~ m/^#\!/) {
- ok(1,"$file does not have a shebang");
- } else {
- my $flags;
- if (!defined $ext || $ext eq 'pl' || $ext eq 'psgi') {
- # standalone programs aren't taint checked yet
- if (grep { $file eq $_ } @require_taint) {
- $flags = 'T';
- }
- else {
- $flags = '';
- }
- } elsif ($ext eq "pm") {
- ok(0, "$file is a module, but has a shebang");
- next;
- } elsif ($ext eq "cgi") {
- # cgi files must be taint checked
- $flags = 'T';
- } elsif ($ext eq 't') {
- $flags = '';
- } else {
- ok(0, "$file has shebang but unknown extension");
- next;
- }
-
- if ($file_line1 =~ m#^\#\!/usr/bin/perl(?:\s-(\w+))?$#) {
- my $file_flags = $1 || '';
- if ($flags eq $file_flags) {
- ok(1, "$file uses standard perl location" . ($flags ? " and -$flags flag" : ""));
- }
- elsif ($flags) {
- ok(0, "$file is MISSING -$flags flag --WARNING");
- }
- else {
- ok(0, "$file has unexpected -$file_flags flag --WARNING");
- }
- } else {
- ok(0,"$file uses non-standard perl location");
- }
+ elsif ($ext eq "pm") {
+ ok(0, "$file is a module, but has a shebang");
+ next;
}
-}
+ elsif ($ext eq "cgi") {
-foreach my $file (@testitems) {
- my $found_use_perl = 0;
- my $found_use_strict = 0;
- my $found_use_warnings = 0;
- my $found_modern_perl = 0;
- my $found_mojo = 0;
-
- $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
- next if (!$file); # skip null entries
- if (! open (FILE, $file)) {
- ok(0,"could not open $file --WARNING");
- next;
+ # cgi files must be taint checked
+ $flags = 'T';
}
- while (my $file_line = <FILE>) {
- $found_modern_perl = 1 if $file_line =~ m/^use\s*(?:Moo|Role::Tiny)/;
- $found_mojo = 1 if $file_line =~ m/^use\s(?:Mojo(?:licious::Lite|::Base)\b)/;
- $found_use_perl = 1 if $file_line =~ m/^\s*use 5.10.1/;
- $found_use_strict = 1 if $file_line =~ m/^\s*use strict/;
- $found_use_warnings = 1 if $file_line =~ m/^\s*use warnings/;
- if ($found_modern_perl || $found_mojo) {
- $found_use_strict = 1;
- $found_use_warnings = 1;
- }
- if ($found_mojo) {
- $found_use_perl = 1;
- }
- last if ($found_use_perl && $found_use_strict && $found_use_warnings);
+ elsif ($ext eq 't') {
+ $flags = '';
}
- close (FILE);
- if ($found_use_perl) {
- ok(1,"$file requires Perl 5.10.1");
- } else {
- ok(0,"$file DOES NOT require Perl 5.10.1 --WARNING");
+ else {
+ ok(0, "$file has shebang but unknown extension");
+ next;
}
- if ($found_use_strict) {
- ok(1,"$file uses strict");
- } else {
- ok(0,"$file DOES NOT use strict --WARNING");
+ if ($file_line1 =~ m#^\#\!/usr/bin/perl(?:\s-(\w+))?$#) {
+ my $file_flags = $1 || '';
+ if ($flags eq $file_flags) {
+ ok(1,
+ "$file uses standard perl location" . ($flags ? " and -$flags flag" : ""));
+ }
+ elsif ($flags) {
+ ok(0, "$file is MISSING -$flags flag --WARNING");
+ }
+ else {
+ ok(0, "$file has unexpected -$file_flags flag --WARNING");
+ }
+ }
+ else {
+ ok(0, "$file uses non-standard perl location");
}
+ }
+}
- if ($found_use_warnings) {
- ok(1,"$file uses warnings");
- } else {
- ok(0,"$file DOES NOT use warnings --WARNING");
+foreach my $file (@testitems) {
+ my $found_use_perl = 0;
+ my $found_use_strict = 0;
+ my $found_use_warnings = 0;
+ my $found_modern_perl = 0;
+ my $found_mojo = 0;
+
+ $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
+ next if (!$file); # skip null entries
+ if (!open(FILE, $file)) {
+ ok(0, "could not open $file --WARNING");
+ next;
+ }
+ while (my $file_line = <FILE>) {
+ $found_modern_perl = 1 if $file_line =~ m/^use\s*(?:Moo|Role::Tiny)/;
+ $found_mojo = 1 if $file_line =~ m/^use\s(?:Mojo(?:licious::Lite|::Base)\b)/;
+ $found_use_perl = 1 if $file_line =~ m/^\s*use 5.10.1/;
+ $found_use_strict = 1 if $file_line =~ m/^\s*use strict/;
+ $found_use_warnings = 1 if $file_line =~ m/^\s*use warnings/;
+ if ($found_modern_perl || $found_mojo) {
+ $found_use_strict = 1;
+ $found_use_warnings = 1;
+ }
+ if ($found_mojo) {
+ $found_use_perl = 1;
}
+ last if ($found_use_perl && $found_use_strict && $found_use_warnings);
+ }
+ close(FILE);
+ if ($found_use_perl) {
+ ok(1, "$file requires Perl 5.10.1");
+ }
+ else {
+ ok(0, "$file DOES NOT require Perl 5.10.1 --WARNING");
+ }
+
+ if ($found_use_strict) {
+ ok(1, "$file uses strict");
+ }
+ else {
+ ok(0, "$file DOES NOT use strict --WARNING");
+ }
+
+ if ($found_use_warnings) {
+ ok(1, "$file uses warnings");
+ }
+ else {
+ ok(0, "$file DOES NOT use warnings --WARNING");
+ }
}
# Check to see that all error messages use tags (for l10n reasons.)
foreach my $file (@testitems) {
- $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
- next if (!$file); # skip null entries
- if (! open (FILE, $file)) {
- ok(0,"could not open $file --WARNING");
- next;
- }
- my $lineno = 0;
- my $error = 0;
-
- while (!$error && (my $file_line = <FILE>)) {
- $lineno++;
- if ($file_line =~ /Throw.*Error\("(.*?)"/) {
- if ($1 =~ /\s/) {
- ok(0,"$file has a Throw*Error call on line $lineno
- which doesn't use a tag --ERROR");
- $error = 1;
- }
- }
+ $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
+ next if (!$file); # skip null entries
+ if (!open(FILE, $file)) {
+ ok(0, "could not open $file --WARNING");
+ next;
+ }
+ my $lineno = 0;
+ my $error = 0;
+
+ while (!$error && (my $file_line = <FILE>)) {
+ $lineno++;
+ if ($file_line =~ /Throw.*Error\("(.*?)"/) {
+ if ($1 =~ /\s/) {
+ ok(
+ 0, "$file has a Throw*Error call on line $lineno
+ which doesn't use a tag --ERROR"
+ );
+ $error = 1;
+ }
}
+ }
- ok(1,"$file uses Throw*Error calls correctly") if !$error;
+ ok(1, "$file uses Throw*Error calls correctly") if !$error;
- close(FILE);
+ close(FILE);
}
# Forbird the { foo => $cgi->param() } syntax, for security reasons.
foreach my $file (@testitems) {
- $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
- next unless $file; # skip null entries
- if (!open(FILE, $file)) {
- ok(0, "could not open $file --WARNING");
- next;
- }
- my $lineno = 0;
- my @unsafe_args;
-
- while (my $file_line = <FILE>) {
- $lineno++;
- $file_line =~ s/^\s*(.+)\s*$/$1/; # Remove leading and trailing whitespaces.
- if ($file_line =~ /^[^#]+=> \$cgi\->param/) {
- push(@unsafe_args, "$file_line on line $lineno");
- }
- }
-
- if (@unsafe_args) {
- ok(0, "$file incorrectly passes a CGI argument to a hash --ERROR\n" .
- join("\n", @unsafe_args));
+ $file =~ s/\s.*$//; # nuke everything after the first space (#comment)
+ next unless $file; # skip null entries
+ if (!open(FILE, $file)) {
+ ok(0, "could not open $file --WARNING");
+ next;
+ }
+ my $lineno = 0;
+ my @unsafe_args;
+
+ while (my $file_line = <FILE>) {
+ $lineno++;
+ $file_line =~ s/^\s*(.+)\s*$/$1/; # Remove leading and trailing whitespaces.
+ if ($file_line =~ /^[^#]+=> \$cgi\->param/) {
+ push(@unsafe_args, "$file_line on line $lineno");
}
- else {
- ok(1, "$file has no vulnerable hash syntax");
- }
-
- close(FILE);
+ }
+
+ if (@unsafe_args) {
+ ok(0,
+ "$file incorrectly passes a CGI argument to a hash --ERROR\n"
+ . join("\n", @unsafe_args));
+ }
+ else {
+ ok(1, "$file has no vulnerable hash syntax");
+ }
+
+ close(FILE);
}
exit 0;
generated by cgit v1.2.3-24-g4f1b (git 2.32.0) at 2024-05-03 06:58:02 +0200