X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fmisc.t;h=38690305cfe73e5c7b79760207ba6d5bb05d4cc3;hb=b0f2b690b4ba59b02c372a35658748cb0f31c38e;hp=4f47f0f7af8c0ea971a4a6fb6e96fadbb367a5a5;hpb=44a8e56aa037ed0f03f0506f6f85f5ed290c78e1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/misc.t b/t/op/misc.t index 4f47f0f..3869030 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -1,7 +1,10 @@ #!./perl +# NOTE: Please don't add tests to this file unless they *need* to be run in +# separate executable and can't simply use eval. + chdir 't' if -d 't'; -@INC = "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -12,22 +15,42 @@ print "1..", scalar @prgs, "\n"; $tmpfile = "misctmp000"; 1 while -f ++$tmpfile; -END { unlink $tmpfile if $tmpfile; } +END { while($tmpfile && unlink $tmpfile){} } + +$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat')); for (@prgs){ my $switch; - if (s/^\s*-\w+//){ - $switch = $&; + if (s/^\s*(-\w.*)//){ + $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); - open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + $prog =~ s#/dev/null#NL:# if $^O eq 'VMS'; + $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS'; # VMS file locking + print TEST $prog, "\n"; - close TEST; + close TEST or die "Cannot close $tmpfile: $!"; + + if ($^O eq 'MSWin32') { + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; + } + elsif ($^O eq 'NetWare') { + $results = `perl -I../lib $switch $tmpfile 2>&1`; + } + else { + $results = `./perl $switch $tmpfile 2>&1`; + } $status = $?; - $results = `cat $tmpfile`; $results =~ s/\n+$//; + $results =~ s/at\s+misctmp\d+\s+line/at - line/g; + $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + $results =~ s/\n\n/\n/ if $^O eq 'VMS'; # pipes double these sometimes $expected =~ s/\n+$//; - if ( $results ne $expected){ + if ( $results ne $expected ) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; @@ -44,14 +67,15 @@ EXPECT a := b := c ######## $cusp = ~0 ^ (~0 >> 1); +use integer; $, = " "; -print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; +print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; EXPECT -7 0 0 1 ! +7 0 0 8 ! ######## $foo=undef; $foo->go; EXPECT -Can't call method "go" without a package or object reference at - line 1. +Can't call method "go" on an undefined value at - line 1. ######## BEGIN { @@ -64,7 +88,7 @@ $x=0x0eabcd; print $x->ref; EXPECT Can't call method "ref" without a package or object reference at - line 1. ######## -chop ($str .= ); +chop ($str .= ); ######## close ($banana); ######## @@ -74,9 +98,9 @@ EXPECT ######## eval {sub bar {print "In bar";}} ######## -system "./perl -ne 'print if eof' /dev/null" +system './perl -ne "print if eof" /dev/null' ######## -chop($file = <>); +chop($file = ); ######## package N; sub new {my ($obj,$n)=@_; bless \$n} @@ -88,7 +112,8 @@ EXPECT ######## %@x=0; EXPECT -Can't coerce HASH to string in repeat at - line 1. +Can't modify hash dereference in repeat (x) at - line 1, near "0;" +Execution of - aborted due to compilation errors. ######## $_="foo"; printf(STDOUT "%s\n", $_); @@ -188,6 +213,11 @@ BEGIN failed--compilation aborted at - line 1. shift; print join(' ', reverse @_)."\n"; } + sub PRINTF { + shift; + my $fmt = shift; + print sprintf($fmt, @_)."\n"; + } sub TIEHANDLE { bless {}, shift; } @@ -196,23 +226,51 @@ BEGIN failed--compilation aborted at - line 1. } sub DESTROY { print "and destroyed as well\n"; - } + } + sub READ { + shift; + print STDOUT "foo->can(READ)(@_)\n"; + return 100; + } + sub GETC { + shift; + print STDOUT "Don't GETC, Get Perl\n"; + return "a"; + } } { local(*FOO); tie(*FOO,'foo'); print FOO "sentence.", "reversed", "a", "is", "This"; print "-- ", , " --\n"; + my($buf,$len,$offset); + $buf = "string"; + $len = 10; $offset = 1; + read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed"; + getc(FOO) eq "a" or die "foo->GETC failed"; + printf "%s is number %d\n", "Perl", 1; } EXPECT This is a reversed sentence. -- Out of inspiration -- +foo->can(READ)(string 10 1) +Don't GETC, Get Perl +Perl is number 1 and destroyed as well ######## my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n" EXPECT 2 2 2 ######## +# used to attach defelem magic to all immortal values, +# which made restore of local $_ fail. +foo(2>1); +sub foo { bar() for @_; } +sub bar { local $_; } +print "ok\n"; +EXPECT +ok +######## @a = ($a, $b, $c, $d) = (5, 6); print "ok\n" if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]); @@ -259,6 +317,13 @@ print p::func()->groovy(), "\n" EXPECT really groovy ######## +@list = ([ 'one', 1 ], [ 'two', 2 ]); +sub func { $num = shift; (grep $_->[1] == $num, @list)[0] } +print scalar(map &func($_), 1 .. 3), " ", + scalar(map scalar &func($_), 1 .. 3), "\n"; +EXPECT +2 3 +######## ($k, $s) = qw(x 0); @{$h{$k}} = qw(1 2 4); for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) } @@ -269,3 +334,395 @@ eval q[ my $a = 'inner'; eval q[ print "$a " ] ]; eval { my $x = 'peace'; eval q[ print "$x\n" ] } EXPECT inner peace +######## +-w +$| = 1; +sub foo { + print "In foo1\n"; + eval 'sub foo { print "In foo2\n" }'; + print "Exiting foo1\n"; +} +foo; +foo; +EXPECT +In foo1 +Subroutine foo redefined at (eval 1) line 1. +Exiting foo1 +In foo2 +######## +$s = 0; +map {#this newline here tickles the bug +$s += $_} (1,2,4); +print "eat flaming death\n" unless ($s == 7); +######## +sub foo { local $_ = shift; split; @_ } +@x = foo(' x y z '); +print "you die joe!\n" unless "@x" eq 'x y z'; +######## +/(?{"{"})/ # Check it outside of eval too +EXPECT +Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern +Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1. +######## +/(?{"{"}})/ # Check it outside of eval too +EXPECT +Unmatched right curly bracket at (re_eval 1) line 1, at end of line +syntax error at (re_eval 1) line 1, near ""{"}" +Compilation failed in regexp at - line 1. +######## +BEGIN { @ARGV = qw(a b c d e) } +BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } +END { print "end <",shift,">\nargv <@ARGV>\n" } +INIT { print "init <",shift,">\n" } +CHECK { print "check <",shift,">\n" } +EXPECT +argv +begin +check +init +end +argv +######## +-l +# fdopen from a system descriptor to a system descriptor used to close +# the former. +open STDERR, '>&=STDOUT' or die $!; +select STDOUT; $| = 1; print fileno STDOUT or die $!; +select STDERR; $| = 1; print fileno STDERR or die $!; +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" }; +package main; +*s = ascalar X; +EXPECT +destroyed +######## +package X; +sub anarray { bless [] } +sub DESTROY { print "destroyed\n" }; +package main; +*a = anarray X; +EXPECT +destroyed +######## +package X; +sub ahash { bless {} } +sub DESTROY { print "destroyed\n" }; +package main; +*h = ahash X; +EXPECT +destroyed +######## +package X; +sub aclosure { my $x; bless sub { ++$x } } +sub DESTROY { print "destroyed\n" }; +package main; +*c = aclosure X; +EXPECT +destroyed +######## +package X; +sub any { bless {} } +my $f = "FH000"; # just to thwart any future optimisations +sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r } +sub DESTROY { print "destroyed\n" } +package main; +$x = any X; # to bump sv_objcount. IO objs aren't counted?? +*f = afh X; +EXPECT +destroyed +destroyed +######## +BEGIN { + $| = 1; + $SIG{__WARN__} = sub { + eval { print $_[0] }; + die "bar\n"; + }; + warn "foo\n"; +} +EXPECT +foo +bar +BEGIN failed--compilation aborted at - line 8. +######## +package X; +@ISA='Y'; +sub new { + my $class = shift; + my $self = { }; + bless $self, $class; + my $init = shift; + $self->foo($init); + print "new", $init; + return $self; +} +sub DESTROY { + my $self = shift; + print "DESTROY", $self->foo; +} +package Y; +sub attribute { + my $self = shift; + my $var = shift; + if (@_ == 0) { + return $self->{$var}; + } elsif (@_ == 1) { + $self->{$var} = shift; + } +} +sub AUTOLOAD { + $AUTOLOAD =~ /::([^:]+)$/; + my $method = $1; + splice @_, 1, 0, $method; + goto &attribute; +} +package main; +my $x = X->new(1); +for (2..3) { + my $y = X->new($_); + print $y->foo; +} +print $x->foo; +EXPECT +new1new22DESTROY2new33DESTROY31DESTROY1 +######## +re(); +sub re { + my $re = join '', eval 'qr/(??{ $obj->method })/'; + $re; +} +EXPECT +######## +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +EXPECT +ZZZ +######## +eval ' +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +'; +EXPECT +ZZZ +######## +-w +if (@ARGV) { print "" } +else { + if ($x == 0) { print "" } else { print $x } +} +EXPECT +Use of uninitialized value in numeric eq (==) at - line 4. +######## +$x = sub {}; +foo(); +sub foo { eval { return }; } +print "ok\n"; +EXPECT +ok +######## +# moved to op/lc.t +EXPECT +######## +sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } +my $x = "foo"; +{ f } continue { print $x, "\n" } +EXPECT +foo +######## +sub C () { 1 } +sub M { $_[0] = 2; } +eval "C"; +M(C); +EXPECT +Modification of a read-only value attempted at - line 2. +######## +print qw(ab a\b a\\b); +EXPECT +aba\ba\b +######## +# lexicals declared after the myeval() definition should not be visible +# within it +sub myeval { eval $_[0] } +my $foo = "ok 2\n"; +myeval('sub foo { local $foo = "ok 1\n"; print $foo; }'); +die $@ if $@; +foo(); +print $foo; +EXPECT +ok 1 +ok 2 +######## +# lexicals outside an eval"" should be visible inside subroutine definitions +# within it +eval <<'EOT'; die $@ if $@; +{ + my $X = "ok\n"; + eval 'sub Y { print $X }'; die $@ if $@; + Y(); +} +EOT +EXPECT +ok +######## +# test that closures generated by eval"" hold on to the CV of the eval"" +# for their entire lifetime +$code = eval q[ + sub { eval '$x = "ok 1\n"'; } +]; +&{$code}(); +print $x; +EXPECT +ok 1 +######## +# This test is here instead of pragma/locale.t because +# the bug depends on in the internal state of the locale +# settings and pragma/locale messes up that state pretty badly. +# We need a "fresh run". +BEGIN { + eval { require POSIX }; + if ($@) { + exit(0); # running minitest? + } +} +use Config; +my $have_setlocale = $Config{d_setlocale} eq 'define'; +$have_setlocale = 0 if $@; +# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" +# and mingw32 uses said silly CRT +$have_setlocale = 0 if (($^O eq 'MSWin32' || $^O eq 'NetWare') && $Config{cc} =~ /^(cl|gcc)/i); +exit(0) unless $have_setlocale; +my @locales; +if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { + while() { + chomp; + push(@locales, $_); + } + close(LOCALES); +} +exit(0) unless @locales; +for (@locales) { + use POSIX qw(locale_h); + use locale; + setlocale(LC_NUMERIC, $_) or next; + my $s = sprintf "%g %g", 3.1, 3.1; + next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; + print "$_ $s\n"; +} +EXPECT +######## +die qr(x) +EXPECT +(?-xism:x) at - line 1. +######## +# 20001210.003 mjd@plover.com +format REMITOUT_TOP = +FOO +. + +format REMITOUT = +BAR +. + +# This loop causes a segv in 5.6.0 +for $lineno (1..61) { + write REMITOUT; +} + +print "It's OK!"; +EXPECT +It's OK! +######## +# Inaba Hiroto +reset; +if (0) { + if ("" =~ //) { + } +} +######## +# Nicholas Clark +$ENV{TERM} = 0; +reset; +// if 0; +######## +# Vadim Konovalov +use strict; +sub new_pmop($) { + my $pm = shift; + return eval "sub {shift=~/$pm/}"; +} +new_pmop "abcdef"; reset; +new_pmop "abcdef"; reset; +new_pmop "abcdef"; reset; +new_pmop "abcdef"; reset; +######## +# David Dyck +# coredump in 5.7.1 +close STDERR; die; +EXPECT +######## +-w +"x" =~ /(\G?x)?/; # core dump in 20000716.007 +EXPECT +Quantifier unexpected on zero-length expression in regex; marked by <-- HERE in m/(\G?x)? <-- HERE / at - line 2. +######## +# Bug 20010515.004 +my @h = 1 .. 10; +bad(@h); +sub bad { + undef @h; + print "O"; + print for @_; + print "K"; +} +EXPECT +OK +######## +# Bug 20010506.041 +"abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n"; +EXPECT +ok +######## +# Bug 20010422.005 +{s//${}/; //} +EXPECT +syntax error at - line 2, near "${}" +Execution of - aborted due to compilation errors. +######## +# Bug 20010528.007 +"\x{" +EXPECT +Missing right brace on \x{} at - line 2, within string +Execution of - aborted due to compilation errors. +######## +my $foo = Bar->new(); +my @dst; +END { + ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/; + print $_, "\n"; +} +package Bar; +sub new { + my Bar $self = bless [], Bar; + eval '$self'; + return $self; +} +sub DESTROY { + push @dst, "$_[0]"; +} +EXPECT +Bar=ARRAY(0x...) +######## +eval "a.b.c.d.e.f;sub" +EXPECT