X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fmisc.t;h=38690305cfe73e5c7b79760207ba6d5bb05d4cc3;hb=b0f2b690b4ba59b02c372a35658748cb0f31c38e;hp=667db989bfcfc2b92df9a5d22f3cb861ddfe7a7c;hpb=ebf99b04cc4af488057bd9d08bb6a2768960923c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/misc.t b/t/op/misc.t index 667db98..3869030 100755 --- a/t/op/misc.t +++ b/t/op/misc.t @@ -4,7 +4,7 @@ # separate executable and can't simply use eval. chdir 't' if -d 't'; -@INC = "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -15,9 +15,9 @@ 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 <>"' : 'cat'); +$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : (($^O eq 'NetWare') ? 'perl -e "print <>"' : 'cat')); for (@prgs){ my $switch; @@ -25,20 +25,32 @@ for (@prgs){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); + 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 or die "Cannot close $tmpfile: $!"; + if ($^O eq 'MSWin32') { - open TEST, "| .\\perl -I../lib $switch >$tmpfile 2>&1"; + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; + } + elsif ($^O eq 'NetWare') { + $results = `perl -I../lib $switch $tmpfile 2>&1`; } else { - open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + $results = `./perl $switch $tmpfile 2>&1`; } - print TEST $prog, "\n"; - close TEST; $status = $?; - $results = `$CAT $tmpfile`; $results =~ s/\n+$//; - $results =~ s/syntax error/syntax error/i; + $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"; @@ -55,10 +67,11 @@ 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 @@ -75,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); ######## @@ -87,7 +100,7 @@ eval {sub bar {print "In bar";}} ######## system './perl -ne "print if eof" /dev/null' ######## -chop($file = <>); +chop($file = ); ######## package N; sub new {my ($obj,$n)=@_; bless \$n} @@ -99,7 +112,7 @@ EXPECT ######## %@x=0; EXPECT -Can't modify hash deref in repeat at - line 1, near "0;" +Can't modify hash dereference in repeat (x) at - line 1, near "0;" Execution of - aborted due to compilation errors. ######## $_="foo"; @@ -249,6 +262,15 @@ 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]); @@ -340,31 +362,33 @@ 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 at - line 1. +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 bracket at (re_eval 1) line 1, at end of line +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) } +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 +argv begin -init -end -argv <> +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; -select STDERR; $| = 1; print fileno STDERR; +select STDOUT; $| = 1; print fileno STDOUT or die $!; +select STDERR; $| = 1; print fileno STDERR or die $!; EXPECT 1 2 @@ -430,3 +454,275 @@ 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