perl

 view release on metacpan or  search on metacpan

lib/overload.pm  view on Meta::CPAN

        }
        elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) {
            # Can't use C<ref $_[1] eq "CODE"> above as code references can be
            # blessed, and C<ref> would return the package the ref is blessed into.
            if (warnings::enabled) {
                $_ [1] = "undef" unless defined $_ [1];
                warnings::warn ("'$_[1]' is not a code reference");
            }
        }
        else {
            $^H{$_[0]} = $_[1];
            $^H |= $constants{$_[0]};
        }
        shift, shift;
    }
}

sub remove_constant {
    # Arguments: what, sub
    while (@_) {
        delete $^H{$_[0]};
        $^H &= ~ $constants{$_[0]};
        shift, shift;
    }
}

1;

__END__

=head1 NAME

pod/perl5160delta.pod  view on Meta::CPAN

localize C<%^H> during compilation if it
was empty at the time the C<eval> call itself was compiled.  This could
lead to scary side effects, like C<use re "/m"> enabling other flags that
the surrounding code was trying to enable for its caller [perl #68750].

=item *

C<eval $string> and C<require> no longer localize hints (C<$^H> and C<%^H>)
at run time, but only during compilation of the $string or required file.
This makes C<BEGIN { $^H{foo}=7 }> equivalent to
C<BEGIN { eval '$^H{foo}=7' }> [perl #70151].

=item *

Creating a BEGIN block from XS code (via C<newXS> or C<newATTRSUB>) would,
on completion, make the hints of the current compiling code the current
hints.  This could cause warnings to occur in a non-warning scope.

=back

=head2 Copy-on-write scalars

t/comp/hints.t  view on Meta::CPAN

{
    BEGIN {
	# Make sure %^H is clear and not localised, to begin with
	%^H = ();
	$^H = 0;
    }
    DESTROY { %^H }
    {
	{
	    BEGIN {
		$^H{foom} = bless[];
	    }
	} # scope exit triggers destructor, which autovivifies a non-
	  # magical %^H
	BEGIN {
	    # Here we have the %^H created by DESTROY, which is
	    # not localised
	    $^H{112444} = 'baz';
	}
    } # %^H leaks on scope exit
    BEGIN { @keez = keys %^H }

t/japh/abigail.t  view on Meta::CPAN

#######  Self modifying code 1
$_ = "goto F.print chop;\n=rekcaH lreP rehtona tsuJ";F1:eval
SWITCHES: -w

#######  Overloaded constants 1
BEGIN {$^H {q} = sub {pop and pop and print pop}; $^H = 2**4.2**12}
"Just "; "another "; "Perl "; "Hacker";
SKIP_OS: qnx

#######  Overloaded constants 2
BEGIN {$^H {q} = sub {$_ [1] =~ y/S-ZA-IK-O/q-tc-fe-m/d; $_ [1]}; $^H = 0x28100}
print "Just another PYTHON hacker\n";
EXPECT: $JaPh

#######  Overloaded constants 3
BEGIN {$^H {join "" => ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub
           {["", "Just ", "another ", "Perl ", "Hacker\n"] -> [shift]};
       $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4}
print 1, 2, 3, 4;

#######  Overloaded constants 4
BEGIN {$^H {join "" => ("a" .. "z") [8, 13, 19, 4, 6, 4, 17]} = sub
           {["", "Just ", "another ", "Perl ", "Hacker"] -> [shift]};
       $^H = hex join "" => reverse map {int ($_ / 2)} 0 .. 4}
print 1, 2, 3, 4, "\n";

#######  Overloaded constants 5
BEGIN {my $x = "Knuth heals rare project\n";
       $^H {integer} = sub {my $y = shift; $_ = substr $x => $y & 0x1F, 1;
       $y > 32 ? uc : lc}; $^H = hex join "" => 2, 1, 1, 0, 0}
print 52,2,10,23,16,8,1,19,3,6,15,12,5,49,21,14,9,11,36,13,22,32,7,18,24;

t/lib/warnings/toke  view on Meta::CPAN

}
no warnings "uninitialized";
$_= "";
s//\3000/;
s//"\x{180};;s\221(*$@$`\241\275";/gee;
s//"s\221\302\302\302\302\302\302\302$@\241\275";/gee;
EXPECT
########
# NAME  [perl #130666] Assertion failure
no warnings "uninitialized";
BEGIN{$^H=-1};my $l; s�$0[$l]��
EXPECT
########
# NAME  [perl #129036] Assertion failure
BEGIN{$0="";$^H=hex join""=>A00000}p?
EXPECT
OPTION fatal
syntax error at - line 1, at EOF
Execution of - aborted due to compilation errors.
########
# NAME  [perl #130655]

t/re/pat.t  view on Meta::CPAN

		\A (?! .* ^ \s+ - )
	    }msx, { stderr => 1 }, "Offsets in debug output are not negative");
	}
    }
    {
        # buffer overflow

        # This test also used to leak - fixed by the commit which added
        # this line.

        fresh_perl_is("BEGIN{\$^H=0x200000}\ns/[(?{//xx",
                      "Unmatched [ in regex; marked by <-- HERE in m/[ <-- HERE (?{/ at (eval 1) line 1.\n",
                      {}, "buffer overflow for regexp component");
    }
    {
        # [perl #129281] buffer write overflow, detected by ASAN, valgrind
        fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much");
    }
    {
        # RT #131893 - fails with ASAN -fsanitize=undefined
        fresh_perl_is('qr/0(0?(0||00*))|/', '', {}, "integer overflow during compilation");