--- /dev/null
- if ($^O eq 'linux') {
- print "ok 6 # Skip: sigaction() broken in $^O\n";
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC, '../lib';
+}
+
+BEGIN{
+ # Don't do anything if POSIX is missing, or sigaction missing.
+ eval { use POSIX; };
+ if($@ || $^O eq 'MSWin32' || $^O eq 'NetWare') {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use strict;
+use vars qw/$bad7 $ok10 $bad18 $ok/;
+
+$^W=1;
+
+print "1..18\n";
+
+sub IGNORE {
+ $bad7=1;
+}
+
+sub DEFAULT {
+ $bad18=1;
+}
+
+sub foo {
+ $ok=1;
+}
+
+my $newaction=POSIX::SigAction->new('::foo', new POSIX::SigSet(SIGUSR1), 0);
+my $oldaction=POSIX::SigAction->new('::bar', new POSIX::SigSet(), 0);
+
+{
+ my $bad;
+ local($SIG{__WARN__})=sub { $bad=1; };
+ sigaction(SIGHUP, $newaction, $oldaction);
+ if($bad) { print "not ok 1\n" } else { print "ok 1\n"}
+}
+
+if($oldaction->{HANDLER} eq 'DEFAULT' ||
+ $oldaction->{HANDLER} eq 'IGNORE')
+ { print "ok 2\n" } else { print "not ok 2 # ", $oldaction->{HANDLER}, "\n"}
+print $SIG{HUP} eq '::foo' ? "ok 3\n" : "not ok 3\n";
+
+sigaction(SIGHUP, $newaction, $oldaction);
+if($oldaction->{HANDLER} eq '::foo')
+ { print "ok 4\n" } else { print "not ok 4\n"}
+if($oldaction->{MASK}->ismember(SIGUSR1))
+ { print "ok 5\n" } else { print "not ok 5\n"}
+if($oldaction->{FLAGS}) {
++ if ($^O eq 'linux' || $^O eq 'unicos') {
++ print "ok 6 # Skip: sigaction() thinks different in $^O\n";
+ } else {
+ print "not ok 6\n";
+ }
+} else {
+ print "ok 6\n";
+}
+
+$newaction=POSIX::SigAction->new('IGNORE');
+sigaction(SIGHUP, $newaction);
+kill 'HUP', $$;
+print $bad7 ? "not ok 7\n" : "ok 7\n";
+
+print $SIG{HUP} eq 'IGNORE' ? "ok 8\n" : "not ok 8\n";
+sigaction(SIGHUP, POSIX::SigAction->new('DEFAULT'));
+print $SIG{HUP} eq 'DEFAULT' ? "ok 9\n" : "not ok 9\n";
+
+$newaction=POSIX::SigAction->new(sub { $ok10=1; });
+sigaction(SIGHUP, $newaction);
+{
+ local($^W)=0;
+ kill 'HUP', $$;
+}
+print $ok10 ? "ok 10\n" : "not ok 10\n";
+
+print ref($SIG{HUP}) eq 'CODE' ? "ok 11\n" : "not ok 11\n";
+
+sigaction(SIGHUP, POSIX::SigAction->new('::foo'));
+# Make sure the signal mask gets restored after sigaction croak()s.
+eval {
+ my $act=POSIX::SigAction->new('::foo');
+ delete $act->{HANDLER};
+ sigaction(SIGINT, $act);
+};
+kill 'HUP', $$;
+print $ok ? "ok 12\n" : "not ok 12\n";
+
+undef $ok;
+# Make sure the signal mask gets restored after sigaction returns early.
+my $x=defined sigaction(SIGKILL, $newaction, $oldaction);
+kill 'HUP', $$;
+print !$x && $ok ? "ok 13\n" : "not ok 13\n";
+
+$SIG{HUP}=sub {};
+sigaction(SIGHUP, $newaction, $oldaction);
+print ref($oldaction->{HANDLER}) eq 'CODE' ? "ok 14\n" : "not ok 14\n";
+
+eval {
+ sigaction(SIGHUP, undef, $oldaction);
+};
+print $@ ? "not ok 15\n" : "ok 15\n";
+
+eval {
+ sigaction(SIGHUP, 0, $oldaction);
+};
+print $@ ? "not ok 16\n" : "ok 16\n";
+
+eval {
+ sigaction(SIGHUP, bless({},'Class'), $oldaction);
+};
+print $@ ? "ok 17\n" : "not ok 17\n";
+
+if ($^O eq 'VMS') {
+ print "ok 18 # Skip: SIGCONT not trappable in $^O\n";
+} else {
+ $newaction=POSIX::SigAction->new(sub { $ok10=1; });
+ if (eval { SIGCONT; 1 }) {
+ sigaction(SIGCONT, POSIX::SigAction->new('DEFAULT'));
+ {
+ local($^W)=0;
+ kill 'CONT', $$;
+ }
+ }
+ print $bad18 ? "not ok 18\n" : "ok 18\n";
+}
+
--- /dev/null
-my $fname = $0;
-$fname =~ tr/<>-/\253\273\255/; # _warn does this so we have to also
-is( $fake_out, "<!-- warning: There is a problem at $fname line 95. -->\n",
+ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 2 -*-
+ #!/usr/local/bin/perl -w
+
+ use strict;
+ use lib qw(t/lib);
+ use Test::More tests => 42;
+ use IO::Handle;
+
+ BEGIN { use_ok('CGI::Carp') };
+
+ #-----------------------------------------------------------------------------
+ # Test id
+ #-----------------------------------------------------------------------------
+
+ # directly invoked
+ my $expect_f = __FILE__;
+ my $expect_l = __LINE__ + 1;
+ my ($file, $line, $id) = CGI::Carp::id(0);
+ is($file, $expect_f, "file");
+ is($line, $expect_l, "line");
+ is($id, "carp.t", "id");
+
+ # one level of indirection
+ sub id1 { my $level = shift; return CGI::Carp::id($level); };
+
+ $expect_l = __LINE__ + 1;
+ ($file, $line, $id) = id1(1);
+ is($file, $expect_f, "file");
+ is($line, $expect_l, "line");
+ is($id, "carp.t", "id");
+
+ # two levels of indirection
+ sub id2 { my $level = shift; return id1($level); };
+
+ $expect_l = __LINE__ + 1;
+ ($file, $line, $id) = id2(2);
+ is($file, $expect_f, "file");
+ is($line, $expect_l, "line");
+ is($id, "carp.t", "id");
+
+ #-----------------------------------------------------------------------------
+ # Test stamp
+ #-----------------------------------------------------------------------------
+
+ my $stamp = "/^\\[
+ ([a-z]{3}\\s){2}\\s?
+ [\\s\\d:]+
+ \\]\\s$id:/ix";
+
+ like(CGI::Carp::stamp(),
+ $stamp,
+ "Time in correct format");
+
+ sub stamp1 {return CGI::Carp::stamp()};
+ sub stamp2 {return stamp1()};
+
+ like(stamp2(), $stamp, "Time in correct format");
+
+ #-----------------------------------------------------------------------------
+ # Test warn and _warn
+ #-----------------------------------------------------------------------------
+
+ # set some variables to control what's going on.
+ $CGI::Carp::WARN = 0;
+ $CGI::Carp::EMIT_WARNINGS = 0;
+ @CGI::Carp::WARNINGS = ();
+ my $q_file = quotemeta($file);
+
+
+ # Test that realwarn is called
+ {
+ local $^W = 0;
+ eval "sub CGI::Carp::realwarn {return 'Called realwarn'};";
+ }
+
+ $expect_l = __LINE__ + 1;
+ is(CGI::Carp::warn("There is a problem"),
+ "Called realwarn",
+ "CGI::Carp::warn calls CORE::warn");
+ is(@CGI::Carp::WARNINGS, 0, "_warn not called");
+
+ # Test that message is constructed correctly
+ eval 'sub CGI::Carp::realwarn {my $mess = shift; return $mess};';
+
+ $expect_l = __LINE__ + 1;
+ like(CGI::Carp::warn("There is a problem"),
+ "/] $id: There is a problem at $q_file line $expect_l.".'$/',
+ "CGI::Carp::warn builds correct message");
+ is(@CGI::Carp::WARNINGS, 0, "_warn not called");
+
+ # Test that _warn is called at the correct time
+ $CGI::Carp::WARN = 1;
+
+ $expect_l = __LINE__ + 1;
+ like(CGI::Carp::warn("There is a problem"),
+ "/] $id: There is a problem at $q_file line $expect_l.".'$/',
+ "CGI::Carp::warn builds correct message");
+
+ is(@CGI::Carp::WARNINGS, 1, "_warn now called");
+ like($CGI::Carp::WARNINGS[0],
+ "/There is a problem at $q_file line $expect_l.".'$/',
+ "CGI::Carp::WARNINGS has correct message (without stamp)");
+
+ #-----------------------------------------------------------------------------
+ # Test ineval
+ #-----------------------------------------------------------------------------
+
+ ok(!CGI::Carp::ineval, 'ineval returns false when not in eval');
+ eval {ok(CGI::Carp::ineval, 'ineval returns true when in eval');};
+
+ #-----------------------------------------------------------------------------
+ # Test die
+ #-----------------------------------------------------------------------------
+
+ # set some variables to control what's going on.
+ $CGI::Carp::WRAP = 0;
+
+ $expect_l = __LINE__ + 1;
+ eval { CGI::Carp::die('There is a problem'); };
+ like($@,
+ '/^There is a problem/',
+ 'CGI::Carp::die calls CORE::die without altering argument in eval');
+
+ # Test that realwarn is called
+ {
+ local $^W = 0;
+ eval 'sub CGI::Carp::realdie {my $mess = shift; return $mess};';
+ }
+
+ like(CGI::Carp::die('There is a problem'),
+ $stamp,
+ 'CGI::Carp::die calls CORE::die, but adds stamp');
+
+ #-----------------------------------------------------------------------------
+ # Test set_message
+ #-----------------------------------------------------------------------------
+
+ is(CGI::Carp::set_message('My new Message'),
+ 'My new Message',
+ 'CGI::Carp::set_message returns new message');
+
+ is($CGI::Carp::CUSTOM_MSG,
+ 'My new Message',
+ 'CGI::Carp::set_message message set correctly');
+
+ # set the message back to the empty string so that the tests later
+ # work properly.
+ CGI::Carp::set_message(''),
+
+ #-----------------------------------------------------------------------------
+ # Test warnings_to_browser
+ #-----------------------------------------------------------------------------
+
+ CGI::Carp::warningsToBrowser(0);
+ is($CGI::Carp::EMIT_WARNINGS, 0, "Warnings turned off");
+ unless( is(@CGI::Carp::WARNINGS, 1, "_warn not called") ) {
+ print join "\n", map "'$_'", @CGI::Carp::WARNINGS;
+ }
+
+ # turn off STDOUT (prevents spurious warnings to screen
+ tie *STDOUT, 'StoreStuff' or die "Can't tie STDOUT";
+ CGI::Carp::warningsToBrowser(1);
+ my $fake_out = join '', <STDOUT>;
+ untie *STDOUT;
+
+ open(STDOUT, ">&REAL_STDOUT");
++is( $fake_out, "<!-- warning: There is a problem at $0 line 95. -->\n",
+ 'warningsToBrowser() on' );
+
+ is($CGI::Carp::EMIT_WARNINGS, 1, "Warnings turned off");
+ is(@CGI::Carp::WARNINGS, 0, "_warn is called");
+
+ #-----------------------------------------------------------------------------
+ # Test fatals_to_browser
+ #-----------------------------------------------------------------------------
+
+ package StoreStuff;
+
+ sub TIEHANDLE {
+ my $class = shift;
+ bless [], $class;
+ }
+
+ sub PRINT {
+ my $self = shift;
+ push @$self, @_;
+ }
+
+ sub READLINE {
+ my $self = shift;
+ shift @$self;
+ }
+
+ package main;
+
+ tie *STDOUT, "StoreStuff";
+
+ # do tests
+ my @result;
+
+ CGI::Carp::fatalsToBrowser();
+ $result[0] .= $_ while (<STDOUT>);
+
+ CGI::Carp::fatalsToBrowser('Message to the world');
+ $result[1] .= $_ while (<STDOUT>);
+
+ $ENV{SERVER_ADMIN} = 'foo@bar.com';
+ CGI::Carp::fatalsToBrowser();
+ $result[2] .= $_ while (<STDOUT>);
+
+ CGI::Carp::set_message('Override the message passed in'),
+
+ CGI::Carp::fatalsToBrowser('Message to the world');
+ $result[3] .= $_ while (<STDOUT>);
+ CGI::Carp::set_message(''),
+ delete $ENV{SERVER_ADMIN};
+
+ # now restore STDOUT
+ untie *STDOUT;
+
+
+ like($result[0],
+ '/Content-type: text/html/',
+ "Default string has header");
+
+ ok($result[0] !~ /Message to the world/, "Custom message not in default string");
+
+ like($result[1],
+ '/Message to the world/',
+ "Custom Message appears in output");
+
+ ok($result[0] !~ /foo\@bar.com/, "Server Admin does not appear in default message");
+
+ like($result[2],
+ '/foo@bar.com/',
+ "Server Admin appears in output");
+
+ like($result[3],
+ '/Message to the world/',
+ "Custom message not in result");
+
+ like($result[3],
+ '/Override the message passed in/',
+ "Correct message in string");
+
+ #-----------------------------------------------------------------------------
+ # Test to_filehandle
+ #-----------------------------------------------------------------------------
+
+ sub buffer {
+ CGI::Carp::to_filehandle (@_);
+ }
+
+ tie *STORE, "StoreStuff";
+
+ require FileHandle;
+ my $fh = FileHandle->new;
+
+ ok( defined buffer(\*STORE), '\*STORE returns proper filehandle');
+ ok( defined buffer( $fh ), '$fh returns proper filehandle');
+ ok( defined buffer('::STDOUT'), 'STDIN returns proper filehandle');
+ ok( defined buffer(*main::STDOUT), 'STDIN returns proper filehandle');
+ ok(!defined buffer("WIBBLE"), '"WIBBLE" doesn\'t returns proper filehandle');
--- /dev/null
- my $NonTaintedCwd = $^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'os2';
-
+#!./perl -T
+
+
+my %Expect_File = (); # what we expect for $_
+my %Expect_Name = (); # what we expect for $File::Find::name/fullname
+my %Expect_Dir = (); # what we expect for $File::Find::dir
+my $symlink_exists = eval { symlink("",""); 1 };
+my $cwd;
+my $cwd_untainted;
+
+use Config;
+
+BEGIN {
+ chdir 't' if -d 't';
+ unshift @INC => '../lib';
+
+ for (keys %ENV) { # untaint ENV
+ ($ENV{$_}) = $ENV{$_} =~ /(.*)/;
+ }
+
+ # Remove insecure directories from PATH
+ my @path;
+ my $sep = $Config{path_sep};
+ foreach my $dir (split(/\Q$sep/,$ENV{'PATH'}))
+ {
+ ##
+ ## Match the directory taint tests in mg.c::Perl_magic_setenv()
+ ##
+ push(@path,$dir) unless (length($dir) >= 256
+ or
+ substr($dir,0,1) ne "/"
+ or
+ (stat $dir)[2] & 002);
+ }
+ $ENV{'PATH'} = join($sep,@path);
+}
+
+
+if ( $symlink_exists ) { print "1..45\n"; }
+else { print "1..27\n"; }
+
+use File::Find;
+use File::Spec;
+use Cwd;
+
+
- if ($NonTaintedCwd) {
- Skip("$^O does not taint cwd");
- }
- else {
- Check( $@ =~ m|insecure cwd| );
- }
+cleanup();
+
+find({wanted => sub { print "ok 1\n" if $_ eq 'commonsense.t'; },
+ untaint => 1, untaint_pattern => qr|^(.+)$|}, File::Spec->curdir);
+
+finddepth({wanted => sub { print "ok 2\n" if $_ eq 'commonsense.t'; },
+ untaint => 1, untaint_pattern => qr|^(.+)$|},
+ File::Spec->curdir);
+
+my $case = 2;
+my $FastFileTests_OK = 0;
+
+sub cleanup {
+ if (-d dir_path('for_find')) {
+ chdir(dir_path('for_find'));
+ }
+ if (-d dir_path('fa')) {
+ unlink file_path('fa', 'fa_ord'),
+ file_path('fa', 'fsl'),
+ file_path('fa', 'faa', 'faa_ord'),
+ file_path('fa', 'fab', 'fab_ord'),
+ file_path('fa', 'fab', 'faba', 'faba_ord'),
+ file_path('fb', 'fb_ord'),
+ file_path('fb', 'fba', 'fba_ord');
+ rmdir dir_path('fa', 'faa');
+ rmdir dir_path('fa', 'fab', 'faba');
+ rmdir dir_path('fa', 'fab');
+ rmdir dir_path('fa');
+ rmdir dir_path('fb', 'fba');
+ rmdir dir_path('fb');
+ chdir File::Spec->updir;
+ rmdir dir_path('for_find');
+ }
+}
+
+END {
+ cleanup();
+}
+
+sub Check($) {
+ $case++;
+ if ($_[0]) { print "ok $case\n"; }
+ else { print "not ok $case\n"; }
+
+}
+
+sub CheckDie($) {
+ $case++;
+ if ($_[0]) { print "ok $case\n"; }
+ else { print "not ok $case\n"; exit 0; }
+}
+
+sub Skip($) {
+ $case++;
+ print "ok $case # skipped: ",$_[0],"\n";
+}
+
+sub touch {
+ CheckDie( open(my $T,'>',$_[0]) );
+}
+
+sub MkDir($$) {
+ CheckDie( mkdir($_[0],$_[1]) );
+}
+
+sub wanted_File_Dir {
+ print "# \$File::Find::dir => '$File::Find::dir'\n";
+ print "# \$_ => '$_'\n";
+ s#\.$## if ($^O eq 'VMS' && $_ ne '.');
+ Check( $Expect_File{$_} );
+ if ( $FastFileTests_OK ) {
+ delete $Expect_File{ $_}
+ unless ( $Expect_Dir{$_} && ! -d _ );
+ } else {
+ delete $Expect_File{$_}
+ unless ( $Expect_Dir{$_} && ! -d $_ );
+ }
+}
+
+sub wanted_File_Dir_prune {
+ &wanted_File_Dir;
+ $File::Find::prune=1 if $_ eq 'faba';
+}
+
+
+sub simple_wanted {
+ print "# \$File::Find::dir => '$File::Find::dir'\n";
+ print "# \$_ => '$_'\n";
+}
+
+
+# Use dir_path() to specify a directory path that's expected for
+# $File::Find::dir (%Expect_Dir). Also use it in file operations like
+# chdir, rmdir etc.
+#
+# dir_path() concatenates directory names to form a _relative_
+# directory path, independant from the platform it's run on, although
+# there are limitations. Don't try to create an absolute path,
+# because that may fail on operating systems that have the concept of
+# volume names (e.g. Mac OS). Be careful when you want to create an
+# updir path like ../fa (Unix) or ::fa: (Mac OS). Plain directory
+# names will work best. As a special case, you can pass it a "." as
+# first argument, to create a directory path like "./fa/dir" on
+# operating systems other than Mac OS (actually, Mac OS will ignore
+# the ".", if it's the first argument). If there's no second argument,
+# this function will return the empty string on Mac OS and the string
+# "./" otherwise.
+
+sub dir_path {
+ my $first_item = shift @_;
+
+ if ($first_item eq '.') {
+ if ($^O eq 'MacOS') {
+ return '' unless @_;
+ # ignore first argument; return a relative path
+ # with leading ":" and with trailing ":"
+ return File::Spec->catdir("", @_);
+ } else { # other OS
+ return './' unless @_;
+ my $path = File::Spec->catdir(@_);
+ # add leading "./"
+ $path = "./$path";
+ return $path;
+ }
+
+ } else { # $first_item ne '.'
+ return $first_item unless @_; # return plain filename
+ if ($^O eq 'MacOS') {
+ # relative path with leading ":" and with trailing ":"
+ return File::Spec->catdir("", $first_item, @_);
+ } else { # other OS
+ return File::Spec->catdir($first_item, @_);
+ }
+ }
+}
+
+
+# Use topdir() to specify a directory path that you want to pass to
+#find/finddepth Basically, topdir() does the same as dir_path() (see
+#above), except that there's no trailing ":" on Mac OS.
+
+sub topdir {
+ my $path = dir_path(@_);
+ $path =~ s/:$// if ($^O eq 'MacOS');
+ return $path;
+}
+
+
+# Use file_path() to specify a file path that's expected for $_ (%Expect_File).
+# Also suitable for file operations like unlink etc.
+
+# file_path() concatenates directory names (if any) and a filename to
+# form a _relative_ file path (the last argument is assumed to be a
+# file). It's independant from the platform it's run on, although
+# there are limitations (see the warnings for dir_path() above). As a
+# special case, you can pass it a "." as first argument, to create a
+# file path like "./fa/file" on operating systems other than Mac OS
+# (actually, Mac OS will ignore the ".", if it's the first
+# argument). If there's no second argument, this function will return
+# the empty string on Mac OS and the string "./" otherwise.
+
+sub file_path {
+ my $first_item = shift @_;
+
+ if ($first_item eq '.') {
+ if ($^O eq 'MacOS') {
+ return '' unless @_;
+ # ignore first argument; return a relative path
+ # with leading ":", but without trailing ":"
+ return File::Spec->catfile("", @_);
+ } else { # other OS
+ return './' unless @_;
+ my $path = File::Spec->catfile(@_);
+ # add leading "./"
+ $path = "./$path";
+ return $path;
+ }
+
+ } else { # $first_item ne '.'
+ return $first_item unless @_; # return plain filename
+ if ($^O eq 'MacOS') {
+ # relative path with leading ":", but without trailing ":"
+ return File::Spec->catfile("", $first_item, @_);
+ } else { # other OS
+ return File::Spec->catfile($first_item, @_);
+ }
+ }
+}
+
+
+# Use file_path_name() to specify a file path that's expected for
+# $File::Find::Name (%Expect_Name). Note: When the no_chdir => 1
+# option is in effect, $_ is the same as $File::Find::Name. In that
+# case, also use this function to specify a file path that's expected
+# for $_.
+#
+# Basically, file_path_name() does the same as file_path() (see
+# above), except that there's always a leading ":" on Mac OS, even for
+# plain file/directory names.
+
+sub file_path_name {
+ my $path = file_path(@_);
+ $path = ":$path" if (($^O eq 'MacOS') && ($path !~ /:/));
+ return $path;
+}
+
+
+
+MkDir( dir_path('for_find'), 0770 );
+CheckDie(chdir( dir_path('for_find')));
+
+$cwd = cwd(); # save cwd
+( $cwd_untainted ) = $cwd =~ m|^(.+)$|; # untaint it
+
+MkDir( dir_path('fa'), 0770 );
+MkDir( dir_path('fb'), 0770 );
+touch( file_path('fb', 'fb_ord') );
+MkDir( dir_path('fb', 'fba'), 0770 );
+touch( file_path('fb', 'fba', 'fba_ord') );
+if ($^O eq 'MacOS') {
+ CheckDie( symlink(':fb',':fa:fsl') ) if $symlink_exists;
+} else {
+ CheckDie( symlink('../fb','fa/fsl') ) if $symlink_exists;
+}
+touch( file_path('fa', 'fa_ord') );
+
+MkDir( dir_path('fa', 'faa'), 0770 );
+touch( file_path('fa', 'faa', 'faa_ord') );
+MkDir( dir_path('fa', 'fab'), 0770 );
+touch( file_path('fa', 'fab', 'fab_ord') );
+MkDir( dir_path('fa', 'fab', 'faba'), 0770 );
+touch( file_path('fa', 'fab', 'faba', 'faba_ord') );
+
+print "# check untainting (no follow)\n";
+
+# untainting here should work correctly
+
+%Expect_File = (File::Spec->curdir => 1, file_path('fsl') =>
+ 1,file_path('fa_ord') => 1, file_path('fab') => 1,
+ file_path('fab_ord') => 1, file_path('faba') => 1,
+ file_path('faa') => 1, file_path('faa_ord') => 1);
+delete $Expect_File{ file_path('fsl') } unless $symlink_exists;
+%Expect_Name = ();
+
+%Expect_Dir = ( dir_path('fa') => 1, dir_path('faa') => 1,
+ dir_path('fab') => 1, dir_path('faba') => 1,
+ dir_path('fb') => 1, dir_path('fba') => 1);
+
+delete @Expect_Dir{ dir_path('fb'), dir_path('fba') } unless $symlink_exists;
+
+File::Find::find( {wanted => \&wanted_File_Dir_prune, untaint => 1,
+ untaint_pattern => qr|^(.+)$|}, topdir('fa') );
+
+Check( scalar(keys %Expect_File) == 0 );
+
+
+# don't untaint at all, should die
+%Expect_File = ();
+%Expect_Name = ();
+%Expect_Dir = ();
+undef $@;
+eval {File::Find::find( {wanted => \&simple_wanted}, topdir('fa') );};
+Check( $@ =~ m|Insecure dependency| );
+chdir($cwd_untainted);
+
+
+# untaint pattern doesn't match, should die
+undef $@;
+
+eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1,
+ untaint_pattern => qr|^(NO_MATCH)$|},
+ topdir('fa') );};
+
+Check( $@ =~ m|is still tainted| );
+chdir($cwd_untainted);
+
+
+# untaint pattern doesn't match, should die when we chdir to cwd
+print "# check untaint_skip (No follow)\n";
+undef $@;
+
+eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1,
+ untaint_skip => 1, untaint_pattern =>
+ qr|^(NO_MATCH)$|}, topdir('fa') );};
+
+print "# $@" if $@;
+#$^D = 8;
- if ($NonTaintedCwd) {
- Skip("$^O does not taint cwd");
- }
- else {
- Check( $@ =~ m|insecure cwd| );
- }
++Check( $@ =~ m|insecure cwd| );
++
+chdir($cwd_untainted);
+
+
+if ( $symlink_exists ) {
+ print "# --- symbolic link tests --- \n";
+ $FastFileTests_OK= 1;
+
+ print "# check untainting (follow)\n";
+
+ # untainting here should work correctly
+ # no_chdir is in effect, hence we use file_path_name to specify the expected paths for %Expect_File
+
+ %Expect_File = (file_path_name('fa') => 1,
+ file_path_name('fa','fa_ord') => 1,
+ file_path_name('fa', 'fsl') => 1,
+ file_path_name('fa', 'fsl', 'fb_ord') => 1,
+ file_path_name('fa', 'fsl', 'fba') => 1,
+ file_path_name('fa', 'fsl', 'fba', 'fba_ord') => 1,
+ file_path_name('fa', 'fab') => 1,
+ file_path_name('fa', 'fab', 'fab_ord') => 1,
+ file_path_name('fa', 'fab', 'faba') => 1,
+ file_path_name('fa', 'fab', 'faba', 'faba_ord') => 1,
+ file_path_name('fa', 'faa') => 1,
+ file_path_name('fa', 'faa', 'faa_ord') => 1);
+
+ %Expect_Name = ();
+
+ %Expect_Dir = (dir_path('fa') => 1,
+ dir_path('fa', 'faa') => 1,
+ dir_path('fa', 'fab') => 1,
+ dir_path('fa', 'fab', 'faba') => 1,
+ dir_path('fb') => 1,
+ dir_path('fb', 'fba') => 1);
+
+ File::Find::find( {wanted => \&wanted_File_Dir, follow_fast => 1,
+ no_chdir => 1, untaint => 1, untaint_pattern =>
+ qr|^(.+)$| }, topdir('fa') );
+
+ Check( scalar(keys %Expect_File) == 0 );
+
+
+ # don't untaint at all, should die
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1},
+ topdir('fa') );};
+
+ Check( $@ =~ m|Insecure dependency| );
+ chdir($cwd_untainted);
+
+ # untaint pattern doesn't match, should die
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, follow => 1,
+ untaint => 1, untaint_pattern =>
+ qr|^(NO_MATCH)$|}, topdir('fa') );};
+
+ Check( $@ =~ m|is still tainted| );
+ chdir($cwd_untainted);
+
+ # untaint pattern doesn't match, should die when we chdir to cwd
+ print "# check untaint_skip (Follow)\n";
+ undef $@;
+
+ eval {File::Find::find( {wanted => \&simple_wanted, untaint => 1,
+ untaint_skip => 1, untaint_pattern =>
+ qr|^(NO_MATCH)$|}, topdir('fa') );};
++ Check( $@ =~ m|insecure cwd| );
++
+ chdir($cwd_untainted);
+}
+
projects / platform / upstream / perl.git / commitdiff