X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fref.t;h=aca94a35678aa5385edede542641bb02372c0319;hb=e66590ee0c794dd404055173204d6a0057f5d90d;hp=1c713a977e6887278b3474823dbae305fe99e979;hpb=431529dbf3ead68001f1ed06fd4712dec7000e8f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/ref.t b/t/op/ref.t old mode 100755 new mode 100644 index 1c713a9..aca94a3 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -7,8 +7,9 @@ BEGIN { require 'test.pl'; use strict qw(refs subs); +use re (); -plan(119); +plan(196); # Test glob operations. @@ -54,11 +55,6 @@ $BAR = \$BAZ; $BAZ = "hit"; is ($$$FOO, 'hit'); -# test that ref(vstring) makes sense -my $vstref = \v1; -is (ref($vstref), "VSTRING", "ref(vstr) eq VSTRING"); -like ( $vstref, qr/VSTRING\(0x[0-9a-f]+\)/, '\vstr is also VSTRING'); - # Test references to real arrays. my $test = curr_test(); @@ -129,11 +125,77 @@ $subrefref = \\&mysub2; is ($$subrefref->("GOOD"), "good"); sub mysub2 { lc shift } +# Test REGEXP assignment + +{ + my $x = qr/x/; + my $str = "$x"; # regex stringification may change + + my $y = $$x; + is ($y, $str, "bare REGEXP stringifies correctly"); + ok (eval { "x" =~ $y }, "bare REGEXP matches correctly"); + + my $z = \$y; + ok (re::is_regexp($z), "new ref to REXEXP passes is_regexp"); + is ($z, $str, "new ref to REGEXP stringifies correctly"); + ok (eval { "x" =~ $z }, "new ref to REGEXP matches correctly"); +} +{ + my ($x, $str); + { + my $y = qr/x/; + $str = "$y"; + $x = $$y; + } + is ($x, $str, "REGEXP keeps a ref to its mother_re"); + ok (eval { "x" =~ $x }, "REGEXP with mother_re still matches"); +} + # Test the ref operator. -is (ref $subref, 'CODE'); -is (ref $ref, 'ARRAY'); -is (ref $refref, 'HASH'); +sub PVBM () { 'foo' } +{ my $dummy = index 'foo', PVBM } + +my $pviv = 1; "$pviv"; +my $pvnv = 1.0; "$pvnv"; +my $x; + +# we don't test +# tied lvalue => SCALAR, as we haven't tested tie yet +# BIND, 'cos we can't create them yet +# REGEXP, 'cos that requires overload or Scalar::Util +# LVALUE ref, 'cos I can't work out how to create one :) + +for ( + [ 'undef', SCALAR => \undef ], + [ 'constant IV', SCALAR => \1 ], + [ 'constant NV', SCALAR => \1.0 ], + [ 'constant PV', SCALAR => \'f' ], + [ 'scalar', SCALAR => \$x ], + [ 'PVIV', SCALAR => \$pviv ], + [ 'PVNV', SCALAR => \$pvnv ], + [ 'PVMG', SCALAR => \$0 ], + [ 'PVBM', SCALAR => \PVBM ], + [ 'vstring', VSTRING => \v1 ], + [ 'ref', REF => \\1 ], + [ 'lvalue', LVALUE => \substr($x, 0, 0) ], + [ 'named array', ARRAY => \@ary ], + [ 'anon array', ARRAY => [ 1 ] ], + [ 'named hash', HASH => \%whatever ], + [ 'anon hash', HASH => { a => 1 } ], + [ 'named sub', CODE => \&mysub, ], + [ 'anon sub', CODE => sub { 1; } ], + [ 'glob', GLOB => \*foo ], + [ 'format', FORMAT => *STDERR{FORMAT} ], +) { + my ($desc, $type, $ref) = @$_; + is (ref $ref, $type, "ref() for ref to $desc"); + like ("$ref", qr/^$type\(0x[0-9a-f]+\)$/, "stringify for ref to $desc"); +} + +is (ref *STDOUT{IO}, 'IO::Handle', 'IO refs are blessed into IO::Handle'); +like (*STDOUT{IO}, qr/^IO::Handle=IO\(0x[0-9a-f]+\)$/, + 'stringify for IO refs'); # Test anonymous hash syntax. @@ -427,6 +489,10 @@ TODO: { is ($$name1, "Yummy", 'Accessing via the correct name works'); is ($$name2, undef, 'Accessing via a different NUL-containing name gives nothing'); + # defined uses a different code path + ok (defined $$name1, 'defined via the correct name works'); + ok (!defined $$name2, + 'defined via a different NUL-containing name gives nothing'); is ($name1->[0], undef, 'Nothing before we start (arrays)'); is ($name2->[0], undef, 'Nothing before we start'); @@ -434,6 +500,9 @@ TODO: { is ($name1->[0], "Yummy", 'Accessing via the correct name works'); is ($name2->[0], undef, 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $name1->[0], 'defined via the correct name works'); + ok (!defined$name2->[0], + 'defined via a different NUL-containing name gives nothing'); my (undef, $one) = @{$name1}[2,3]; my (undef, $two) = @{$name2}[2,3]; @@ -445,6 +514,9 @@ TODO: { is ($one, "Yummy", 'Accessing via the correct name works'); is ($two, undef, 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $one, 'defined via the correct name works'); + ok (!defined $two, + 'defined via a different NUL-containing name gives nothing'); is ($name1->{PWOF}, undef, 'Nothing before we start (hashes)'); is ($name2->{PWOF}, undef, 'Nothing before we start'); @@ -452,6 +524,9 @@ TODO: { is ($name1->{PWOF}, "Yummy", 'Accessing via the correct name works'); is ($name2->{PWOF}, undef, 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $name1->{PWOF}, 'defined via the correct name works'); + ok (!defined $name2->{PWOF}, + 'defined via a different NUL-containing name gives nothing'); my (undef, $one) = @{$name1}{'SNIF', 'BEEYOOP'}; my (undef, $two) = @{$name2}{'SNIF', 'BEEYOOP'}; @@ -463,11 +538,20 @@ TODO: { is ($one, "Yummy", 'Accessing via the correct name works'); is ($two, undef, 'Accessing via a different NUL-containing name gives nothing'); + ok (defined $one, 'defined via the correct name works'); + ok (!defined $two, + 'defined via a different NUL-containing name gives nothing'); $name1 = "Left"; $name2 = "Left\0Right"; my $glob2 = *{$name2}; - isnt ($glob1, $glob2, "We get different typeglobs"); + is ($glob1, undef, "We get different typeglobs. In fact, undef"); + + *{$name1} = sub {"One"}; + *{$name2} = sub {"Two"}; + + is (&{$name1}, "One"); + is (&{$name2}, "Two"); } # test derefs after list slice @@ -489,16 +573,57 @@ is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' ); # test dereferencing errors { - eval q/ ${*STDOUT{IO}} /; - like($@, qr/Not a SCALAR reference/); - eval q/ @{*STDOUT{IO}} /; - like($@, qr/Not an ARRAY reference/); - eval q/ %{*STDOUT{IO}} /; - like($@, qr/Not a HASH reference/); - eval q/ &{*STDOUT{IO}} /; - like($@, qr/Not a CODE reference/); + format STDERR = +. + my $ref; + foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) { + eval q/ $$ref /; + like($@, qr/Not a SCALAR reference/, "Scalar dereference"); + eval q/ @$ref /; + like($@, qr/Not an ARRAY reference/, "Array dereference"); + eval q/ %$ref /; + like($@, qr/Not a HASH reference/, "Hash dereference"); + eval q/ &$ref /; + like($@, qr/Not a CODE reference/, "Code dereference"); + } + + $ref = *STDERR{FORMAT}; + eval q/ *$ref /; + like($@, qr/Not a GLOB reference/, "Glob dereference"); + + $ref = *STDOUT{IO}; + eval q/ *$ref /; + is($@, '', "Glob dereference of PVIO is acceptable"); + + is($ref, *{$ref}{IO}, "IO slot of the temporary glob is set correctly"); } +# these will segfault if they fail + +my $pvbm = PVBM; +my $rpvbm = \$pvbm; + +ok (!eval { *$rpvbm }, 'PVBM ref is not a GLOB ref'); +ok (!eval { *$pvbm }, 'PVBM is not a GLOB ref'); +ok (!eval { $$pvbm }, 'PVBM is not a SCALAR ref'); +ok (!eval { @$pvbm }, 'PVBM is not an ARRAY ref'); +ok (!eval { %$pvbm }, 'PVBM is not a HASH ref'); +ok (!eval { $pvbm->() }, 'PVBM is not a CODE ref'); +ok (!eval { $rpvbm->foo }, 'PVBM is not an object'); + +# bug 24254 +is( runperl(stderr => 1, prog => 'map eval qq(exit),1 for 1'), ""); +is( runperl(stderr => 1, prog => 'eval { for (1) { map { die } 2 } };'), ""); +is( runperl(stderr => 1, prog => 'for (125) { map { exit } (213)}'), ""); +my $hushed = $^O eq 'VMS' ? 'use vmsish qw(hushed);' : ''; +is( runperl(stderr => 1, prog => $hushed . 'map die,4 for 3'), "Died at -e line 1.\n"); +is( runperl(stderr => 1, prog => $hushed . 'grep die,4 for 3'), "Died at -e line 1.\n"); +is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "Died at -e line 1.\n"); + +# bug 57564 +is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); + + # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. $test = curr_test(); curr_test($test + 3);