Websites/bugs.webkit.org/t/002goodperl.t

# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0. If a copy of the MPL was not distributed with this
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
#
# This Source Code Form is "Incompatible With Secondary Licenses", as
# defined by the Mozilla Public License, v. 2.0.


#################
#Bugzilla Test 2#
####GoodPerl#####

use 5.10.1;
use strict;
use warnings;

use lib 't';

use Support::Files;

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");
    }
    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") {
            # 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';
        } 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");
        }
    }
}

foreach my $file (@testitems) {
    my $found_use_perl = 0;
    my $found_use_strict = 0;
    my $found_use_warnings = 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_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/;
        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;       
            }
        }
    }
    
    ok(1,"$file uses Throw*Error calls correctly") if !$error;
    
    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));
    }
    else {
        ok(1, "$file has no vulnerable hash syntax");
    }

    close(FILE);
}

exit 0;