perl
view release on metacpan or search on metacpan
cpan/autodie/lib/autodie/Scope/Guard.pm view on Meta::CPAN
__END__
=head1 NAME
autodie::Scope::Guard - Wrapper class for calling subs at end of scope
=head1 SYNOPSIS
use autodie::Scope::Guard;
$^H{'my-key'} = autodie::Scope::Guard->new(sub {
print "Hallo world\n";
});
=head1 DESCRIPTION
This class is used to bless perl subs so that they are invoked when
they are destroyed. This is mostly useful for ensuring the code is
invoked at end of scope. This module is not a part of autodie's
public API.
cpan/autodie/lib/autodie/Scope/GuardStack.pm view on Meta::CPAN
sub new {
my ($class) = @_;
return bless([], $class);
}
sub push_hook {
my ($self, $hook) = @_;
my $h_key = $H_KEY_STEM . ($COUNTER++);
my $size = @{$self};
$^H{$h_key} = autodie::Scope::Guard->new(sub {
# Pop the stack until we reach the right size
# - this may seem weird, but it is to avoid relying
# on "destruction order" of keys in %^H.
#
# Example:
# {
# use autodie; # hook 1
# no autodie; # hook 2
# use autodie; # hook 3
# }
ext/re/re.pm view on Meta::CPAN
setcolor() if $s =~/color/i;
_load_unload($on);
$seen_debug = 1;
} elsif (exists $bitmask{$s}) {
$bits |= $bitmask{$s};
} elsif ($EXPORT_OK{$s}) {
require Exporter;
re->export_to_level(2, 're', $s);
} elsif ($s eq 'strict') {
if ($on) {
$^H{reflags} |= $reflags{$s};
warnings::warnif('experimental::re_strict',
"\"use re 'strict'\" is experimental");
# Turn on warnings if not already done.
if (! warnings::enabled('regexp')) {
require warnings;
warnings->import('regexp');
$^H{re_strict} = 1;
}
}
else {
$^H{reflags} &= ~$reflags{$s} if $^H{reflags};
# Turn off warnings if we turned them on.
warnings->unimport('regexp') if $^H{re_strict};
}
if ($^H{reflags}) {
$^H |= $flags_hint;
}
else {
$^H &= ~$flags_hint;
}
ext/re/re.pm view on Meta::CPAN
.qq 'are exclusive'
);
}
else {
Carp::carp(
qq 'The "$seen_charset" flag may not appear '
.qq 'twice'
);
}
}
$^H{reflags_charset} = $reflags{$_};
$seen_charset = $_;
}
else {
delete $^H{reflags_charset}
if defined $^H{reflags_charset}
&& $^H{reflags_charset} == $reflags{$_};
}
} elsif (exists $reflags{$_}) {
if ($_ eq 'x') {
$x_count++;
if ($x_count > 2) {
require Carp;
Carp::carp(
qq 'The "x" flag may only appear a maximum of twice'
);
}
ext/re/re.pm view on Meta::CPAN
? $reflags |= $reflags{$_}
: ($reflags &= ~$reflags{$_});
} else {
require Carp;
Carp::carp(
qq'Unknown regular expression flag "$_"'
);
next ARG;
}
}
($^H{reflags} = $reflags or defined $^H{reflags_charset})
? $^H |= $flags_hint
: ($^H &= ~$flags_hint);
} else {
require Carp;
if ($seen_debug && defined $flags{$s}) {
Carp::carp("Use \"Debug\" not \"debug\", to list debug types"
. " in \"re\". \"$s\" ignored");
}
else {
Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
lib/B/Deparse.t view on Meta::CPAN
print sort(foo('bar'));
>>>>
print sort(foo('bar'));
####
# substr assignment
substr(my $a, 0, 0) = (foo(), bar());
$a++;
####
# This following line works around an unfixed bug that we are not trying to
# test for here:
# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
# hint hash
BEGIN { $^H{'foo'} = undef; }
{
BEGIN { $^H{'bar'} = undef; }
{
BEGIN { $^H{'baz'} = undef; }
{
print $_;
}
print $_;
}
print $_;
}
BEGIN { $^H{q[']} = '('; }
print $_;
####
# This following line works around an unfixed bug that we are not trying to
# test for here:
# CONTEXT BEGIN { $^H{a} = "b"; delete $^H{a} } # make %^H localised
# hint hash changes that serialise the same way with sort %hh
BEGIN { $^H{'a'} = 'b'; }
{
BEGIN { $^H{'b'} = 'a'; delete $^H{'a'}; }
print $_;
}
print $_;
####
# [perl #47361] do({}) and do +{} (variants of do-file)
do({});
do +{};
sub foo::do {}
package foo;
CORE::do({});
lib/_charnames.pm view on Meta::CPAN
# At runtime, but currently not at compile time, %^H gets
# stringified, so un-stringify back to the original data structures.
# These get thrown away by perl before the next invocation
# Also fill in the hash with the non-stringified data.
# N.B. New fields must be also added to %dummy_H
%{$^H{charnames_name_aliases}} = split ',',
$hints_ref->{charnames_stringified_names};
%{$^H{charnames_ord_aliases}} = split ',',
$hints_ref->{charnames_stringified_ords};
$^H{charnames_scripts} = $hints_ref->{charnames_scripts};
$^H{charnames_full} = $hints_ref->{charnames_full};
$^H{charnames_loose} = $hints_ref->{charnames_loose};
$^H{charnames_short} = $hints_ref->{charnames_short};
}
my $loose = $regex_loose || $^H{charnames_loose};
my $lookup_name; # Input name suitably modified for grepping for in the
# table
# User alias should be checked first or else can't override ours, and if we
# were to add any, could conflict with theirs.
if (! $regex_loose && exists $^H{charnames_ord_aliases}{$name}) {
$result = $^H{charnames_ord_aliases}{$name};
lib/_charnames.pm view on Meta::CPAN
# Those remaining hyphens were originally at the beginning or end of
# a word, so they can match either a blank before or after, but not
# both. (Keep in mind that they have been quoted, so are a '\-'
# sequence)
$lookup_name =~ s/\\ -/(?:- | -)/xg;
}
# Do the lookup in the full table if asked for, and if succeeds
# save the offsets and set where to cache the result.
if (($loose || $^H{charnames_full}) && $txt =~ /^$lookup_name$/m) {
@off = ($-[0], $+[0]);
$cache_ref = ($loose) ? \%loose_names_cache : \%full_names_cache;
}
elsif ($regex_loose) {
# Currently don't allow :short when this is set
return;
}
else {
# Here, didn't look for, or didn't find the name.
lib/_charnames.pm view on Meta::CPAN
sub import
{
shift; ## ignore class name
populate_txt() unless $txt;
if (not @_) {
carp("'use charnames' needs explicit imports list");
}
$^H{charnames} = \&charnames ;
$^H{charnames_ord_aliases} = {};
$^H{charnames_name_aliases} = {};
$^H{charnames_inverse_ords} = {};
# New fields must be added to %dummy_H, and the code in lookup_name()
# that copies fields from the runtime structure
##
## fill %h keys with our @_ args.
##
my ($promote, %h, @args) = (0);
while (my $arg = shift) {
if ($arg eq ":alias") {
@_ or
lib/_charnames.pm view on Meta::CPAN
warn "unsupported special '$arg' in charnames";
next;
}
push @args, $arg;
}
@args == 0 && $promote and @args = (":full");
@h{@args} = (1) x @args;
# Don't leave these undefined as are tested for in lookup_names
$^H{charnames_full} = delete $h{':full'} || 0;
$^H{charnames_loose} = delete $h{':loose'} || 0;
$^H{charnames_short} = delete $h{':short'} || 0;
my @scripts = map { uc quotemeta } grep { /^[^:]/ } @args;
##
## If utf8? warnings are enabled, and some scripts were given,
## see if at least we can find one letter from each script.
##
if (warnings::enabled('utf8') && @scripts) {
for my $script (@scripts) {
if (not $txt =~ m/^$script (?:CAPITAL |SMALL )?LETTER /m) {
warnings::warn('utf8', "No such script: '$script'");
$script = quotemeta $script; # Escape it, for use in the re.
}
}
}
# %^H gets stringified, so serialize it ourselves so can extract the
# real data back later.
$^H{charnames_stringified_ords} = join ",", %{$^H{charnames_ord_aliases}};
$^H{charnames_stringified_names} = join ",", %{$^H{charnames_name_aliases}};
$^H{charnames_stringified_inverse_ords} = join ",", %{$^H{charnames_inverse_ords}};
# Modify the input script names for loose name matching if that is also
# specified, similar to the way the base character name is prepared. They
# don't (currently, and hopefully never will) have dashes. These go into a
# regex, and have already been uppercased and quotemeta'd. Squeeze out all
# input underscores, blanks, and dashes. Then convert so will match a blank
# between any characters.
if ($^H{charnames_loose}) {
for (my $i = 0; $i < @scripts; $i++) {
$scripts[$i] =~ s/[_ -]//g;
lib/locale.pm view on Meta::CPAN
$locale::hint_bits = 0x4;
$locale::partial_hint_bits = 0x10; # If pragma has an argument
# The pseudo-category :characters consists of 2 real ones; but it also is
# given its own number, -1, because in the complement form it also has the
# side effect of "use feature 'unicode_strings'"
sub import {
shift; # should be 'locale'; not checked
$^H{locale} = 0 unless defined $^H{locale};
if (! @_) { # If no parameter, use the plain form that changes all categories
$^H |= $locale::hint_bits;
}
else {
my @categories = ( qw(:ctype :collate :messages
:numeric :monetary :time) );
for (my $i = 0; $i < @_; $i++) {
my $arg = $_[$i];
my $complement = $arg =~ s/ : ( ! | not_ ) /:/x;
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
lib/strict.pm view on Meta::CPAN
my $inline_all_explicit_bits = $bits;
*all_explicit_bits = sub () { $inline_all_explicit_bits };
}
sub bits {
my $bits = 0;
my @wrong;
foreach my $s (@_) {
if (exists $bitmask{$s}) {
$^H |= $explicit_bitmask{$s};
$bits |= $bitmask{$s};
}
else {
push @wrong, $s;
}
}
if (@wrong) {
require Carp;
Carp::croak("Unknown 'strict' tag(s) '@wrong'");
t/comp/hints.aux view on Meta::CPAN
our($ri1, $rf1, $rfe1);
BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); }
1;
t/comp/hints.t view on Meta::CPAN
if (${^OPEN}) {
print "not " unless $^H & 0x00020000;
print "ok 2 - \$^H contains HINT_LOCALIZE_HH initially with ${^OPEN}\n";
} else {
print "not " if $^H & 0x00020000;
print "ok 2 - \$^H doesn't contain HINT_LOCALIZE_HH initially\n";
}
}
{
# simulate a pragma -- don't forget HINT_LOCALIZE_HH
BEGIN { $^H |= 0x04020000; $^H{foo} = "a"; }
BEGIN {
print "not " if $^H{foo} ne "a";
print "ok 3 - \$^H{foo} is now 'a'\n";
print "not " unless $^H & 0x00020000;
print "ok 4 - \$^H contains HINT_LOCALIZE_HH while compiling\n";
}
{
BEGIN { $^H |= 0x00020000; $^H{foo} = "b"; }
BEGIN {
print "not " if $^H{foo} ne "b";
print "ok 5 - \$^H{foo} is now 'b'\n";
}
}
BEGIN {
print "not " if $^H{foo} ne "a";
print "ok 6 - \$^H{foo} restored to 'a'\n";
}
# The pragma settings disappear after compilation
t/comp/hints.t view on Meta::CPAN
print "not " if $^H & 0x00020000;
print "ok 8 - \$^H doesn't contain HINT_LOCALIZE_HH while finishing compilation\n";
}
}
{
BEGIN{$^H{x}=1};
for my $tno (15..16) {
eval q(
BEGIN {
print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
}
$^H{y} = 1;
);
if ($@) {
(my $str = $@)=~s/^/# /gm;
print "not ok $tno\n$str\n";
}
}
}
{
BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
print +($ri0 & 0x04000000 ? "" : "not "), "ok 17 - \$^H correct before require\n";
print +($rf0 eq "z" ? "" : "not "), "ok 18 - \$^H{foo} correct before require\n";
our($ra1, $ri1, $rf1, $rfe1);
BEGIN { require "comp/hints.aux"; }
print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 19 - \$^H cleared for require\n";
print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 20 - \$^H{foo} cleared for require\n";
our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
print +($ri2 & 0x04000000 ? "" : "not "), "ok 21 - \$^H correct after require\n";
print +($rf2 eq "z" ? "" : "not "), "ok 22 - \$^H{foo} correct after require\n";
}
# [perl #73174]
{
my $res;
BEGIN { $^H{73174} = "foo" }
BEGIN { $res = ($^H{73174} // "") }
t/comp/hints.t view on Meta::CPAN
}
# [perl #112326]
# this code could cause a crash, due to PL_hints continuing to point to th
# hints hash currently being freed
{
package Foo;
my @h = qw(a 1 b 2);
BEGIN {
$^H{FOO} = bless {};
}
sub DESTROY {
@h = %^H;
delete $INC{strict}; require strict; # boom!
}
my $h = join ':', %h;
# this isn't the main point of the test; the main point is that
# it doesn't crash!
print "not " if $h ne '';
print "ok 29 - #112326\n";
t/comp/hints.t view on Meta::CPAN
print "not " if @keez;
print "ok 30 - %^H does not leak when autovivified in destructor\n";
print "# keys are: @keez\n" if @keez;
# Add new tests above this require, in case it fails.
require './test.pl';
# bug #27040: hints hash was being double-freed
my $result = runperl(
prog => '$^H |= 0x20000; eval q{BEGIN { $^H |= 0x20000 }}',
stderr => 1
);
print "not " if length $result;
print "ok 31 - double-freeing hints hash\n";
print "# got: $result\n" if length $result;
__END__
# Add new tests above require 'test.pl'
t/japh/abigail.t view on Meta::CPAN
####### Here documents 4
$_ = "\x3C\x3C\x45\x4F\x54\n" and s/<<EOT/<<EOT/ee and print;
"Just another Perl Hacker"
EOT
####### 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;
####### v-strings 1
print v74.117.115.116.32;
print v97.110.111.116.104.101.114.32;
print v80.101.114.108.32;
print v72.97.99.107.101.114.10;
####### v-strings 2
t/lib/croak/toke_l1 view on Meta::CPAN
# File is encoded in latin-1 so can have malformed-utf8
__END__
# NAME [perl #129037]
BEGIN{{};$^H=-1}0Ã
EXPECT
Malformed UTF-8 character: \xc3\x0a (unexpected non-continuation byte 0x0a, immediately after start byte 0xc3; need 2 bytes, got 1) at - line 1.
Malformed UTF-8 character (fatal) at - line 1.
########
# NAME [perl #129157]
BEGIN {$^H {q} = sub {pop and-t write gmtime getpwuid @p }; $^H =-6**4,0*215}
"@ust weÃÃÃÃÃÃÃÃÃÃÃtprotobyname"; "9 "Y=n {pop and-p[p };shmr [A
G----C
EXPECT
Malformed UTF-8 character: \xc3\xc3 (unexpected non-continuation byte 0xc3, immediately after start byte 0xc3; need 2 bytes, got 1) at - line 2.
Malformed UTF-8 character (fatal) at - line 2.
########
# NAME [perl #130675]
use utf8;y'0Á''
EXPECT
Malformed UTF-8 character: \xc1\x27 (unexpected non-continuation byte 0x27, immediately after start byte 0xc1; need 2 bytes, got 1) at - line 1.
t/op/attrs.t view on Meta::CPAN
eval 'use attributes __PACKAGE__, \&lent, "-lvalue"; 1' or die;
is $w, "", 'no -lvalue warning on def non-lvalue sub';
no warnings 'misc';
eval 'use attributes __PACKAGE__, \&lent, "lvalue"';
is $w, "", 'no lvalue warnings under no warnings misc';
eval 'use attributes __PACKAGE__, \&ent, "-lvalue"';
is $w, "", 'no -lvalue warnings under no warnings misc';
}
unlike runperl(
prog => 'BEGIN {$^H{a}=b} sub foo:bar{1}',
stderr => 1,
),
qr/Unbalanced/,
'attribute errors do not cause op trees to leak';
package ProtoTest {
sub MODIFY_CODE_ATTRIBUTES { $Proto = prototype $_[1]; () }
sub foo ($) : gelastic {}
}
is $ProtoTest::Proto, '$', 'prototypes are visible in attr handlers';
fresh_perl_is(
'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"} } "\N{a}"',
'Constant(\N{a}) unknown at - line 1, within string' . "\n"
."Execution of - aborted due to compilation errors.\n",
{ stderr => 1 },
'correct output (and no crash) when charnames cannot load for \N{...}'
);
}
fresh_perl_is(
'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"};
$^H{charnames} = "foo" } "\N{a}"',
"Undefined subroutine &main::foo called at - line 2.\n"
."Propagated at - line 2, within string\n"
."Execution of - aborted due to compilation errors.\n",
{ stderr => 1 },
'no crash when charnames cannot load and %^H holds string'
);
fresh_perl_is(
'BEGIN{ ++$_ for @INC{"charnames.pm","_charnames.pm"};
$^H{charnames} = \"foo" } "\N{a}"',
"Not a CODE reference at - line 2.\n"
."Propagated at - line 2, within string\n"
."Execution of - aborted due to compilation errors.\n",
{ stderr => 1 },
'no crash when charnames cannot load and %^H holds string reference'
);
# not fresh_perl_is, as it seems to hide the error
is runperl(
nolib => 1, # -Ilib may also hide the error
t/op/magic.t view on Meta::CPAN
'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';
\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");
( run in 0.856 second using v1.01-cache-2.11-cpan-49f99fa48dc )