view release on metacpan or  search on metacpan

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

      runperl(
	prog => 'BEGIN { defined *{q=-=} } print qq-ok\n- if tied %-',
      ),
     "ok\n",
     'defined *{"-"} does not stop %- from working';
}

SKIP: {
    skip_if_miniperl("No XS in miniperl", 1);

    for ( [qw( %! Errno )] ) {
	my ($var, $mod) = @$_;
	my $modfile = $mod =~ s|::|/|gr . ".pm";
	fresh_perl_is
	   qq 'sub UNIVERSAL::AUTOLOAD{}
	       $mod\::foo() if 0;
	       $var;
	       print "ok\\n" if \$INC{"$modfile"}',
	  "ok\n",
	   { switches => [ '-X' ] },
	  "$var still loads $mod when stash and UNIVERSAL::AUTOLOAD exist";
    }
}

# ${^LAST_FH}
() = tell STDOUT;
is ${^LAST_FH}, \*STDOUT, '${^LAST_FH} after tell';
() = tell STDIN;
is ${^LAST_FH}, \*STDIN, '${^LAST_FH} after another tell';
{
    my $fh = *STDOUT;
    () = tell $fh;
    is ${^LAST_FH}, \$fh, '${^LAST_FH} referencing lexical coercible glob';
}
# This also tests that ${^LAST_FH} is a weak reference:
is ${^LAST_FH}, undef, '${^LAST_FH} is undef when PL_last_in_gv is NULL';

# all of these would set PL_last_in_gv to a non-GV which would
# assert when referenced by the magic for ${^LAST_FH}.
# The approach to fixing this has changed (#128263), but it's still useful
# to check each op.
for my $code ('tell $0', 'sysseek $0, 0, 0', 'seek $0, 0, 0', 'eof $0') {
    fresh_perl_is("$code; print defined \${^LAST_FH} ? qq(not ok\n) : qq(ok\n)", "ok\n",
                  undef, "check $code doesn't define \${^LAST_FH}");
}

# $|
fresh_perl_is 'print $| = ~$|', "1\n", {switches => ['-l']},
 '[perl #4760] print $| = ~$|';
fresh_perl_is
 'select f; undef *f; ${q/|/}; print STDOUT qq|ok\n|', "ok\n", {},
 '[perl #115206] no crash when vivifying $| while *{+select}{IO} is undef';

# ${^OPEN} and $^H interaction
# Setting ${^OPEN} causes $^H to change, but setting $^H would only some-
# times make ${^OPEN} change, depending on whether it was in the same BEGIN
# block.  Don't test actual values (subject to change); just test for
# consistency.
my @stuff;
eval '
    BEGIN { ${^OPEN} = "a\0b"; $^H = 0;          push @stuff, ${^OPEN} }
    BEGIN { ${^OPEN} = "a\0b"; $^H = 0 } BEGIN { push @stuff, ${^OPEN} }
1' or die $@;
is $stuff[0], $stuff[1], '$^H modifies ${^OPEN} consistently';

# deleting $::{"\cH"}
is runperl(prog => 'delete $::{qq-\cH-}; ${^OPEN}=foo; print qq-ok\n-'),
  "ok\n",
  'deleting $::{"\cH"}';

# Tests for some non-magic names:
is ${^MPE}, undef, '${^MPE} starts undefined';
is ++${^MPE}, 1, '${^MPE} can be incremented';

# This one used to behave as ${^MATCH} due to a missing break:
is ${^MPEN}, undef, '${^MPEN} starts undefined';
# This one used to croak due to that missing break:
is ++${^MPEN}, 1, '${^MPEN} can be incremented';

{
    no warnings 'deprecated';
    eval { ${^E_NCODING} = 1 };
    is $@, "", 'Setting ${^E_NCODING} does nothing';
    $_ = ${^E_NCODING};
    pass('can read ${^E_NCODING} without blowing up');
    is $_, 1, '${^E_NCODING} is whatever it was set to';
}

{
    my $warned = 0;
    local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; };
    unshift @RT12608::A::ISA, qw(RT12608::B RT12608::C);
    is $warned, 0, '[perl #126082] unshifting onto @ISA doesn\'t trigger set magic for each item';
}

{
    my $warned = 0;
    local $SIG{__WARN__} = sub { ++$warned if $_[0] =~ /Use of uninitialized value in unshift/; print "# @_"; };

    my $x; tie $x, 'RT12608::F';
    unshift @RT12608::X::ISA, $x, "RT12608::Z";
    is $warned, 0, '[perl #126082] PL_delaymagic correctly/saved restored when pushing/unshifting onto @ISA';

    package RT12608::F;
    use parent 'Tie::Scalar';
    sub TIESCALAR { bless {}; }
    sub FETCH { push @RT12608::G::ISA, "RT12608::H"; "RT12608::Y"; }
}


# ^^^^^^^^^ New tests go here ^^^^^^^^^

SKIP: {
    skip "Win32 needs XS for env/shell tests", 20
        if $Is_MSWin32 && is_miniperl;

 SKIP: {
	skip("clearing \%ENV is not safe when running under valgrind or on VMS or on z/OS in ASCII mode")
	    if $ENV{PERL_VALGRIND} || $Is_VMS || ($Is_ZOS && ord "A" == 65);

	    $PATH = $ENV{PATH};
	    $SYSTEMROOT = $ENV{SYSTEMROOT} if exists $ENV{SYSTEMROOT}; # win32