diff options
Diffstat (limited to 't/op')
-rwxr-xr-x | t/op/die_exit.t | 48 | ||||
-rwxr-xr-x | t/op/gv.t | 20 | ||||
-rwxr-xr-x | t/op/hashwarn.t | 3 | ||||
-rwxr-xr-x | t/op/ipcmsg.t | 124 | ||||
-rwxr-xr-x | t/op/ipcsem.t | 136 | ||||
-rwxr-xr-x | t/op/misc.t | 5 | ||||
-rwxr-xr-x | t/op/pack.t | 8 | ||||
-rwxr-xr-x | t/op/pos.t | 16 | ||||
-rwxr-xr-x | t/op/runlevel.t | 2 | ||||
-rwxr-xr-x | t/op/stat.t | 9 |
10 files changed, 366 insertions, 5 deletions
diff --git a/t/op/die_exit.t b/t/op/die_exit.t new file mode 100755 index 0000000000..b01dd35a97 --- /dev/null +++ b/t/op/die_exit.t @@ -0,0 +1,48 @@ +#!./perl + +# +# Verify that C<die> return the return code +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -e '../lib'; +} +my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; + +use strict; + +my %tests = ( + 1 => [ 0, 0], + 2 => [ 0, 1], + 3 => [ 0, 127], + 4 => [ 0, 128], + 5 => [ 0, 255], + 6 => [ 0, 256], + 7 => [ 0, 512], + 8 => [ 1, 0], + 9 => [ 1, 1], + 10 => [ 1, 256], + 11 => [ 128, 0], + 12 => [ 128, 1], + 13 => [ 128, 256], + 14 => [ 255, 0], + 15 => [ 255, 1], + 16 => [ 255, 256], +); + +my $max = keys %tests; + +print "1..$max\n"; + +foreach my $test (1 .. $max) { + my($bang, $query) = @{$tests{$test}}; + my $exit = + system qq($perl -e '\$! = $bang; \$? = $query; die;' 2> /dev/null); + + printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query + unless $exit == (($bang || ($query >> 8) || 255) << 8); + print "ok $test\n"; +} + @@ -4,7 +4,7 @@ # various typeglob tests # -print "1..13\n"; +print "1..18\n"; # type coersion on assignment $foo = 'foo'; @@ -65,3 +65,21 @@ if (defined $baa) { { package Foo::Bar } print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; + +# test undef operator clearing out entire glob +$foo = 'stuff'; +@foo = qw(more stuff); +%foo = qw(even more random stuff); +undef *foo; +print +($foo || @foo || %foo) ? "not ok" : "ok", " 16\n"; + +# test warnings from assignment of undef to glob +{ + my $msg; + local $SIG{__WARN__} = sub { $msg = $_[0] }; + local $^W = 1; + *foo = 'bar'; + print $msg ? "not ok" : "ok", " 17\n"; + *foo = undef; + print $msg ? "ok" : "not ok", " 18\n"; +} diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t index 4127271e7b..6343a2a8d5 100755 --- a/t/op/hashwarn.t +++ b/t/op/hashwarn.t @@ -1,7 +1,8 @@ #!./perl + BEGIN { chdir 't' if -d 't'; - @INC = qw(../lib); + @INC = '../lib'; } use strict; diff --git a/t/op/ipcmsg.t b/t/op/ipcmsg.t new file mode 100755 index 0000000000..336d6d1253 --- /dev/null +++ b/t/op/ipcmsg.t @@ -0,0 +1,124 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my @define; + +BEGIN { + @define = qw( + IPC_PRIVATE + IPC_RMID + IPC_NOWAIT + IPC_STAT + S_IRWXU + S_IRWXG + S_IRWXO + ); +} + +use Config; +use vars map { '$' . $_ } @define; + +BEGIN { + unless($Config{'d_msgget'} eq 'define' && + $Config{'d_msgctl'} eq 'define' && + $Config{'d_msgsnd'} eq 'define' && + $Config{'d_msgrcv'} eq 'define') { + print "0..0\n"; + exit; + } + my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); + my %done = (); + my %define = (); + + sub process_file { + my($file) = @_; + + return unless defined $file; + + my $path = undef; + my $dir; + foreach $dir (@incpath) { + my $tmp = $dir . "/" . $file; + next unless -r $tmp; + $path = $tmp; + last; + } + + return if exists $done{$path}; + $done{$path} = 1; + + unless(defined $path) { + warn "Cannot find '$file'"; + return; + } + + open(F,$path) or return; + while(<F>) { + s#/\*.*(\*/|$)##; + + process_file($mm,$1) + if /^#\s*include\s*[<"]([^>"]+)[>"]/; + + s/(?:\([^)]*\)\s*)//; + + $define{$1} = $2 + if /^#\s*define\s+(\w+)\s+((0x)?\d+|\w+)/; + } + close(F); + } + + process_file("sys/sem.h"); + process_file("sys/ipc.h"); + process_file("sys/stat.h"); + + foreach $d (@define) { + while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) { + $define{$d} = exists $define{$define{$d}} + ? $define{$define{$d}} : undef; + } + unless(defined $define{$d}) { + print "0..0\n"; + exit; + }; + ${ $d } = eval $define{$d}; + } +} + +use strict; + +print "1..6\n"; + +my $msg = msgget($IPC_PRIVATE, $S_IRWXU | $S_IRWXG | $S_IRWXO) + || die "msgget failed: $!\n"; + +print "ok 1\n"; + +#Putting a message on the queue +my $msgtype = 1; +my $msgtext = "hello"; + +msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not "; +print "ok 2\n"; + +my $data; +msgctl($msg,$IPC_STAT,$data) or print "not "; +print "ok 3\n"; + +print "not " unless length($data); +print "ok 4\n"; + +my $msgbuf; +msgrcv($msg,$msgbuf,256,0,$IPC_NOWAIT) or print "not "; +print "ok 5\n"; + +my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf); + +print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext); +print "ok 6\n"; + +msgctl($msg,$IPC_RMID,0); + diff --git a/t/op/ipcsem.t b/t/op/ipcsem.t new file mode 100755 index 0000000000..abe32fbf51 --- /dev/null +++ b/t/op/ipcsem.t @@ -0,0 +1,136 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my @define; + +BEGIN { + @define = qw( + GETALL + SETALL + IPC_PRIVATE + IPC_CREAT + IPC_RMID + IPC_STAT + S_IRWXU + S_IRWXG + S_IRWXO + ); +} + +use Config; +use vars map { '$' . $_ } @define; + +BEGIN { + unless($Config{'d_semget'} eq 'define' && + $Config{'d_semctl'} eq 'define') { + print "0..0\n"; + exit; + } + my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); + my %done = (); + my %define = (); + + sub process_file { + my($file) = @_; + + return unless defined $file; + + my $path = undef; + my $dir; + foreach $dir (@incpath) { + my $tmp = $dir . "/" . $file; + next unless -r $tmp; + $path = $tmp; + last; + } + + return if exists $done{$path}; + $done{$path} = 1; + + unless(defined $path) { + warn "Cannot find '$file'"; + return; + } + + open(F,$path) or return; + while(<F>) { + s#/\*.*(\*/|$)##; + + process_file($mm,$1) + if /^#\s*include\s*[<"]([^>"]+)[>"]/; + + s/(?:\([^)]*\)\s*)//; + + $define{$1} = $2 + if /^#\s*define\s+(\w+)\s+((0x)?\d+|\w+)/; + } + close(F); + } + + process_file("sys/sem.h"); + process_file("sys/ipc.h"); + process_file("sys/stat.h"); + + foreach $d (@define) { + while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) { + $define{$d} = exists $define{$define{$d}} + ? $define{$define{$d}} : undef; + } + unless(defined $define{$d}) { + print "0..0\n"; + exit; + }; + ${ $d } = eval $define{$d}; + } +} + +use strict; + +print "1..10\n"; + +my $sem = semget($IPC_PRIVATE, 10, $S_IRWXU | $S_IRWXG | $S_IRWXO | $IPC_CREAT) + || die "semget: $!\n"; + +print "ok 1\n"; + +my $data; +semctl($sem,0,$IPC_STAT,$data) or print "not "; +print "ok 2\n"; + +print "not " unless length($data); +print "ok 3\n"; + +semctl($sem,0,$SETALL,pack("s*",(0) x 10)) or print "not "; +print "ok 4\n"; + +$data = ""; +semctl($sem,0,$GETALL,$data) or print "not "; +print "ok 5\n"; + +print "not " unless length($data); +print "ok 6\n"; + +my @data = unpack("s*",$data); + +print "not " unless join("",@data) eq "0000000000"; +print "ok 7\n"; + +$data[2] = 1; +semctl($sem,0,$SETALL,pack("s*",@data)) or print "not "; +print "ok 8\n"; + +$data = ""; +semctl($sem,0,$GETALL,$data) or print "not "; +print "ok 9\n"; + +@data = unpack("s*",$data); + +print "not " unless join("",@data) eq "0010000000"; +print "ok 10\n"; + +semctl($sem,0,$IPC_RMID,undef); + diff --git a/t/op/misc.t b/t/op/misc.t index 582ffa7905..9ab6831859 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -368,6 +368,11 @@ EXPECT 1 2 ######## +-w +sub testme { my $a = "test"; { local $a = "new test"; print $a }} +EXPECT +Can't localize lexical variable $a at - line 2. +######## package X; sub ascalar { my $r; bless \$r } sub DESTROY { print "destroyed\n" }; diff --git a/t/op/pack.t b/t/op/pack.t index f9a89a3ec0..de5fcff218 100755 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -2,7 +2,7 @@ # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ -print "1..29\n"; +print "1..30\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -100,3 +100,9 @@ sub foo { my $a = "a"; return $a . $a++ . $a++ } # undef should give null pointer print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); +# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives +# 4294967295 instead of -1) +# see #ifdef __osf__ in pp.c pp_unpack +# Test 30: +print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n"); + diff --git a/t/op/pos.t b/t/op/pos.t new file mode 100755 index 0000000000..46811b7bbc --- /dev/null +++ b/t/op/pos.t @@ -0,0 +1,16 @@ +#!./perl + +print "1..3\n"; + +$x='banana'; +$x=~/.a/g; +if (pos($x)==2) {print "ok 1\n"} else {print "not ok 1\n";} + +$x=~/.z/gc; +if (pos($x)==2) {print "ok 2\n"} else {print "not ok 2\n";} + +sub f { my $p=$_[0]; return $p } + +$x=~/.a/g; +if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";} + diff --git a/t/op/runlevel.t b/t/op/runlevel.t index b5e5dbb08c..bff26e4b71 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -188,6 +188,8 @@ sub sortfn { print "---- ".join(', ', @x)."\n"; EXPECT sortfn 4, 5, 6 +sortfn 4, 5, 6 +sortfn 4, 5, 6 ---- 1, 2, 3 ######## @a = (3, 2, 1); diff --git a/t/op/stat.t b/t/op/stat.t index 9d4b3a6787..c7cd0961f3 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -45,7 +45,12 @@ else { if ($Is_MSWin32 || $Is_Dos || $Config{dont_use_nlink} || $nlink == 2) {print "ok 3\n";} else {print "# \$nlink is |$nlink|\nnot ok 3\n";} -if ($Is_MSWin32 || $Is_Dos || ($mtime && $mtime != $ctime) || $cwd =~ m#/afs/# || $^O eq 'amigaos') { +if ( ($mtime && $mtime != $ctime) + || $Is_MSWin32 + || $Is_Dos + || ($cwd eq '/tmp' and $mtime && $mtime==$ctime) # Solaris tmpfs bug + || $cwd =~ m#/afs/# + || $^O eq 'amigaos') { print "ok 4\n"; } else { @@ -53,7 +58,7 @@ else { print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; } -print "#4 :$mtime: != :$ctime:\n"; +print "#4 :$mtime: should != :$ctime:\n"; unlink "Op.stat.tmp"; if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F } |