diff options
Diffstat (limited to 'gnu/usr.bin/perl/t')
| -rwxr-xr-x | gnu/usr.bin/perl/t/io/through.t | 15 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/t/lib/cygwin.t | 51 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/t/op/chr.t | 82 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/t/op/getppid.t | 131 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/t/op/negate.t | 88 | ||||
| -rwxr-xr-x | gnu/usr.bin/perl/t/op/sselect.t | 81 |
6 files changed, 88 insertions, 360 deletions
diff --git a/gnu/usr.bin/perl/t/io/through.t b/gnu/usr.bin/perl/t/io/through.t index 315de90b861..60c75c99217 100755 --- a/gnu/usr.bin/perl/t/io/through.t +++ b/gnu/usr.bin/perl/t/io/through.t @@ -1,14 +1,16 @@ #!./perl BEGIN { + if ($^O eq 'VMS') { + print "1..0 # Skip on VMS -- too picky about line endings for record-oriented pipes\n"; + exit; + } chdir 't' if -d 't'; @INC = '../lib'; - require './test.pl'; - skip_all("VMS too picky about line endings for record-oriented pipes") - if $^O eq 'VMS'; } use strict; +require './test.pl'; my $Perl = which_perl(); @@ -88,8 +90,7 @@ sub testfile ($$$$$$) { my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; my @data = grep length, split /(.{1,$write_c})/s, $str; - my $filename = tempfile(); - open my $fh, '>', $filename or die; + open my $fh, '>', 'io_io.tmp' or die; select $fh; binmode $fh, ':crlf' if defined $main::use_crlf && $main::use_crlf == 1; @@ -105,7 +106,7 @@ sub testfile ($$$$$$) { die "Unrecognized write: '$how_w'"; } close $fh or die "close: $!"; - open $fh, '<', $filename or die; + open $fh, '<', 'io_io.tmp' or die; binmode $fh, ':crlf' if defined $main::use_crlf && $main::use_crlf == 1; testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); @@ -142,4 +143,6 @@ for my $s (1..2) { } } +unlink 'io_io.tmp'; + 1; diff --git a/gnu/usr.bin/perl/t/lib/cygwin.t b/gnu/usr.bin/perl/t/lib/cygwin.t index 9033d3fb53d..01485461439 100755 --- a/gnu/usr.bin/perl/t/lib/cygwin.t +++ b/gnu/usr.bin/perl/t/lib/cygwin.t @@ -3,11 +3,13 @@ BEGIN { chdir 't' if -d 't'; @INC = ('../lib'); - require './test.pl'; - skip_all('cygwin specific test') unless $^O eq 'cygwin'; + unless ($^O eq "cygwin") { + print "1..0 # skipped: cygwin specific test\n"; + exit 0; + } } -plan(tests => 16); +use Test::More tests => 4; is(Cygwin::winpid_to_pid(Cygwin::pid_to_winpid($$)), $$, "perl pid translates to itself"); @@ -27,46 +29,3 @@ close($ps); is(Cygwin::winpid_to_pid($catwinpid), $catpid, "winpid to pid"); is(Cygwin::pid_to_winpid($catpid), $catwinpid, "pid to winpid"); close($cat); - -is(Cygwin::win_to_posix_path("t\\lib"), "t/lib", "win to posix path: t/lib"); -is(Cygwin::posix_to_win_path("t/lib"), "t\\lib", "posix to win path: t\\lib"); - -use Win32; -use Cwd; -my $pwd = getcwd(); -chdir("/"); -my $winpath = Win32::GetCwd(); -is(Cygwin::posix_to_win_path("/", 1), $winpath, "posix to absolute win path"); -chdir($pwd); -is(Cygwin::win_to_posix_path($winpath, 1), "/", "win to absolute posix path"); - -my $mount = join '', `/usr/bin/mount`; -$mount =~ m|on /usr/bin type .+ \((\w+)[,\)]|m; -my $binmode = $1 =~ /binmode|binary/; -is(Cygwin::is_binmount("/"), $binmode ? 1 : '', "check / for binmount"); - -my $rootmnt = Cygwin::mount_flags("/"); -ok($binmode ? ($rootmnt =~ /,(binmode|binary)/) : ($rootmnt =~ /,textmode/), "check / mount_flags"); -is(Cygwin::mount_flags("/cygdrive") =~ /,cygdrive/, 1, "check cygdrive mount_flags"); - -# Cygdrive mount prefix -my @flags = split(/,/, Cygwin::mount_flags('/cygdrive')); -my $prefix = pop(@flags); -ok($prefix, "cygdrive mount prefix = " . (($prefix) ? $prefix : '<none>')); -chomp(my $prefix2 = `df | grep -i '^c: ' | cut -d% -f2 | xargs`); -$prefix2 =~ s/\/c$//i; -if (! $prefix2) { - $prefix2 = '/'; -} -is($prefix, $prefix2, 'cygdrive mount prefix'); - -my @mnttbl = Cygwin::mount_table(); -ok(@mnttbl > 0, "non empty mount_table"); -for $i (@mnttbl) { - if ($i->[0] eq '/') { - is($i->[2].",".$i->[3], $rootmnt, "same root mount flags"); - last; - } -} - -ok(Cwd->cwd(), "bug#38628 legacy"); diff --git a/gnu/usr.bin/perl/t/op/chr.t b/gnu/usr.bin/perl/t/op/chr.t index 57b4adeb2c6..94450ec1cc0 100755 --- a/gnu/usr.bin/perl/t/op/chr.t +++ b/gnu/usr.bin/perl/t/op/chr.t @@ -6,7 +6,7 @@ BEGIN { require "test.pl"; } -plan tests => 42; +plan tests => 26; # Note that t/op/ord.t already tests for chr() <-> ord() rountripping. @@ -19,64 +19,32 @@ is(chr(127), "\x7F"); is(chr(128), "\x80"); is(chr(255), "\xFF"); -is(chr(-0.1), "\x{FFFD}"); # The U+FFFD Unicode replacement character. -is(chr(-1 ), "\x{FFFD}"); -is(chr(-2 ), "\x{FFFD}"); -is(chr(-3.0), "\x{FFFD}"); -{ - use bytes; # Backward compatibility. - is(chr(-0.1), "\x00"); - is(chr(-1 ), "\xFF"); - is(chr(-2 ), "\xFE"); - is(chr(-3.0), "\xFD"); -} - -# Make sure -1 is treated the same way when coming from a tied variable -sub TIESCALAR {bless[]} -sub STORE { $_[0][0] = $_[1] } -sub FETCH { $_[0][0] } -tie $t, ""; -$t = -1; is chr $t, chr -1, 'chr $tied when $tied is -1'; -$t = -2; is chr $t, chr -2, 'chr $tied when $tied is -2'; -$t = -1.1; is chr $t, chr -1.1, 'chr $tied when $tied is -1.1'; -$t = -2.2; is chr $t, chr -2.2, 'chr $tied when $tied is -2.2'; +# is(chr(-1), undef); # Shouldn't it be? -# And that stringy scalars are treated likewise -is chr "-1", chr -1, 'chr "-1" eq chr -1'; -is chr "-2", chr -2, 'chr "-2" eq chr -2'; -is chr "-1.1", chr -1.1, 'chr "-1.1" eq chr -1.1'; -is chr "-2.2", chr -2.2, 'chr "-2.2" eq chr -2.2'; +# Check UTF-8. -# Check UTF-8 (not UTF-EBCDIC). -SKIP: { - skip "no UTF-8 on EBCDIC", 21 if chr(193) eq 'A'; - -sub hexes { - no warnings 'utf8'; # avoid surrogate and beyond Unicode warnings - join(" ",unpack "U0 (H2)*", chr $_[0]); -} +sub hexes { join(" ",map{sprintf"%02x",$_}unpack("C*",chr($_[0]))) } # The following code points are some interesting steps in UTF-8. - is(hexes( 0x100), "c4 80"); - is(hexes( 0x7FF), "df bf"); - is(hexes( 0x800), "e0 a0 80"); - is(hexes( 0xFFF), "e0 bf bf"); - is(hexes( 0x1000), "e1 80 80"); - is(hexes( 0xCFFF), "ec bf bf"); - is(hexes( 0xD000), "ed 80 80"); - is(hexes( 0xD7FF), "ed 9f bf"); - is(hexes( 0xD800), "ed a0 80"); # not strict utf-8 (surrogate area begin) - is(hexes( 0xDFFF), "ed bf bf"); # not strict utf-8 (surrogate area end) - is(hexes( 0xE000), "ee 80 80"); - is(hexes( 0xFFFF), "ef bf bf"); - is(hexes( 0x10000), "f0 90 80 80"); - is(hexes( 0x3FFFF), "f0 bf bf bf"); - is(hexes( 0x40000), "f1 80 80 80"); - is(hexes( 0xFFFFF), "f3 bf bf bf"); - is(hexes(0x100000), "f4 80 80 80"); - is(hexes(0x10FFFF), "f4 8f bf bf"); # Unicode (4.1) last code point - is(hexes(0x110000), "f4 90 80 80"); - is(hexes(0x1FFFFF), "f7 bf bf bf"); # last four byte encoding - is(hexes(0x200000), "f8 88 80 80 80"); -} +is(hexes( 0x100), "c4 80"); +is(hexes( 0x7FF), "df bf"); +is(hexes( 0x800), "e0 a0 80"); +is(hexes( 0xFFF), "e0 bf bf"); +is(hexes( 0x1000), "e1 80 80"); +is(hexes( 0xCFFF), "ec bf bf"); +is(hexes( 0xD000), "ed 80 80"); +is(hexes( 0xD7FF), "ed 9f bf"); +is(hexes( 0xD800), "ed a0 80"); # not strict utf-8 (surrogate area begin) +is(hexes( 0xDFFF), "ed bf bf"); # not strict utf-8 (surrogate area end) +is(hexes( 0xE000), "ee 80 80"); +is(hexes( 0xFFFF), "ef bf bf"); +is(hexes( 0x10000), "f0 90 80 80"); +is(hexes( 0x3FFFF), "f0 bf bf bf"); +is(hexes( 0x40000), "f1 80 80 80"); +is(hexes( 0xFFFFF), "f3 bf bf bf"); +is(hexes(0x100000), "f4 80 80 80"); +is(hexes(0x10FFFF), "f4 8f bf bf"); # Unicode (4.1) last code point +is(hexes(0x110000), "f4 90 80 80"); +is(hexes(0x1FFFFF), "f7 bf bf bf"); # last four byte encoding +is(hexes(0x200000), "f8 88 80 80 80"); diff --git a/gnu/usr.bin/perl/t/op/getppid.t b/gnu/usr.bin/perl/t/op/getppid.t index a8d0f2cb3b8..cb486888bec 100755 --- a/gnu/usr.bin/perl/t/op/getppid.t +++ b/gnu/usr.bin/perl/t/op/getppid.t @@ -1,11 +1,7 @@ #!./perl # Test that getppid() follows UNIX semantics: when the parent process -# dies, the child is reparented to the init process -# The init process is usually 1, but doesn't have to be, and there's no -# standard way to find out what it is, so the only portable way to go it so -# attempt 2 reparentings and see if the PID both orphaned grandchildren get is -# the same. (and not ours) +# dies, the child is reparented to the init process (pid 1). BEGIN { chdir 't' if -d 't'; @@ -13,103 +9,46 @@ BEGIN { } use strict; +use Config; BEGIN { - require './test.pl'; - skip_all_without_config(qw(d_pipe d_fork d_waitpid d_getppid)); - plan (8); + for my $syscall (qw(pipe fork waitpid getppid)) { + if (!$Config{"d_$syscall"}) { + print "1..0 # Skip: no $syscall\n"; + exit; + } + } + print "1..3\n"; } -# No, we don't want any zombies. kill 0, $ppid spots zombies :-( -$SIG{CHLD} = 'IGNORE'; - -sub fork_and_retrieve { - my $which = shift; - pipe my ($r, $w) or die "pipe: $!\n"; - my $pid = fork; defined $pid or die "fork: $!\n"; +pipe my ($r, $w) or die "pipe: $!\n"; +my $pid = fork; defined $pid or die "fork: $!\n"; - if ($pid) { - # parent - close $w or die "close: $!\n"; - $_ = <$r>; - chomp; - die "Garbled output '$_'" - unless my ($how, $first, $second) = /^([a-z]+),(\d+),(\d+)\z/; - cmp_ok ($first, '>=', 1, "Parent of $which grandchild"); - my $message = "grandchild waited until '$how'"; - cmp_ok ($second, '>=', 1, "New parent of orphaned $which grandchild") - ? note ($message) : diag ($message); - - SKIP: { - skip("Orphan processes are not reparented on QNX", 1) - if $^O eq 'nto'; - isnt($first, $second, - "Orphaned $which grandchild got a new parent"); - } - return $second; +if ($pid) { + # parent + close $w; + waitpid($pid, 0) == $pid or die "waitpid: $!\n"; + print <$r>; +} +else { + # child + close $r; + my $pid2 = fork; defined $pid2 or die "fork: $!\n"; + if ($pid2) { + close $w; + sleep 1; } else { - # child - # Prevent test.pl from thinking that we failed to run any tests. - $::NO_ENDING = 1; - close $r or die "close: $!\n"; - - pipe my ($r2, $w2) or die "pipe: $!\n"; - pipe my ($r3, $w3) or die "pipe: $!\n"; - my $pid2 = fork; defined $pid2 or die "fork: $!\n"; - if ($pid2) { - close $w or die "close: $!\n"; - close $w2 or die "close: $!\n"; - close $r3 or die "close: $!\n"; - # Wait for our child to signal that it's read our PID: - <$r2>; - # Implicit close of $w3: - exit 0; - } - else { - # grandchild - close $r2 or die "close: $!\n"; - close $w3 or die "close: $!\n"; - my $ppid1 = getppid(); - # kill 0 isn't portable: - my $can_kill0 = eval { - kill 0, $ppid1; - }; - my $how = $can_kill0 ? 'undead' : 'sleep'; - - # Tell immediate parent to exit: - close $w2 or die "close: $!\n"; - # Wait for it to (start to) exit: - <$r3>; - # Which sadly isn't enough to be sure that it has exited - often we - # get switched in during its shutdown, after $w3 closes but before - # it exits and we get reparented. - if ($can_kill0) { - # use kill 0 where possible. Try 10 times, then give up: - for (0..9) { - my $got = kill 0, $ppid1; - die "kill: $!" unless defined $got; - if (!$got) { - $how = 'kill'; - last; - } - sleep 1; - } - } else { - # Fudge it by waiting a bit more: - sleep 2; - } - my $ppid2 = getppid(); - print $w "$how,$ppid1,$ppid2\n"; - } - exit 0; + # grandchild + my $ppid1 = getppid(); + print $w "not " if $ppid1 <= 1; + print $w "ok 1 # ppid1=$ppid1\n"; + sleep 2; + my $ppid2 = getppid(); + print $w "not " if $ppid1 == $ppid2; + print $w "ok 2 # ppid2=$ppid2, ppid1!=ppid2\n"; + print $w "not " if $ppid2 != 1; + print $w "ok 3 # ppid2=1\n"; } + exit 0; } - -my $first = fork_and_retrieve("first"); -my $second = fork_and_retrieve("second"); -SKIP: { - skip ("Orphan processes are not reparented on QNX", 1) if $^O eq 'nto'; - is ($first, $second, "Both orphaned grandchildren get the same new parent"); -} -isnt ($first, $$, "And that new parent isn't this process"); diff --git a/gnu/usr.bin/perl/t/op/negate.t b/gnu/usr.bin/perl/t/op/negate.t index 3b02e35f20a..fb8d4b49e85 100755 --- a/gnu/usr.bin/perl/t/op/negate.t +++ b/gnu/usr.bin/perl/t/op/negate.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 46; +plan tests => 16; # Some of these will cause warnings if left on. Here we're checking the # functionality, not the warnings. @@ -18,12 +18,8 @@ is(- -10, 10, "Simple numeric negation to positive"); is(-"10", -10, "Negation of a positive string to negative"); is(-"10.0", -10, "Negation of a positive decimal sting to negative"); is(-"10foo", -10, "Negation of a numeric-lead string returns negation of numeric"); -is(-"-10", 10, 'Negation of string starting with "-" returns a positive number - integer'); -"-10" =~ /(.*)/; -is(-$1, 10, 'Negation of magical string starting with "-" - integer'); -is(-"-10.0", 10.0, 'Negation of string starting with "-" returns a positive number - decimal'); -"-10.0" =~ /(.*)/; -is(-$1, 10.0, 'Negation of magical string starting with "-" - decimal'); +is(-"-10", "+10", 'Negation of string starting with "-" returns a string starting with "+" - numeric'); +is(-"-10.0", "+10.0", 'Negation of string starting with "-" returns a string starting with "+" - decimal'); is(-"-10foo", "+10foo", 'Negation of string starting with "-" returns a string starting with "+" - non-numeric'); is(-"xyz", "-xyz", 'Negation of a negative string adds "-" to the front'); is(-"-xyz", "+xyz", "Negation of a negative string to positive"); @@ -32,80 +28,4 @@ is(-bareword, "-bareword", "Negation of bareword treated like a string"); is(- -bareword, "+bareword", "Negation of -bareword returns string +bareword"); is(-" -10", 10, "Negation of a whitespace-lead numeric string"); is(-" -10.0", 10, "Negation of a whitespace-lead decimal string"); -is(-" -10foo", 10, - "Negation of a whitespace-lead sting starting with a numeric"); - -$x = "dogs"; -()=0+$x; -is -$x, '-dogs', 'cached numeric value does not sabotage string negation'; - -is(-"97656250000000000", -97656250000000000, '-bigint vs -"bigint"'); -"9765625000000000" =~ /(\d+)/; -is -$1, -"$1", '-$1 vs -"$1" with big int'; - -$a = "%apples"; -chop($au = "%apples\x{100}"); -is(-$au, -$a, 'utf8 flag makes no difference for string negation'); -is -"\x{100}", 0, '-(non-ASCII) is equivalent to -(punct)'; - -sub TIESCALAR { bless[] } -sub STORE { $_[0][0] = $_[1] } -sub FETCH { $_[0][0] } - -tie $t, ""; -$a = "97656250000000000"; -() = 0+$a; -$t = $a; -is -$t, -97656250000000000, 'magic str+int dualvar'; - -{ # Repeat most of the tests under use integer - use integer; - is(- 10, -10, "Simple numeric negation to negative"); - is(- -10, 10, "Simple numeric negation to positive"); - is(-"10", -10, "Negation of a positive string to negative"); - is(-"10.0", -10, "Negation of a positive decimal sting to negative"); - is(-"10foo", -10, - "Negation of a numeric-lead string returns negation of numeric"); - is(-"-10", 10, - 'Negation of string starting with "-" returns a positive number -' - .' integer'); - "-10" =~ /(.*)/; - is(-$1, 10, 'Negation of magical string starting with "-" - integer'); - is(-"-10.0", 10, - 'Negation of string starting with "-" returns a positive number - ' - .'decimal'); - "-10.0" =~ /(.*)/; - is(-$1, 10, 'Negation of magical string starting with "-" - decimal'); - is(-"-10foo", "+10foo", - 'Negation of string starting with "-" returns a string starting ' - .'with "+" - non-numeric'); - is(-"xyz", "-xyz", - 'Negation of a negative string adds "-" to the front'); - is(-"-xyz", "+xyz", "Negation of a negative string to positive"); - is(-"+xyz", "-xyz", "Negation of a positive string to negative"); - is(-bareword, "-bareword", - "Negation of bareword treated like a string"); - is(- -bareword, "+bareword", - "Negation of -bareword returns string +bareword"); - is(-" -10", 10, "Negation of a whitespace-lead numeric string"); - is(-" -10.0", 10, "Negation of a whitespace-lead decimal string"); - is(-" -10foo", 10, - "Negation of a whitespace-lead sting starting with a numeric"); - - $x = "dogs"; - ()=0+$x; - is -$x, '-dogs', - 'cached numeric value does not sabotage string negation'; - - $a = "%apples"; - chop($au = "%apples\x{100}"); - is(-$au, -$a, 'utf8 flag makes no difference for string negation'); - is -"\x{100}", 0, '-(non-ASCII) is equivalent to -(punct)'; -} - -# [perl #120288] use integer should not stop barewords from being quoted -{ - use strict; - use integer; - is eval "return -a"||$@, "-a", '-bareword under strict+integer'; -} +is(-" -10foo", 10, "Negation of a whitespace-lead sting starting with a numeric") diff --git a/gnu/usr.bin/perl/t/op/sselect.t b/gnu/usr.bin/perl/t/op/sselect.t index 879c9d52316..0f877b1eff4 100755 --- a/gnu/usr.bin/perl/t/op/sselect.t +++ b/gnu/usr.bin/perl/t/op/sselect.t @@ -1,93 +1,32 @@ #!./perl -my $hires; BEGIN { chdir 't' if -d 't'; @INC = ('.', '../lib'); - $hires = eval 'use Time::HiResx "time"; 1'; } require 'test.pl'; -plan (15); +plan (9); my $blank = ""; eval {select undef, $blank, $blank, 0}; -is ($@, "", 'select undef $blank $blank 0'); +is ($@, ""); eval {select $blank, undef, $blank, 0}; -is ($@, "", 'select $blank undef $blank 0'); +is ($@, ""); eval {select $blank, $blank, undef, 0}; -is ($@, "", 'select $blank $blank undef 0'); +is ($@, ""); eval {select "", $blank, $blank, 0}; -is ($@, "", 'select "" $blank $blank 0'); +is ($@, ""); eval {select $blank, "", $blank, 0}; -is ($@, "", 'select $blank "" $blank 0'); +is ($@, ""); eval {select $blank, $blank, "", 0}; -is ($@, "", 'select $blank $blank "" 0'); - -# Test with read-only copy-on-write empty string -my($rocow) = keys%{{""=>undef}}; -Internals::SvREADONLY($rocow,1); -eval {select $rocow, $blank, $blank, 0}; -is ($@, "", 'select $rocow $blank $blank 0'); -eval {select $blank, $rocow, $blank, 0}; -is ($@, "", 'select $blank $rocow $blank 0'); -eval {select $blank, $blank, $rocow, 0}; -is ($@, "", 'select $blank $blank $rocow 0'); +is ($@, ""); eval {select "a", $blank, $blank, 0}; -like ($@, qr/^Modification of a read-only value attempted/, - 'select "a" $blank $blank 0'); +like ($@, qr/^Modification of a read-only value attempted/); eval {select $blank, "a", $blank, 0}; -like ($@, qr/^Modification of a read-only value attempted/, - 'select $blank "a" $blank 0'); +like ($@, qr/^Modification of a read-only value attempted/); eval {select $blank, $blank, "a", 0}; -like ($@, qr/^Modification of a read-only value attempted/, - 'select $blank $blank "a" 0'); - -my $sleep = 3; -# Actual sleep time on Windows may be rounded down to an integral -# multiple of the system clock tick interval. Clock tick interval -# is configurable, but usually about 15.625 milliseconds. -# time() however (if we haven;t loaded Time::HiRes), doesn't return -# fractional values, so the observed delay may be 1 second short. -# -# There is also a report that old linux kernels may return 0.5ms early: -# <20110520081714.GC17549@mars.tony.develop-help.com>. -# - -my $under = $hires ? 0.1 : 1; - -my $t0 = time; -select(undef, undef, undef, $sleep); -my $t1 = time; -my $diff = $t1-$t0; -ok($diff >= $sleep-$under, "select(u,u,u,\$sleep): at least $sleep seconds have passed"); -note("diff=$diff under=$under"); - -my $empty = ""; -vec($empty,0,1) = 0; -$t0 = time; -select($empty, undef, undef, $sleep); -$t1 = time; -$diff = $t1-$t0; -ok($diff >= $sleep-$under, "select(\$e,u,u,\$sleep): at least $sleep seconds have passed"); -note("diff=$diff under=$under"); - -# [perl #120102] CORE::select ignoring timeout var's magic - -{ - package RT120102; - - my $count = 0; - - sub TIESCALAR { bless [] } - sub FETCH { $count++; 0.1 } - - my $sleep; - - tie $sleep, 'RT120102'; - select (undef, undef, undef, $sleep); - ::is($count, 1, 'RT120102'); -} +like ($@, qr/^Modification of a read-only value attempted/); |