diff options
Diffstat (limited to 'contrib/perl5/t/op/misc.t')
| -rwxr-xr-x | contrib/perl5/t/op/misc.t | 603 |
1 files changed, 0 insertions, 603 deletions
diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t deleted file mode 100755 index 35437a4..0000000 --- a/contrib/perl5/t/op/misc.t +++ /dev/null @@ -1,603 +0,0 @@ -#!./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'; -$ENV{PERL5LIB} = "../lib"; - -$|=1; - -undef $/; -@prgs = split "\n########\n", <DATA>; -print "1..", scalar @prgs, "\n"; - -$tmpfile = "misctmp000"; -1 while -f ++$tmpfile; -END { while($tmpfile && unlink $tmpfile){} } - -$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); - -for (@prgs){ - my $switch; - if (s/^\s*(-\w.*)//){ - $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') { - $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; - } - else { - $results = `./perl $switch $tmpfile 2>&1`; - } - $status = $?; - $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; - $expected =~ s/\n+$//; - if ( $results ne $expected ) { - print STDERR "PROG: $switch\n$prog\n"; - print STDERR "EXPECTED:\n$expected\n"; - print STDERR "GOT:\n$results\n"; - print "not "; - } - print "ok ", ++$i, "\n"; -} - -__END__ -()=() -######## -$a = ":="; split /($a)/o, "a:=b:=c"; print "@_" -EXPECT -a := b := c -######## -$cusp = ~0 ^ (~0 >> 1); -use integer; -$, = " "; -print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; -EXPECT -7 0 0 8 ! -######## -$foo=undef; $foo->go; -EXPECT -Can't call method "go" on an undefined value at - line 1. -######## -BEGIN - { - "foo"; - } -######## -$array[128]=1 -######## -$x=0x0eabcd; print $x->ref; -EXPECT -Can't call method "ref" without a package or object reference at - line 1. -######## -chop ($str .= <DATA>); -######## -close ($banana); -######## -$x=2;$y=3;$x<$y ? $x : $y += 23;print $x; -EXPECT -25 -######## -eval {sub bar {print "In bar";}} -######## -system './perl -ne "print if eof" /dev/null' -######## -chop($file = <DATA>); -######## -package N; -sub new {my ($obj,$n)=@_; bless \$n} -$aa=new N 1; -$aa=12345; -print $aa; -EXPECT -12345 -######## -%@x=0; -EXPECT -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", $_); -EXPECT -foo -######## -push(@a, 1, 2, 3,) -######## -quotemeta "" -######## -for ("ABCDE") { - ⊂ -s/./&sub($&)/eg; -print;} -sub sub {local($_) = @_; -$_ x 4;} -EXPECT -Modification of a read-only value attempted at - line 3. -######## -package FOO;sub new {bless {FOO => BAR}}; -package main; -use strict vars; -my $self = new FOO; -print $$self{FOO}; -EXPECT -BAR -######## -$_="foo"; -s/.{1}//s; -print; -EXPECT -oo -######## -print scalar ("foo","bar") -EXPECT -bar -######## -sub by_number { $a <=> $b; };# inline function for sort below -$as_ary{0}="a0"; -@ordered_array=sort by_number keys(%as_ary); -######## -sub NewShell -{ - local($Host) = @_; - my($m2) = $#Shells++; - $Shells[$m2]{HOST} = $Host; - return $m2; -} - -sub ShowShell -{ - local($i) = @_; -} - -&ShowShell(&NewShell(beach,Work,"+0+0")); -&ShowShell(&NewShell(beach,Work,"+0+0")); -&ShowShell(&NewShell(beach,Work,"+0+0")); -######## - { - package FAKEARRAY; - - sub TIEARRAY - { print "TIEARRAY @_\n"; - die "bomb out\n" unless $count ++ ; - bless ['foo'] - } - sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] } - sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] } - sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; } - } - -eval 'tie @h, FAKEARRAY, fred' ; -tie @h, FAKEARRAY, fred ; -EXPECT -TIEARRAY FAKEARRAY fred -TIEARRAY FAKEARRAY fred -DESTROY -######## -BEGIN { die "phooey\n" } -EXPECT -phooey -BEGIN failed--compilation aborted at - line 1. -######## -BEGIN { 1/$zero } -EXPECT -Illegal division by zero at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## -BEGIN { undef = 0 } -EXPECT -Modification of a read-only value attempted at - line 1. -BEGIN failed--compilation aborted at - line 1. -######## -{ - package foo; - sub PRINT { - shift; - print join(' ', reverse @_)."\n"; - } - sub PRINTF { - shift; - my $fmt = shift; - print sprintf($fmt, @_)."\n"; - } - sub TIEHANDLE { - bless {}, shift; - } - sub READLINE { - "Out of inspiration"; - } - 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 "-- ", <FOO>, " --\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 -######## -@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]); -EXPECT -ok -######## -print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000); -EXPECT -ok -######## -print "ok\n" if ("\0" lt "\xFF"); -EXPECT -ok -######## -open(H,'op/misc.t'); # must be in the 't' directory -stat(H); -print "ok\n" if (-e _ and -f _ and -r _); -EXPECT -ok -######## -sub thing { 0 || return qw(now is the time) } -print thing(), "\n"; -EXPECT -nowisthetime -######## -$ren = 'joy'; -$stimpy = 'happy'; -{ local $main::{ren} = *stimpy; print $ren, ' ' } -print $ren, "\n"; -EXPECT -happy joy -######## -$stimpy = 'happy'; -{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' } -print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n"; -EXPECT -happy joy -######## -package p; -sub func { print 'really ' unless wantarray; 'p' } -sub groovy { 'groovy' } -package main; -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) } -print "bogus\n" unless $s == 7; -######## -my $a = 'outer'; -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 before HERE mark in regex 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 <a b c d e> -begin <a> -check <b> -init <c> -end <d> -argv <e> -######## --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 -######## -my @l = qw(hello.* world); -my $x; - -foreach $x (@l) { - print "before - $x\n"; - $x = "\Q$x\E"; - print "quotemeta - $x\n"; - $x = "\u$x"; - print "ucfirst - $x\n"; - $x = "\l$x"; - print "lcfirst - $x\n"; - $x = "\U$x\E"; - print "uc - $x\n"; - $x = "\L$x\E"; - print "lc - $x\n"; -} -EXPECT -before - hello.* -quotemeta - hello\.\* -ucfirst - Hello\.\* -lcfirst - hello\.\* -uc - HELLO\.\* -lc - hello\.\* -before - world -quotemeta - world -ucfirst - World -lcfirst - world -uc - WORLD -lc - world -######## -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 -######## -# 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' && $Config{cc} =~ /^(cl|gcc)/i; -exit(0) unless $have_setlocale; -my @locales; -if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { - while(<LOCALES>) { - 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 |
