view release on metacpan or  search on metacpan

t/op/ref.t  view on Meta::CPAN

    for (@a) {
	$got .= ${\$_};
	$got .= ';';
    }
    is ($got, ";good;");
}

# This test is the reason for postponed destruction in sv_unref
$a = [1,2,3];
$a = $a->[1];
is ($a, 2);

# This test used to coredump. The BEGIN block is important as it causes the
# op that created the constant reference to be freed. Hence the only
# reference to the constant string "pass" is in $a. The hack that made
# sure $a = $a->[1] would work didn't work with references to constants.


foreach my $lexical ('', 'my $a; ') {
  my $expect = "pass\n";
  my $result = runperl (switches => ['-wl'], stderr => 1,
    prog => $lexical . 'BEGIN {$a = \q{pass}}; $a = $$a; print $a');

  is ($?, 0);
  is ($result, $expect);
}

$test = curr_test();
sub x::DESTROY {print "ok ", $test + shift->[0], "\n"}
{ my $a1 = bless [3],"x";
  my $a2 = bless [2],"x";
  { my $a3 = bless [1],"x";
    my $a4 = bless [0],"x";
    567;
  }
}
curr_test($test+4);

is (runperl (switches=>['-l'],
	     prog=> 'print 1; print qq-*$\*-;print 1;'),
    "1\n*\n*\n1\n");

# bug #21347

runperl(prog => 'sub UNIVERSAL::AUTOLOAD { qr// } a->p' );
is ($?, 0, 'UNIVERSAL::AUTOLOAD called when freeing qr//');

runperl(prog => 'sub UNIVERSAL::DESTROY { warn } bless \$a, A', stderr => 1);
is ($?, 0, 'warn called inside UNIVERSAL::DESTROY');


# bug #22719

runperl(prog => 'sub f { my $x = shift; *z = $x; } f({}); f();');
is ($?, 0, 'coredump on typeglob = (SvRV && !SvROK)');

# bug #27268: freeing self-referential typeglobs could trigger
# "Attempt to free unreferenced scalar" warnings

is (runperl(
    prog => 'use Symbol;my $x=bless \gensym,q{t}; print;*$$x=$x',
    stderr => 1
), '', 'freeing self-referential typeglob');

# using a regex in the destructor for STDOUT segfaulted because the
# REGEX pad had already been freed (ithreads build only). The
# object is required to trigger the early freeing of GV refs to STDOUT

TODO: {
    local $TODO = "works but output through pipe is mangled" if $^O eq 'VMS';
    like (runperl(
        prog => '$x=bless[]; sub IO::Handle::DESTROY{$_=q{bad};s/bad/ok/;print}',
        stderr => 1
          ), qr/^(ok)+$/, 'STDOUT destructor');
}

{
    no strict 'refs';
    $name8 = chr 163;
    $name_utf8 = $name8 . chr 256;
    chop $name_utf8;

    is ($$name8, undef, 'Nothing before we start');
    is ($$name_utf8, undef, 'Nothing before we start');
    $$name8 = "Pound";
    is ($$name8, "Pound", 'Accessing via 8 bit symref works');
    is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
}

{
    no strict 'refs';
    $name_utf8 = $name = chr 9787;
    utf8::encode $name_utf8;

    is (length $name, 1, "Name is 1 char");
    is (length $name_utf8, 3, "UTF8 representation is 3 chars");

    is ($$name, undef, 'Nothing before we start');
    is ($$name_utf8, undef, 'Nothing before we start');
    $$name = "Face";
    is ($$name, "Face", 'Accessing via Unicode symref works');
    is ($$name_utf8, undef,
	'Accessing via the UTF8 byte sequence gives nothing');
}

{
    no strict 'refs';
    $name1 = "\0Chalk";
    $name2 = "\0Cheese";

    isnt ($name1, $name2, "They differ");

    is ($$name1, undef, 'Nothing before we start (scalars)');
    is ($$name2, undef, 'Nothing before we start');
    $$name1 = "Yummy";
    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,