require 'test.pl';
use strict qw(refs subs);
+use re ();
-plan(119);
+plan(196);
# Test glob operations.
$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();
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.
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');
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];
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');
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'};
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
# 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);
projects / p5sagit/p5-mst-13.2.git / blobdiff