autovivification-0.12/0000750000175000017500000000000012212134712013777 5ustar vincevinceautovivification-0.12/lib/0000750000175000017500000000000012212134712014545 5ustar vincevinceautovivification-0.12/lib/autovivification.pm0000644000175000017500000001510312212134515020474 0ustar vincevincepackage autovivification; use 5.008_003; use strict; use warnings; =head1 NAME autovivification - Lexically disable autovivification. =head1 VERSION Version 0.12 =cut our $VERSION; BEGIN { $VERSION = '0.12'; } =head1 SYNOPSIS no autovivification; my $hashref; my $a = $hashref->{key_a}; # $hashref stays undef if (exists $hashref->{option}) { # Still undef ... } delete $hashref->{old}; # Still undef again $hashref->{new} = $value; # Vivifies to { new => $value } =head1 DESCRIPTION When an undefined variable is dereferenced, it gets silently upgraded to an array or hash reference (depending of the type of the dereferencing). This behaviour is called I and usually does what you mean (e.g. when you store a value) but it may be unnatural or surprising because your variables gets populated behind your back. This is especially true when several levels of dereferencing are involved, in which case all levels are vivified up to the last, or when it happens in intuitively read-only constructs like C. This pragma lets you disable autovivification for some constructs and optionally throws a warning or an error when it would have happened. =cut BEGIN { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); } =head1 METHODS =head2 C no autovivification; # defaults to qw no autovivification qw; no autovivification 'warn'; no autovivification 'strict'; Magically called when C is encountered. Enables the features given in C<@opts>, which can be : =over 4 =item * C<'fetch'> Turns off autovivification for rvalue dereferencing expressions, such as : $value = $arrayref->[$idx] $value = $hashref->{$key} keys %$hashref values %$hashref Starting from perl C<5.11>, it also covers C and C on array references : keys @$arrayref values @$arrayref When the expression would have autovivified, C is returned for a plain fetch, while C and C return C<0> in scalar context and the empty list in list context. =item * C<'exists'> Turns off autovivification for dereferencing expressions that are parts of an C, such as : exists $arrayref->[$idx] exists $hashref->{$key} C<''> is returned when the expression would have autovivified. =item * C<'delete'> Turns off autovivification for dereferencing expressions that are parts of a C, such as : delete $arrayref->[$idx] delete $hashref->{$key} C is returned when the expression would have autovivified. =item * C<'store'> Turns off autovivification for lvalue dereferencing expressions, such as : $arrayref->[$idx] = $value $hashref->{$key} = $value for ($arrayref->[$idx]) { ... } for ($hashref->{$key}) { ... } function($arrayref->[$idx]) function($hashref->{$key}) An exception is thrown if vivification is needed to store the value, which means that effectively you can only assign to levels that are already defined. In the example, this would require C<$arrayref> (resp. C<$hashref>) to already be an array (resp. hash) reference. =item * C<'warn'> Emits a warning when an autovivification is avoided. =item * C<'strict'> Throws an exception when an autovivification is avoided. =back Each call to C B the specified features to the ones already in use in the current lexical scope. When C<@opts> is empty, it defaults to C<< qw >>. =cut my %bits = ( strict => A_HINT_STRICT, warn => A_HINT_WARN, fetch => A_HINT_FETCH, store => A_HINT_STORE, exists => A_HINT_EXISTS, delete => A_HINT_DELETE, ); sub unimport { shift; my $hint = _detag($^H{+(__PACKAGE__)}) || 0; @_ = qw unless @_; $hint |= $bits{$_} for grep exists $bits{$_}, @_; $^H |= 0x00020000; $^H{+(__PACKAGE__)} = _tag($hint); (); } =head2 C use autovivification; # default Perl behaviour use autovivification qw; Magically called when C is encountered. Disables the features given in C<@opts>, which can be the same as for L. Each call to C B the specified features to the ones already in use in the current lexical scope. When C<@opts> is empty, it defaults to restoring the original Perl autovivification behaviour. =cut sub import { shift; my $hint = 0; if (@_) { $hint = _detag($^H{+(__PACKAGE__)}) || 0; $hint &= ~$bits{$_} for grep exists $bits{$_}, @_; } $^H |= 0x00020000; $^H{+(__PACKAGE__)} = _tag($hint); (); } =head1 CONSTANTS =head2 C True if and only if the module could have been built with thread-safety features enabled. This constant only has a meaning when your perl is threaded, otherwise it will always be false. =head2 C True if and only if this module could have been built with fork-safety features enabled. This constant will always be true, except on Windows where it is false for perl 5.10.0 and below. =head1 CAVEATS The pragma doesn't apply when one dereferences the returned value of an array or hash slice, as in C<< @array[$id]->{member} >> or C<< @hash{$key}->{member} >>. This syntax is valid Perl, yet it is discouraged as the slice is here useless since the dereferencing enforces scalar context. If warnings are turned on, Perl will complain about one-element slices. =head1 DEPENDENCIES L 5.8.3. A C compiler. This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard. L (standard since perl 5.6.0). =head1 SEE ALSO L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc autovivification Tests code coverage report is available at L. =head1 ACKNOWLEDGEMENTS Matt S. Trout asked for it. =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2012,2013 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of autovivification autovivification-0.12/t/0000750000175000017500000000000012212134712014242 5ustar vincevinceautovivification-0.12/t/24-hash-numerous.t0000644000175000017500000000522411511133531017457 0ustar vincevince#!perl use strict; use warnings; use Test::More tests => 2 * 2 * 4; my $n = 100; { my $w; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef lexical'; $w = { a => undef }; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, { a => undef },'numerous fetches from a 1-level hashref lexical'; } { our $w; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef global'; $w = { a => undef }; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, { a => undef },'numerous fetches from a 1-level hashref global'; } { my $x; { my @r; no autovivification; @r = @{$x}{qw} for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef lexical'; $x = { a => undef }; { my @r; no autovivification; @r = @{$x->{a}}{qw} for 1 .. $n; } is_deeply $x, { a => undef }, 'numerous slices from a 1-level hashref lexical'; } { our $x; { my @r; no autovivification; @r = @{$x}{qw} for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef global'; $x = { a => undef }; { my @r; no autovivification; @r = @{$x->{a}}{qw} for 1 .. $n; } is_deeply $x, { a => undef }, 'numerous slices from a 1-level hashref global'; } { my $y; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef lexical'; $y = { a => undef }; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, { a => undef },'numerous exists from a 1-level hashref lexical'; } { our $y; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef global'; $y = { a => undef }; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, { a => undef },'numerous exists from a 1-level hashref global'; } { my $z; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef lexical'; $z = { a => undef }; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, { a => undef },'numerous deletes from a 1-level hashref lexical'; } { our $z; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef global'; $z = { a => undef }; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, { a => undef },'numerous deletes from a 1-level hashref global'; } autovivification-0.12/t/34-array-numerous.t0000644000175000017500000000513411511133531017653 0ustar vincevince#!perl use strict; use warnings; use Test::More tests => 2 * 2 * 4; my $n = 100; my $i = 0; { my $w; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef lexical'; $w = [ undef ]; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, [ undef ], 'numerous fetches from a 1-level arrayref lexical'; } { our $w; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef global'; $w = [ undef ]; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, [ undef ], 'numerous fetches from a 1-level arrayref global'; } { my $x; { my @r; no autovivification; @r = @{$x}[0, 1] for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef lexical'; $x = [ undef ]; { my @r; no autovivification; @r = @{$x->[0]}[0, 1] for 1 .. $n; } is_deeply $x, [ undef ], 'numerous slices from a 1-level arrayref lexical'; } { our $x; { my @r; no autovivification; @r = @{$x}[0, 1] for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef global'; $x = [ undef ]; { my @r; no autovivification; @r = @{$x->[0]}[0, 1] for 1 .. $n; } is_deeply $x, [ undef ], 'numerous slices from a 1-level arrayref global'; } { my $y; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef lexical'; $y = [ undef ]; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, [ undef ], 'numerous exists from a 1-level arrayref lexical'; } { our $y; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef global'; $y = [ undef ]; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, [ undef ], 'numerous exists from a 1-level arrayref global'; } { my $z; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef lexical'; $z = [ undef ]; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, [ undef ], 'numerous deletes from a 1-level arrayref lexical'; } { our $z; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef global'; $z = [ undef ]; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, [ undef ], 'numerous deletes from a 1-level arrayref global'; } autovivification-0.12/t/23-hash-tied.t0000644000175000017500000000073711511133531016532 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; BEGIN { eval 'use Tie::Hash; scalar keys %Tie::StdHash::' or plan skip_all => 'Tie::StdHash required to test tied hashes'; defined and diag "Using Tie::StdHash $_" for $Tie::Hash::VERSION; plan tests => 1; } { tie my %x, 'Tie::StdHash'; tie my %y, 'Tie::StdHash'; $x{key} = 'hlagh'; $y{x} = \%x; my $res = do { no autovivification; $y{x}{key}; }; is $res, 'hlagh', 'nested tied hashes'; } autovivification-0.12/t/lib/0000750000175000017500000000000012212134712015010 5ustar vincevinceautovivification-0.12/t/lib/VPIT/0000750000175000017500000000000012212134712015572 5ustar vincevinceautovivification-0.12/t/lib/VPIT/TestHelpers.pm0000644000175000017500000000376712153114560020417 0ustar vincevincepackage VPIT::TestHelpers; use strict; use warnings; my %exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); sub import { my $pkg = caller; while (my ($name, $code) = each %exports) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } } my $test_sub = sub { my $sub = shift; my $stash; if ($INC{'Test/Leaner.pm'}) { $stash = \%Test::Leaner::; } else { require Test::More; $stash = \%Test::More::; } my $glob = $stash->{$sub}; return $glob ? *$glob{CODE} : undef; }; sub skip { $test_sub->('skip')->(@_) } sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } sub diag { my $diag = $test_sub->('diag'); $diag->($_) for @_; } our $TODO; local $TODO; sub load { my ($pkg, $ver, $imports) = @_; my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; my $err; local $@; if (eval "use $spec (); 1") { $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; $ver = 'undef' unless defined $ver; if ($imports) { my @imports = @$imports; my $caller = (caller 1)[0]; local $@; my $res = eval <<"IMPORTER"; package $caller; BEGIN { \$pkg->import(\@imports) } 1; IMPORTER $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; } } else { (my $file = "$pkg.pm") =~ s{::}{/}g; delete $INC{$file}; $err = "Could not load $spec"; } if ($err) { return wantarray ? (0, $err) : 0; } else { diag "Using $pkg $ver"; return 1; } } sub load_or_skip { my ($pkg, $ver, $imports, $tests) = @_; die 'You must specify how many tests to skip' unless defined $tests; my ($loaded, $err) = load($pkg, $ver, $imports); skip $err => $tests unless $loaded; return $loaded; } sub load_or_skip_all { my ($pkg, $ver, $imports) = @_; my ($loaded, $err) = load($pkg, $ver, $imports); skip_all $err unless $loaded; return $loaded; } package VPIT::TestHelpers::Guard; sub new { my ($class, $code) = @_; bless { code => $code }, $class; } sub DESTROY { $_[0]->{code}->() } 1; autovivification-0.12/t/lib/Test/0000750000175000017500000000000012212134712015727 5ustar vincevinceautovivification-0.12/t/lib/Test/Leaner.pm0000644000175000017500000004537412207502475017526 0ustar vincevincepackage Test::Leaner; use 5.006; use strict; use warnings; =head1 NAME Test::Leaner - A slimmer Test::More for when you favor performance over completeness. =head1 VERSION Version 0.05 =cut our $VERSION = '0.05'; =head1 SYNOPSIS use Test::Leaner tests => 10_000; for (1 .. 10_000) { ... is $one, 1, "checking situation $_"; } =head1 DESCRIPTION When profiling some L-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L itself, even though every single test actually involved a costly C. This module aims to be a partial replacement to L in those situations where you want to run a large number of simple tests. Its functions behave the same as their L counterparts, except for the following differences : =over 4 =item * Stringification isn't forced on the test operands. However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one), L honors C<'ne'> overloading, and L honors whichever overloading category corresponds to the specified operator. =item * L, L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. =item * C (the sub C in package C) is not aliased to L. =item * L and L don't special case regular expressions that are passed as C<'/.../'> strings. A string regexp argument is always treated as the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). =item * L throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants). It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator. =item * L doesn't guard for memory cycles. If the two first arguments present parallel memory cycles, the test may result in an infinite loop. =item * The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics. Moreover, this allows a much faster variant of L. =item * C, C, C, C, C, C, C, C blocks and C are not implemented. =back =cut use Exporter (); my $main_process; BEGIN { $main_process = $$; if ("$]" >= 5.008 and $INC{'threads.pm'}) { my $use_ithreads = do { require Config; no warnings 'once'; $Config::Config{useithreads}; }; if ($use_ithreads) { require threads::shared; *THREADSAFE = sub () { 1 }; } } unless (defined &Test::Leaner::THREADSAFE) { *THREADSAFE = sub () { 0 } } } my ($TAP_STREAM, $DIAG_STREAM); my ($plan, $test, $failed, $no_diag, $done_testing); our @EXPORT = qw< plan skip done_testing pass fail ok is isnt like unlike cmp_ok is_deeply diag note BAIL_OUT >; =head1 ENVIRONMENT =head2 C If this environment variable is set, L will replace its functions by those from L. Moreover, the symbols that are imported when you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. This may be useful if your L-based test script fails and you want extra diagnostics. =cut sub _handle_import_args { my @imports; my $i = 0; while ($i <= $#_) { my $item = $_[$i]; my $splice; if (defined $item) { if ($item eq 'import') { push @imports, @{ $_[$i+1] }; $splice = 2; } elsif ($item eq 'no_diag') { lock $plan if THREADSAFE; $no_diag = 1; $splice = 1; } } if ($splice) { splice @_, $i, $splice; } else { ++$i; } } return @imports; } if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { require Test::More; my $leaner_stash = \%Test::Leaner::; my $more_stash = \%Test::More::; my %stubbed; for (@EXPORT) { my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} : undef; unless (defined $replacement) { $stubbed{$_}++; $replacement = sub { @_ = ("$_ is not implemented in this version of Test::More"); goto &croak; }; } no warnings 'redefine'; $leaner_stash->{$_} = $replacement; } my $import = sub { my $class = shift; my @imports = &_handle_import_args; if (@imports == grep /^!/, @imports) { # All imports are negated, or @imports is empty my %negated; /^!(.*)/ and ++$negated{$1} for @imports; push @imports, grep !$negated{$_}, @EXPORT; } my @test_more_imports; for (@imports) { if ($stubbed{$_}) { my $pkg = caller; no strict 'refs'; *{$pkg."::$_"} = $leaner_stash->{$_}; } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) { push @test_more_imports, $_; } else { # Croak for symbols in Test::More but not in Test::Leaner Exporter::import($class, $_); } } my $test_more_import = 'Test::More'->can('import'); return unless $test_more_import; @_ = ( 'Test::More', @_, import => \@test_more_imports, ); { lock $plan if THREADSAFE; push @_, 'no_diag' if $no_diag; } goto $test_more_import; }; no warnings 'redefine'; *import = $import; return 1; } sub NO_PLAN () { -1 } sub SKIP_ALL () { -2 } BEGIN { if (THREADSAFE) { threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing; } lock $plan if THREADSAFE; $plan = undef; $test = 0; $failed = 0; } sub carp { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; warn @_, " at $file line $line.\n"; } sub croak { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; die @_, " at $file line $line.\n"; } sub _sanitize_comment { $_[0] =~ s/\n+\z//; $_[0] =~ s/#/\\#/g; $_[0] =~ s/\n/\n# /g; } =head1 FUNCTIONS The following functions from L are implemented and exported by default. =head2 C plan tests => $count; plan 'no_plan'; plan skip_all => $reason; See L. =cut sub plan { my ($key, $value) = @_; return unless $key; lock $plan if THREADSAFE; croak("You tried to plan twice") if defined $plan; my $plan_str; if ($key eq 'no_plan') { croak("no_plan takes no arguments") if $value; $plan = NO_PLAN; } elsif ($key eq 'tests') { croak("Got an undefined number of tests") unless defined $value; croak("You said to run 0 tests") unless $value; croak("Number of tests must be a positive integer. You gave it '$value'") unless $value =~ /^\+?[0-9]+$/; $plan = $value; $plan_str = "1..$value"; } elsif ($key eq 'skip_all') { $plan = SKIP_ALL; $plan_str = '1..0 # SKIP'; if (defined $value) { _sanitize_comment($value); $plan_str .= " $value" if length $value; } } else { my @args = grep defined, $key, $value; croak("plan() doesn't understand @args"); } if (defined $plan_str) { local $\; print $TAP_STREAM "$plan_str\n"; } exit 0 if $plan == SKIP_ALL; return 1; } sub import { my $class = shift; my @imports = &_handle_import_args; if (@_) { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; &plan; } @_ = ($class, @imports); goto &Exporter::import; } =head2 C skip $reason => $count; See L. =cut sub skip { my ($reason, $count) = @_; lock $plan if THREADSAFE; if (not defined $count) { carp("skip() needs to know \$how_many tests are in the block") unless defined $plan and $plan == NO_PLAN; $count = 1; } elsif ($count =~ /[^0-9]/) { carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?'); $count = 1; } for (1 .. $count) { ++$test; my $skip_str = "ok $test # skip"; if (defined $reason) { _sanitize_comment($reason); $skip_str .= " $reason" if length $reason; } local $\; print $TAP_STREAM "$skip_str\n"; } no warnings 'exiting'; last SKIP; } =head2 C done_testing; done_testing $count; See L. =cut sub done_testing { my ($count) = @_; lock $plan if THREADSAFE; $count = $test unless defined $count; croak("Number of tests must be a positive integer. You gave it '$count'") unless $count =~ /^\+?[0-9]+$/; if (not defined $plan or $plan == NO_PLAN) { $plan = $count; # $plan can't be NO_PLAN anymore $done_testing = 1; local $\; print $TAP_STREAM "1..$plan\n"; } else { if ($done_testing) { @_ = ('done_testing() was already called'); goto &fail; } elsif ($plan != $count) { @_ = ("planned to run $plan tests but done_testing() expects $count"); goto &fail; } } return 1; } =head2 C ok $ok; ok $ok, $desc; See L. =cut sub ok ($;$) { my ($ok, $desc) = @_; lock $plan if THREADSAFE; ++$test; my $test_str = "ok $test"; $ok or do { $test_str = "not $test_str"; ++$failed; }; if (defined $desc) { _sanitize_comment($desc); $test_str .= " - $desc" if length $desc; } local $\; print $TAP_STREAM "$test_str\n"; return $ok; } =head2 C pass; pass $desc; See L. =cut sub pass (;$) { unshift @_, 1; goto &ok; } =head2 C fail; fail $desc; See L. =cut sub fail (;$) { unshift @_, 0; goto &ok; } =head2 C is $got, $expected; is $got, $expected, $desc; See L. =cut sub is ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( (not(defined $got xor defined $expected) and $got eq $expected), $desc, ); goto &ok; } =head2 C isnt $got, $expected; isnt $got, $expected, $desc; See L. =cut sub isnt ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( ((defined $got xor defined $expected) or $got ne $expected), $desc, ); goto &ok; } my %binops = ( 'or' => 'or', 'xor' => 'xor', 'and' => 'and', '||' => 'hor', ('//' => 'dor') x ("$]" >= 5.010), '&&' => 'hand', '|' => 'bor', '^' => 'bxor', '&' => 'band', 'lt' => 'lt', 'le' => 'le', 'gt' => 'gt', 'ge' => 'ge', 'eq' => 'eq', 'ne' => 'ne', 'cmp' => 'cmp', '<' => 'nlt', '<=' => 'nle', '>' => 'ngt', '>=' => 'nge', '==' => 'neq', '!=' => 'nne', '<=>' => 'ncmp', '=~' => 'like', '!~' => 'unlike', ('~~' => 'smartmatch') x ("$]" >= 5.010), '+' => 'add', '-' => 'substract', '*' => 'multiply', '/' => 'divide', '%' => 'modulo', '<<' => 'lshift', '>>' => 'rshift', '.' => 'concat', '..' => 'flipflop', '...' => 'altflipflop', ',' => 'comma', '=>' => 'fatcomma', ); my %binop_handlers; sub _create_binop_handler { my ($op) = @_; my $name = $binops{$op}; croak("Operator $op not supported") unless defined $name; { local $@; eval <<"IS_BINOP"; sub is_$name (\$\$;\$) { my (\$got, \$expected, \$desc) = \@_; \@_ = (scalar(\$got $op \$expected), \$desc); goto &ok; } IS_BINOP die $@ if $@; } $binop_handlers{$op} = do { no strict 'refs'; \&{__PACKAGE__."::is_$name"}; } } =head2 C like $got, $regexp_expected; like $got, $regexp_expected, $desc; See L. =head2 C unlike $got, $regexp_expected; unlike $got, $regexp_expected, $desc; See L. =cut { no warnings 'once'; *like = _create_binop_handler('=~'); *unlike = _create_binop_handler('!~'); } =head2 C cmp_ok $got, $op, $expected; cmp_ok $got, $op, $expected, $desc; See L. =cut sub cmp_ok ($$$;$) { my ($got, $op, $expected, $desc) = @_; my $handler = $binop_handlers{$op}; unless ($handler) { local $Test::More::Level = ($Test::More::Level || 0) + 1; $handler = _create_binop_handler($op); } @_ = ($got, $expected, $desc); goto $handler; } =head2 C is_deeply $got, $expected; is_deeply $got, $expected, $desc; See L. =cut BEGIN { local $@; if (eval { require Scalar::Util; 1 }) { *_reftype = \&Scalar::Util::reftype; } else { # Stolen from Scalar::Util::PP require B; my %tmap = qw< B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP >; *_reftype = sub ($) { my $r = shift; return undef unless length ref $r; my $t = ref B::svref_2object($r); return exists $tmap{$t} ? $tmap{$t} : length ref $$r ? 'REF' : 'SCALAR' } } } sub _deep_ref_check { my ($x, $y, $ry) = @_; no warnings qw; if ($ry eq 'ARRAY') { return 0 unless $#$x == $#$y; my ($ex, $ey); for (0 .. $#$y) { $ex = $x->[$_]; $ey = $y->[$_]; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'HASH') { return 0 unless keys(%$x) == keys(%$y); my ($ex, $ey); for (keys %$y) { return 0 unless exists $x->{$_}; $ex = $x->{$_}; $ey = $y->{$_}; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { return _deep_check($$x, $$y); } return 0; } sub _deep_check { my ($x, $y) = @_; no warnings qw; return 0 if defined $x xor defined $y; # Try object identity/eq overloading first. It also covers the case where # $x and $y are both undefined. # If either $x or $y is overloaded but none has eq overloading, the test will # break at that point. return 1 if not(ref $x xor ref $y) and $x eq $y; # Test::More::is_deeply happily breaks encapsulation if the objects aren't # overloaded. my $ry = _reftype($y); return 0 if _reftype($x) ne $ry; # Shortcut if $x and $y are both not references and failed the previous # $x eq $y test. return 0 unless $ry; # We know that $x and $y are both references of type $ry, without overloading. _deep_ref_check($x, $y, $ry); } sub is_deeply { @_ = ( &_deep_check, $_[2], ); goto &ok; } sub _diag_fh { my $fh = shift; return unless @_; lock $plan if THREADSAFE; return if $no_diag; my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; _sanitize_comment($msg); return unless length $msg; local $\; print $fh "# $msg\n"; return 0; }; =head2 C diag @lines; See L. =cut sub diag { unshift @_, $DIAG_STREAM; goto &_diag_fh; } =head2 C note @lines; See L. =cut sub note { unshift @_, $TAP_STREAM; goto &_diag_fh; } =head2 C BAIL_OUT; BAIL_OUT $desc; See L. =cut sub BAIL_OUT { my ($desc) = @_; lock $plan if THREADSAFE; my $bail_out_str = 'Bail out!'; if (defined $desc) { _sanitize_comment($desc); $bail_out_str .= " $desc" if length $desc; # Two spaces } local $\; print $TAP_STREAM "$bail_out_str\n"; exit 255; } END { if ($main_process == $$ and not $?) { lock $plan if THREADSAFE; if (defined $plan) { if ($failed) { $? = $failed <= 254 ? $failed : 254; } elsif ($plan >= 0) { $? = $test == $plan ? 0 : 255; } if ($plan == NO_PLAN) { local $\; print $TAP_STREAM "1..$test\n"; } } } } =pod L also provides some functions of its own, which are never exported. =head2 C my $tap_fh = tap_stream; tap_stream $fh; Read/write accessor for the filehandle to which the tests are outputted. On write, it also turns autoflush on onto C<$fh>. Note that it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub tap_stream (;*) { if (@_) { $TAP_STREAM = $_[0]; my $fh = select $TAP_STREAM; $|++; select $fh; } return $TAP_STREAM; } tap_stream *STDOUT; =head2 C my $diag_fh = diag_stream; diag_stream $fh; Read/write accessor for the filehandle to which the diagnostics are printed. On write, it also turns autoflush on onto C<$fh>. Just like L, it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub diag_stream (;*) { if (@_) { $DIAG_STREAM = $_[0]; my $fh = select $DIAG_STREAM; $|++; select $fh; } return $DIAG_STREAM; } diag_stream *STDERR; =head2 C This constant evaluates to true if and only if L is thread-safe, i.e. when this version of C is at least 5.8, has been compiled with C defined, and L has been loaded B L. In that case, it also needs a working L. =head1 DEPENDENCIES L 5.6. L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Leaner =head1 COPYRIGHT & LICENSE Copyright 2010,2011,2013 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Except for the fallback implementation of the internal C<_reftype> function, which has been taken from L and is Copyright 1997-2007 Graham Barr, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Leaner autovivification-0.12/t/lib/autovivification/0000750000175000017500000000000012212134712020373 5ustar vincevinceautovivification-0.12/t/lib/autovivification/TestRequired6.pm0000644000175000017500000000023711511133531023445 0ustar vincevincepackage autovivification::TestRequired6; sub new { bless {} } sub bar { exists $main::blurp->{bar}; } sub baz { eval q[exists $main::blurp->{baz}]; } 1; autovivification-0.12/t/lib/autovivification/TestCases.pm0000644000175000017500000000566511604710617022660 0ustar vincevincepackage autovivification::TestCases; use strict; use warnings; use Test::Leaner; sub import { no strict 'refs'; *{caller().'::testcase_ok'} = \&testcase_ok; } sub in_strict { (caller 0)[8] & (eval { strict::bits(@_) } || 0) }; sub do_nothing { } sub set_arg { $_[0] = 1 } sub generate { my ($var, $init, $code, $exp, $use, $opts, $global) = @_; my $decl = $global ? "our $var; local $var;" : "my $var;"; my $test = $var =~ /^[@%]/ ? "\\$var" : $var; my $desc = join('; ', map { my $x = $_; $x=~ s,;\s*$,,; $x } grep /\S/, $decl, $init, $code) . " <$opts>"; return </\$$var/g; push @base, \@oldderef; my @nonref = @{$base[0]}; $nonref[0] = $sigil . $name; for ($nonref[1], $nonref[2]) { s/\@\Q$var\E([\[\{])/\@$name$1/g; s/\Q$sigil$var\E/$nonref[0]/g; s/\Q$var\E\->/$var/g; } my $simple = $nonref[2] !~ /->/; my $plain_deref = $nonref[2] =~ /\Q$nonref[0]\E/; my $empty = { '@' => '[ ]', '%' => '{ }' }->{$sigil}; if (($simple and ( $nonref[3] =~ m!qr/\^Reference vivification forbidden.*?/! or $nonref[3] =~ m!qr/\^Can't vivify reference.*?/!)) or ($plain_deref and $nonref[3] =~ m!qr/\^Can't use an undefined value as a.*?/!)) { $nonref[1] = ''; $nonref[2] = 1; $nonref[3] = "'', 1, $empty"; } $nonref[3] =~ s/,\s*undef\s*$/, $empty/; push @base, \@nonref; } my @testcases = map { my ($var, $init, $code, $exp, $use) = @$_; [ $var, $init, $code, $exp, $use, $opts, 0 ], [ $var, "use strict; $init", $code, $exp, $use, $opts, 1 ], [ $var, "no strict; $init", $code, $exp, $use, $opts, 1 ], } @base; for (@testcases) { my ($testcase, $desc) = generate(@$_); my @N = (0 .. 9); eval $testcase; diag "== This testcase failed to compile ==\n$testcase\n## Reason: $@" if $@; } } 1; autovivification-0.12/t/lib/autovivification/TestRequired1.pm0000644000175000017500000000021411511133531023433 0ustar vincevincepackage autovivification::TestRequired1; my $x = $main::blurp->{r1_main}->{vivify}; eval 'my $y = $main::blurp->{r1_eval}->{vivify}'; 1; autovivification-0.12/t/lib/autovivification/TestThreads.pm0000644000175000017500000000223412207502475023202 0ustar vincevincepackage autovivification::TestThreads; use strict; use warnings; use Config qw<%Config>; use VPIT::TestHelpers; sub import { shift; require autovivification; skip_all 'This autovivification isn\'t thread safe' unless autovivification::A_THREADSAFE(); my $force = $ENV{PERL_AUTOVIVIFICATION_TEST_THREADS} ? 1 : !1; skip_all 'This perl wasn\'t built to support threads' unless $Config{useithreads}; skip_all 'perl 5.13.4 required to test thread safety' unless $force or "$]" >= 5.013_004; load_or_skip_all('threads', $force ? '0' : '1.67', [ ]); my %exports = ( spawn => \&spawn, ); my $pkg = caller; while (my ($name, $code) = each %exports) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } } sub spawn { local $@; my @diag; my $thread = eval { local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; threads->create(@_); }; push @diag, "Thread creation error: $@" if $@; if (@diag) { require Test::Leaner; Test::Leaner::diag($_) for @diag; } return $thread ? $thread : (); } 1; autovivification-0.12/t/lib/autovivification/TestRequired2.pm0000644000175000017500000000042711511133531023442 0ustar vincevincepackage autovivification::TestRequired2; no autovivification; BEGIN { delete $INC{'autovivification/TestRequired1.pm'}; } use lib 't/lib'; use autovivification::TestRequired1; my $x = $main::blurp->{r2_main}->{vivify}; eval 'my $y = $main::blurp->{r2_eval}->{vivify}'; 1; autovivification-0.12/t/lib/autovivification/TestRequired5/0000750000175000017500000000000012212134712023100 5ustar vincevinceautovivification-0.12/t/lib/autovivification/TestRequired5/d0.pm0000644000175000017500000000011211511133531023737 0ustar vincevincepackage autovivification::TestRequired5::d0; my $x; my $y = $x->{foo}; 1; autovivification-0.12/t/lib/autovivification/TestRequired5/a0.pm0000644000175000017500000000031711511133531023743 0ustar vincevincepackage autovivification::TestRequired5::a0; no autovivification qw; use autovivification::TestRequired5::b0; sub error { local $@; autovivification::TestRequired5::b0->get; return $@; } 1; autovivification-0.12/t/lib/autovivification/TestRequired5/b0.pm0000644000175000017500000000016111511133531023741 0ustar vincevincepackage autovivification::TestRequired5::b0; sub get { eval 'require autovivification::TestRequired5::c0'; } 1; autovivification-0.12/t/lib/autovivification/TestRequired5/c0.pm0000644000175000017500000000013511511133531023743 0ustar vincevincepackage autovivification::TestRequired5::c0; require autovivification::TestRequired5::d0; 1; autovivification-0.12/t/lib/autovivification/TestRequired4/0000750000175000017500000000000012212134712023077 5ustar vincevinceautovivification-0.12/t/lib/autovivification/TestRequired4/a0.pm0000644000175000017500000000031711511133531023742 0ustar vincevincepackage autovivification::TestRequired4::a0; no autovivification qw; use autovivification::TestRequired4::b0; sub error { local $@; autovivification::TestRequired4::b0->get; return $@; } 1; autovivification-0.12/t/lib/autovivification/TestRequired4/b0.pm0000644000175000017500000000016111511133531023740 0ustar vincevincepackage autovivification::TestRequired4::b0; sub get { eval 'require autovivification::TestRequired4::c0'; } 1; autovivification-0.12/t/lib/autovivification/TestRequired4/c0.pm0000644000175000017500000000011211511133531023735 0ustar vincevincepackage autovivification::TestRequired4::c0; my $x; my $y = $x->{foo}; 1; autovivification-0.12/t/41-padsv.t0000644000175000017500000000066611511133531016002 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 4; my $buf = "abc\ndef\n"; open my $x, '<', \$buf; # Do this one first so that the check functions are set up for the second my $res = eval 'no autovivification; <$x>'; is $@, '', 'padsv 1: no error'; is $res, "abc\n", 'padsv 1: correct returned value'; $res = eval '<$x>'; is $@, '', 'padsv 2: no error'; is $res, "def\n", 'padsv 2: correct returned value'; autovivification-0.12/t/40-scope.t0000644000175000017500000000354712207502475016010 0ustar vincevince#!perl use strict; use warnings; use Test::More tests => 12; use lib 't/lib'; { my @w; my $x; my $res = eval { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; no autovivification qw; $x->{a}; }; is @w, 1, 'warned only once'; like $w[0], qr/^warn:Reference was vivified at \Q$0\E line ${\(__LINE__-3)}/, 'warning looks correct'; is_deeply $x, undef, 'didn\'t vivified'; is $res, undef, 'returned undef'; } our $blurp; { local $blurp; eval 'no autovivification; use autovivification::TestRequired1; $blurp->{x}'; is $@, '', 'first require test doesn\'t croak prematurely'; is_deeply $blurp, { r1_main => { }, r1_eval => { } }, 'first require vivified correctly'; } { local $blurp; eval 'no autovivification; use autovivification::TestRequired2; $blurp->{a}'; is $@, '', 'second require test doesn\'t croak prematurely'; my $expect; $expect = { r1_main => { }, r1_eval => { } }; $expect->{r2_eval} = { } if "$]" < 5.009_005; is_deeply $blurp, $expect, 'second require test didn\'t vivify'; } # This test may not fail for the old version when ran in taint mode { my $err = eval <<' SNIP'; use autovivification::TestRequired4::a0; autovivification::TestRequired4::a0::error(); SNIP is $err, '', 'RT #50570'; } # This test must be in the topmost scope BEGIN { eval 'use autovivification::TestRequired5::a0' } my $err = autovivification::TestRequired5::a0::error(); is $err, '', 'identifying requires by their eval context pointer is not enough'; { local $blurp; no autovivification; use autovivification::TestRequired6; autovivification::TestRequired6::bar(); is_deeply $blurp, { }, 'vivified without eval'; $blurp = undef; autovivification::TestRequired6::baz(); is_deeply $blurp, { }, 'vivified with eval'; } autovivification-0.12/t/33-array-tied.t0000644000175000017500000000073711511133531016726 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; BEGIN { eval 'use Tie::Array; scalar keys %Tie::StdArray::' or plan skip_all => 'Tie::StdArray required to test tied arrays'; defined and diag "Using Tie::StdArray $_" for $Tie::Array::VERSION; plan tests => 1; } { tie my @a, 'Tie::StdArray'; tie my @b, 'Tie::StdArray'; $a[1] = 'hlagh'; $b[0] = \@a; my $res = do { no autovivification; $b[0][1]; }; is $res, 'hlagh', 'nested tied arrays'; } autovivification-0.12/t/42-deparse.t0000644000175000017500000000104012153114560016300 0ustar vincevince#!perl -T use strict; use warnings; use Test::More; use lib 't/lib'; use VPIT::TestHelpers; load_or_skip_all('B::Deparse', undef, [ ]); plan tests => 2; my $bd = B::Deparse->new; { no autovivification qw; sub blech { my $key = $_[0]->{key} } } { my $undef; eval 'blech($undef)'; like $@, qr/Reference vivification forbidden/, 'Original blech() works'; } { my $code = $bd->coderef2text(\&blech); my $undef; eval "$code; blech(\$undef)"; like $@, qr/Reference vivification forbidden/, 'Deparsed blech() works'; } autovivification-0.12/t/00-load.t0000644000175000017500000000027012207502475015600 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'autovivification' ); } diag( "Testing autovivification $autovivification::VERSION, Perl $], $^X" ); autovivification-0.12/t/43-peep.t0000644000175000017500000000752711511133531015623 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 11 + 6 * 3; { my $desc = 'peephole optimization of conditionals'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { if ($_[0]) { my $z = $x->{a}; return 1; } elsif ($_[1] || $_[2]) { my $z = $x->{b}; return 2; } elsif ($_[3] && $_[4]) { my $z = $x->{c}; return 3; } elsif ($_[5] ? $_[6] : 0) { my $z = $x->{d}; return 4; } else { my $z = $x->{e}; return 5; } return 0; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(1); is_deeply $x, undef, "$desc : first branch did not autovivify"; is $ret, 1, "$desc : first branch returned 1"; $ret = $code->(0, 1); is_deeply $x, undef, "$desc : second branch did not autovivify"; is $ret, 2, "$desc : second branch returned 2"; $ret = $code->(0, 0, 0, 1, 1); is_deeply $x, undef, "$desc : third branch did not autovivify"; is $ret, 3, "$desc : third branch returned 3"; $ret = $code->(0, 0, 0, 0, 0, 1, 1); is_deeply $x, undef, "$desc : fourth branch did not autovivify"; is $ret, 4, "$desc : fourth branch returned 4"; $ret = $code->(); is_deeply $x, undef, "$desc : fifth branch did not autovivify"; is $ret, 5, "$desc : fifth branch returned 5"; } { my $desc = 'peephole optimization of C-style loops'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { my $ret = 0; for ( my ($z, $i) = ($x->[100], 0) ; do { my $z = $x->[200]; $i < 4 } ; do { my $z = $x->[300]; ++$i } ) { my $z = $x->[$i]; $ret += $i; } return $ret; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(); is_deeply $x, undef, "$desc did not autovivify"; is $ret, 6, "$desc returned 0+1+2+3"; } { my $desc = 'peephole optimization of range loops'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { my $ret = 0; for ((do { my $z = $x->[100]; 0 }) .. (do { my $z = $x->[200]; 3 })) { my $z = $x->[$_]; $ret += $_; } return $ret; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(); is_deeply $x, undef, "$desc did not autovivify"; is $ret, 6, "$desc returned 0+1+2+3"; } { my $desc = 'peephole optimization of empty loops (RT #64435)'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { my $ret = 0; for (;;) { ++$ret; return $ret; } return $ret; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(); is_deeply $x, undef, "$desc did not autovivify"; is $ret, 1, "$desc returned 1"; } { my $desc = 'peephole optimization of map'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { join ':', map { my $z = $x->[$_]; "x${_}y" } @_ } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(1, 2); is_deeply $x, undef, "$desc did not autovivify"; is $ret, 'x1y:x2y', "$desc returned the right value"; } { my $desc = 'peephole optimization of grep'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { join ':', grep { my $z = $x->[$_]; $_ <= 3 } @_ } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(1 .. 5); is_deeply $x, undef, "$desc did not autovivify"; is $ret, '1:2:3', "$desc returned the right value"; } { my $desc = 'peephole optimization of substitutions'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { my $str = $_[0]; $str =~ s{ ([0-9]) }{ my $z = $x->[$1]; 9 - $1; }xge; $str; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->('0123456789'); is_deeply $x, undef, "$desc did not autovivify"; is $ret, '9876543210', "$desc returned the right value"; } autovivification-0.12/t/32-array-kv.t0000644000175000017500000000670011625205606016425 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner; BEGIN { if ("$]" >= 5.011) { plan tests => 9 * 3 * 64 } else { plan skip_all => 'perl 5.11 required for keys/values @array' } } use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '@'); } __DATA__ --- keys --- $x # keys @$x # '', 0, [ ] $x # keys @$x # '', 0, undef # $x # keys @$x # '', 0, undef # +fetch $x # keys @$x # '', 0, [ ] # +exists $x # keys @$x # '', 0, [ ] # +delete $x # keys @$x # '', 0, [ ] # +store $x # keys @$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys @$x # '', 0, [ ] # +strict +exists $x # keys @$x # '', 0, [ ] # +strict +delete $x # keys @$x # '', 0, [ ] # +strict +store $x # [ keys @$x ] # '', [ ], [ ] $x # [ keys @$x ] # '', [ ], undef # $x # [ keys @$x ] # '', [ ], undef # +fetch $x # [ keys @$x ] # '', [ ], [ ] # +exists +delete +store $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # +fetch $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # +exists +delete +store $x # keys @{$x->[0]} # '', 0, [ [ ] ] $x # keys @{$x->[0]} # '', 0, undef # $x # keys @{$x->[0]} # '', 0, undef # +fetch $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +exists $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +delete $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +store $x # keys @{$x->[0]} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +exists $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +delete $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +store $x # [ keys @{$x->[0]} ] # '', [ ], [ [ ] ] $x # [ keys @{$x->[0]} ] # '', [ ], undef # $x # [ keys @{$x->[0]} ] # '', [ ], undef # +fetch $x # [ keys @{$x->[0]} ] # '', [ ], [ [ ] ] # +exists +delete +store --- values --- $x # values @$x # '', 0, [ ] $x # values @$x # '', 0, undef # $x # values @$x # '', 0, undef # +fetch $x # values @$x # '', 0, [ ] # +exists $x # values @$x # '', 0, [ ] # +delete $x # values @$x # '', 0, [ ] # +store $x # values @$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values @$x # '', 0, [ ] # +strict +exists $x # values @$x # '', 0, [ ] # +strict +delete $x # values @$x # '', 0, [ ] # +strict +store $x # [ values @$x ] # '', [ ], [ ] $x # [ values @$x ] # '', [ ], undef # $x # [ values @$x ] # '', [ ], undef # +fetch $x # [ values @$x ] # '', [ ], [ ] # +exists +delete +store $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # +fetch $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # +exists +delete +store $x # values @{$x->[0]} # '', 0, [ [ ] ] $x # values @{$x->[0]} # '', 0, undef # $x # values @{$x->[0]} # '', 0, undef # +fetch $x # values @{$x->[0]} # '', 0, [ [ ] ] # +exists $x # values @{$x->[0]} # '', 0, [ [ ] ] # +delete $x # values @{$x->[0]} # '', 0, [ [ ] ] # +store $x # values @{$x->[0]} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +exists $x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +delete $x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +store $x # [ values @{$x->[0]} ] # '', [ ], [ [ ] ] $x # [ values @{$x->[0]} ] # '', [ ], undef # $x # [ values @{$x->[0]} ] # '', [ ], undef # +fetch $x # [ values @{$x->[0]} ] # '', [ ], [ [ ] ] # +exists +delete +store autovivification-0.12/t/31-array-fast.t0000644000175000017500000005005411625205606016742 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner tests => 9 * 3 * 302; use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '@'); } __DATA__ --- fetch --- $x # $x->[0] # '', undef, [ ] $x # $x->[0] # '', undef, undef # $x # $x->[0] # '', undef, undef # +fetch $x # $x->[0] # '', undef, [ ] # +exists $x # $x->[0] # '', undef, [ ] # +delete $x # $x->[0] # '', undef, [ ] # +store $x # $x->[0] # '', undef, [ ] # -fetch $x # $x->[0] # '', undef, [ ] # +fetch -fetch $x # $x->[0] # '', undef, undef # -fetch +fetch $x # $x->[0] # '', undef, undef # +fetch -exists $x # $x->[0] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[0] # '', undef, [ ] # +strict +exists $x # $x->[0] # '', undef, [ ] # +strict +delete $x # $x->[0] # '', undef, [ ] # +strict +store $x # $x->[0]->[1] # '', undef, [ [ ] ] $x # $x->[0]->[1] # '', undef, undef # $x # $x->[0]->[1] # '', undef, undef # +fetch $x # $x->[0]->[1] # '', undef, [ [ ] ] # +exists $x # $x->[0]->[1] # '', undef, [ [ ] ] # +delete $x # $x->[0]->[1] # '', undef, [ [ ] ] # +store $x # $x->[0]->[1] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[0]->[1] # '', undef, [ [ ] ] # +strict +exists $x # $x->[0]->[1] # '', undef, [ [ ] ] # +strict +delete $x # $x->[0]->[1] # '', undef, [ [ ] ] # +strict +store $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +fetch $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +fetch $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +exists $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +exists $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +delete $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +delete $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +store $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +store $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +fetch $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +fetch $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +exists $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +exists $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +delete $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +delete $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +store $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[2]->[3] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +store --- aliasing --- $x # 1 for $x->[0]; () # '', undef, [ undef ] $x # 1 for $x->[0]; () # '', undef, [ undef ] # $x # 1 for $x->[0]; () # '', undef, [ undef ] # +fetch $x # 1 for $x->[0]; () # '', undef, [ undef ] # +exists $x # 1 for $x->[0]; () # '', undef, [ undef ] # +delete $x # 1 for $x->[0]; () # qr/^Can't vivify reference/, undef, undef # +store $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +fetch $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +exists $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +delete $x # $_ = 1 for $x->[0]; () # qr/^Can't vivify reference/, undef, undef # +store $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +fetch $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +fetch $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +exists $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +exists $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +delete $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +delete $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +store $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +store $x # do_nothing($x->[0]); () # '', undef, [ ] $x # do_nothing($x->[0]); () # '', undef, [ ] # $x # do_nothing($x->[0]); () # '', undef, [ ] # +fetch $x # do_nothing($x->[0]); () # '', undef, [ ] # +exists $x # do_nothing($x->[0]); () # '', undef, [ ] # +delete $x # do_nothing($x->[0]); () # qr/^Can't vivify reference/, undef, undef # +store $x # set_arg($x->[0]); () # '', undef, [ 1 ] $x # set_arg($x->[0]); () # '', undef, [ 1 ] # $x # set_arg($x->[0]); () # '', undef, [ 1 ] # +fetch $x # set_arg($x->[0]); () # '', undef, [ 1 ] # +exists $x # set_arg($x->[0]); () # '', undef, [ 1 ] # +delete $x # set_arg($x->[0]); () # qr/^Can't vivify reference/, undef, undef # +store --- dereferencing --- $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +fetch $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +exists $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +delete $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +store $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +fetch $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +exists $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +delete $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +store --- slice --- $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], undef # $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], undef # +fetch $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +exists $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +delete $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +store $x->[1] = 0 # my @a = @$x[0, 1]; \@a # '', [ undef, 0 ], [ undef, 0 ] # +fetch $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +fetch $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +exists $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +delete $x # @$x[0, 1] = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store $x->[0] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +store $x->[2] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2, 0 ] # +store $x->[0] = 0, $x->[1] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +store --- exists --- $x # exists $x->[0] # '', '', [ ] $x # exists $x->[0] # '', '', undef # $x # exists $x->[0] # '', '', [ ] # +fetch $x # exists $x->[0] # '', '', undef # +exists $x # exists $x->[0] # '', '', [ ] # +delete $x # exists $x->[0] # '', '', [ ] # +store $x # exists $x->[0] # '', '', [ ] # +strict +fetch $x # exists $x->[0] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[0] # '', '', [ ] # +strict +delete $x # exists $x->[0] # '', '', [ ] # +strict +store $x # exists $x->[0]->[1] # '', '', [ [ ] ] $x # exists $x->[0]->[1] # '', '', undef # $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +fetch $x # exists $x->[0]->[1] # '', '', undef # +exists $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +delete $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +store $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +strict +fetch $x # exists $x->[0]->[1] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +strict +delete $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +strict +store $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +fetch $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +fetch $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +exists $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +exists $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +delete $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +delete $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +store $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +store $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +fetch $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +fetch $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +exists $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +exists $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +delete $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +delete $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +store $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +store $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +delete $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +store $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +fetch $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # exists $x->[2]->[3] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +store --- delete --- $x # delete $x->[0] # '', undef, [ ] $x # delete $x->[0] # '', undef, undef # $x # delete $x->[0] # '', undef, [ ] # +fetch $x # delete $x->[0] # '', undef, [ ] # +exists $x # delete $x->[0] # '', undef, undef # +delete $x # delete $x->[0] # '', undef, [ ] # +store $x # delete $x->[0] # '', undef, [ ] # +strict +fetch $x # delete $x->[0] # '', undef, [ ] # +strict +exists $x # delete $x->[0] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[0] # '', undef, [ ] # +strict +store $x # delete $x->[0]->[1] # '', undef, [ [ ] ] $x # delete $x->[0]->[1] # '', undef, undef # $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +fetch $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +exists $x # delete $x->[0]->[1] # '', undef, undef # +delete $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +store $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +strict +fetch $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +strict +exists $x # delete $x->[0]->[1] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +strict +store $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +fetch $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +fetch $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +exists $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +exists $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +delete $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +delete $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +store $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +store $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +fetch $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +fetch $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +exists $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +exists $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +delete $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +delete $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +store $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +store $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +fetch $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +fetch $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +exists $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +exists $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +delete $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +delete $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ] ]# +delete $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +store $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +store $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +fetch $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +fetch $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +exists $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +exists $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +delete $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # delete $x->[2]->[3] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +store $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +store --- store --- $x # $x->[0] = 1 # '', 1, [ 1 ] $x # $x->[0] = 1 # '', 1, [ 1 ] # $x # $x->[0] = 1 # '', 1, [ 1 ] # +fetch $x # $x->[0] = 1 # '', 1, [ 1 ] # +exists $x # $x->[0] = 1 # '', 1, [ 1 ] # +delete $x # $x->[0] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[0] = 1 # '', 1, [ 1 ] # +strict +fetch $x # $x->[0] = 1 # '', 1, [ 1 ] # +strict +exists $x # $x->[0] = 1 # '', 1, [ 1 ] # +strict +delete $x # $x->[0] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +fetch $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +exists $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +delete $x # $x->[0]->[1] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +exists $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +delete $x # $x->[0]->[1] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +fetch $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +fetch $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +exists $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +exists $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +delete $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +delete $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +store $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +store $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +fetch $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +fetch $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +exists $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +exists $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +delete $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +delete $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +store $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +fetch $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +exists $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +delete $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +store $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # qr/^Can't vivify reference/, undef, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +store autovivification-0.12/t/22-hash-kv.t0000644000175000017500000000707611511133531016227 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner; BEGIN { plan tests => 9 * 3 * 64; } use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '%'); } __DATA__ --- keys --- $x # keys %$x # '', 0, { } $x # keys %$x # '', 0, undef # $x # keys %$x # '', 0, undef # +fetch $x # keys %$x # '', 0, { } # +exists $x # keys %$x # '', 0, { } # +delete $x # keys %$x # '', 0, { } # +store $x # keys %$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys %$x # '', 0, { } # +strict +exists $x # keys %$x # '', 0, { } # +strict +delete $x # keys %$x # '', 0, { } # +strict +store $x # [ keys %$x ] # '', [ ], { } $x # [ keys %$x ] # '', [ ], undef # $x # [ keys %$x ] # '', [ ], undef # +fetch $x # [ keys %$x ] # '', [ ], { } # +exists +delete +store $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # +fetch $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # +exists +delete +store $x # keys %{$x->{a}} # '', 0, { a => { } } $x # keys %{$x->{a}} # '', 0, undef # $x # keys %{$x->{a}} # '', 0, undef # +fetch $x # keys %{$x->{a}} # '', 0, { a => { } } # +exists $x # keys %{$x->{a}} # '', 0, { a => { } } # +delete $x # keys %{$x->{a}} # '', 0, { a => { } } # +store $x # keys %{$x->{a}} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys %{$x->{a}} # '', 0, { a => { } } # +strict +exists $x # keys %{$x->{a}} # '', 0, { a => { } } # +strict +delete $x # keys %{$x->{a}} # '', 0, { a => { } } # +strict +store $x # [ keys %{$x->{a}} ] # '', [ ], { a => { } } $x # [ keys %{$x->{a}} ] # '', [ ], undef # $x # [ keys %{$x->{a}} ] # '', [ ], undef # +fetch $x # [ keys %{$x->{a}} ] # '', [ ], { a => { } } # +exists +delete +store --- values --- $x # values %$x # '', 0, { } $x # values %$x # '', 0, undef # $x # values %$x # '', 0, undef # +fetch $x # values %$x # '', 0, { } # +exists $x # values %$x # '', 0, { } # +delete $x # values %$x # '', 0, { } # +store $x # values %$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values %$x # '', 0, { } # +strict +exists $x # values %$x # '', 0, { } # +strict +delete $x # values %$x # '', 0, { } # +strict +store $x # [ values %$x ] # '', [ ], { } $x # [ values %$x ] # '', [ ], undef # $x # [ values %$x ] # '', [ ], undef # +fetch $x # [ values %$x ] # '', [ ], { } # +exists +delete +store $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # +fetch $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # +exists +delete +store $x # values %{$x->{a}} # '', 0, { a => { } } $x # values %{$x->{a}} # '', 0, undef # $x # values %{$x->{a}} # '', 0, undef # +fetch $x # values %{$x->{a}} # '', 0, { a => { } } # +exists $x # values %{$x->{a}} # '', 0, { a => { } } # +delete $x # values %{$x->{a}} # '', 0, { a => { } } # +store $x # values %{$x->{a}} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values %{$x->{a}} # '', 0, { a => { } } # +strict +exists $x # values %{$x->{a}} # '', 0, { a => { } } # +strict +delete $x # values %{$x->{a}} # '', 0, { a => { } } # +strict +store $x # [ values %{$x->{a}} ] # '', [ ], { a => { } } $x # [ values %{$x->{a}} ] # '', [ ], undef # $x # [ values %{$x->{a}} ] # '', [ ], undef # +fetch $x # [ values %{$x->{a}} ] # '', [ ], { a => { } } # +exists +delete +store autovivification-0.12/t/20-hash.t0000644000175000017500000005354412207502475015622 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner tests => 9 * 3 * 302; use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '%'); } __DATA__ --- fetch --- $x # $x->{a} # '', undef, { } $x # $x->{a} # '', undef, undef # $x # $x->{a} # '', undef, undef # +fetch $x # $x->{a} # '', undef, { } # +exists $x # $x->{a} # '', undef, { } # +delete $x # $x->{a} # '', undef, { } # +store $x # $x->{a} # '', undef, { } # -fetch $x # $x->{a} # '', undef, { } # +fetch -fetch $x # $x->{a} # '', undef, undef # -fetch +fetch $x # $x->{a} # '', undef, undef # +fetch -exists $x # $x->{a} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->{a} # '', undef, { } # +strict +exists $x # $x->{a} # '', undef, { } # +strict +delete $x # $x->{a} # '', undef, { } # +strict +store $x # $x->{a}->{b} # '', undef, { a => { } } $x # $x->{a}->{b} # '', undef, undef # $x # $x->{a}->{b} # '', undef, undef # +fetch $x # $x->{a}->{b} # '', undef, { a => { } } # +exists $x # $x->{a}->{b} # '', undef, { a => { } } # +delete $x # $x->{a}->{b} # '', undef, { a => { } } # +store $x # $x->{a}->{b} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->{a}->{b} # '', undef, { a => { } } # +strict +exists $x # $x->{a}->{b} # '', undef, { a => { } } # +strict +delete $x # $x->{a}->{b} # '', undef, { a => { } } # +strict +store $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +fetch $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +fetch $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +exists $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +exists $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +delete $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +delete $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +store $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +store $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +fetch $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +fetch $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +exists $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +exists $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +delete $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +delete $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +store $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +exists $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +delete $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +store $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{c}->{d} # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +strict +store --- aliasing --- $x # 1 for $x->{a}; () # '', undef, { a => undef } $x # 1 for $x->{a}; () # '', undef, { a => undef } # $x # 1 for $x->{a}; () # '', undef, { a => undef } # +fetch $x # 1 for $x->{a}; () # '', undef, { a => undef } # +exists $x # 1 for $x->{a}; () # '', undef, { a => undef } # +delete $x # 1 for $x->{a}; () # qr/^Can't vivify reference/, undef, undef # +store $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +fetch $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +exists $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +delete $x # $_ = 1 for $x->{a}; () # qr/^Can't vivify reference/, undef, undef # +store $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +fetch $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +fetch $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +exists $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +exists $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +delete $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +delete $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +store $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +store $x # do_nothing($x->{a}); () # '', undef, { } $x # do_nothing($x->{a}); () # '', undef, { } # $x # do_nothing($x->{a}); () # '', undef, { } # +fetch $x # do_nothing($x->{a}); () # '', undef, { } # +exists $x # do_nothing($x->{a}); () # '', undef, { } # +delete $x # do_nothing($x->{a}); () # qr/^Can't vivify reference/, undef, undef # +store $x # set_arg($x->{a}); () # '', undef, { a => 1 } $x # set_arg($x->{a}); () # '', undef, { a => 1 } # $x # set_arg($x->{a}); () # '', undef, { a => 1 } # +fetch $x # set_arg($x->{a}); () # '', undef, { a => 1 } # +exists $x # set_arg($x->{a}); () # '', undef, { a => 1 } # +delete $x # set_arg($x->{a}); () # qr/^Can't vivify reference/, undef, undef # +store --- dereferencing --- $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +fetch $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +exists $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +delete $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +store $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +fetch $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +exists $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +delete $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +store --- slice --- $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], undef # $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], undef # +fetch $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } # +exists $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } # +delete $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } # +store $x->{b} = 0 # my @a = @$x{'a', 'b'}; \@a # '', [ undef, 0 ], { b => 0 } # +fetch $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +fetch $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +exists $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +delete $x # @$x{'a', 'b'} = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store $x->{a} = 0 # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +store $x->{c} = 0 # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2, c => 0 } # +store $x->{a} = 0, $x->{b} = 0 # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +store --- exists --- $x # exists $x->{a} # '', '', { } $x # exists $x->{a} # '', '', undef # $x # exists $x->{a} # '', '', { } # +fetch $x # exists $x->{a} # '', '', undef # +exists $x # exists $x->{a} # '', '', { } # +delete $x # exists $x->{a} # '', '', { } # +store $x # exists $x->{a} # '', '', { } # +strict +fetch $x # exists $x->{a} # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->{a} # '', '', { } # +strict +delete $x # exists $x->{a} # '', '', { } # +strict +store $x # exists $x->{a}->{b} # '', '', { a => { } } $x # exists $x->{a}->{b} # '', '', undef # $x # exists $x->{a}->{b} # '', '', { a => { } } # +fetch $x # exists $x->{a}->{b} # '', '', undef # +exists $x # exists $x->{a}->{b} # '', '', { a => { } } # +delete $x # exists $x->{a}->{b} # '', '', { a => { } } # +store $x # exists $x->{a}->{b} # '', '', { a => { } } # +strict +fetch $x # exists $x->{a}->{b} # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->{a}->{b} # '', '', { a => { } } # +strict +delete $x # exists $x->{a}->{b} # '', '', { a => { } } # +strict +store $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +fetch $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +fetch $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +exists $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +exists $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +delete $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +delete $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +store $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +store $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +fetch $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +fetch $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +exists $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +exists $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +delete $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +delete $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +store $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +store $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +fetch $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +delete $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +store $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +store $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +strict +fetch $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # exists $x->{c}->{d} # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +strict +delete $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +strict +store --- delete --- $x # delete $x->{a} # '', undef, { } $x # delete $x->{a} # '', undef, undef # $x # delete $x->{a} # '', undef, { } # +fetch $x # delete $x->{a} # '', undef, { } # +exists $x # delete $x->{a} # '', undef, undef # +delete $x # delete $x->{a} # '', undef, { } # +store $x # delete $x->{a} # '', undef, { } # +strict +fetch $x # delete $x->{a} # '', undef, { } # +strict +exists $x # delete $x->{a} # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->{a} # '', undef, { } # +strict +store $x # delete $x->{a}->{b} # '', undef, { a => { } } $x # delete $x->{a}->{b} # '', undef, undef # $x # delete $x->{a}->{b} # '', undef, { a => { } } # +fetch $x # delete $x->{a}->{b} # '', undef, { a => { } } # +exists $x # delete $x->{a}->{b} # '', undef, undef # +delete $x # delete $x->{a}->{b} # '', undef, { a => { } } # +store $x # delete $x->{a}->{b} # '', undef, { a => { } } # +strict +fetch $x # delete $x->{a}->{b} # '', undef, { a => { } } # +strict +exists $x # delete $x->{a}->{b} # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->{a}->{b} # '', undef, { a => { } } # +strict +store $x->{a} = 1 # delete $x->{a} # '', 1, { } # +fetch $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +fetch $x->{a} = 1 # delete $x->{a} # '', 1, { } # +exists $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +exists $x->{a} = 1 # delete $x->{a} # '', 1, { } # +delete $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +delete $x->{a} = 1 # delete $x->{a} # '', 1, { } # +store $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +store $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +fetch $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +fetch $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +exists $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +exists $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +delete $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +delete $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +store $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +store $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +fetch $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +fetch $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +fetch $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +exists $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +exists $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +exists $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +delete $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +delete $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 } }# +delete $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +store $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +store $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +store $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +fetch $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => {} }# +strict +fetch $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +exists $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => {} }# +strict +exists $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +delete $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # delete $x->{c}->{d} # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +store $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => {} }# +strict +store --- store --- $x # $x->{a} = 1 # '', 1, { a => 1 } $x # $x->{a} = 1 # '', 1, { a => 1 } # $x # $x->{a} = 1 # '', 1, { a => 1 } # +fetch $x # $x->{a} = 1 # '', 1, { a => 1 } # +exists $x # $x->{a} = 1 # '', 1, { a => 1 } # +delete $x # $x->{a} = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->{a} = 1 # '', 1, { a => 1 } # +strict +fetch $x # $x->{a} = 1 # '', 1, { a => 1 } # +strict +exists $x # $x->{a} = 1 # '', 1, { a => 1 } # +strict +delete $x # $x->{a} = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +fetch $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +exists $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +delete $x # $x->{a}->{b} = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +strict +fetch $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +strict +exists $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +strict +delete $x # $x->{a}->{b} = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +fetch $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +fetch $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +exists $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +exists $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +delete $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +delete $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +store $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +store $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +fetch $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +fetch $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +exists $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +exists $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +delete $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +delete $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +store $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +fetch $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +exists $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +exists $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +exists $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +delete $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +delete $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +delete $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +store $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +store $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # qr/^Can't vivify reference/, undef, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +exists $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +delete $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +store $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +store autovivification-0.12/t/51-threads-teardown.t0000644000175000017500000000173012207502475020144 0ustar vincevince#!perl use strict; use warnings; use lib 't/lib'; use autovivification::TestThreads; use Test::Leaner tests => 1; sub run_perl { my $code = shift; my ($SystemRoot, $PATH) = @ENV{qw}; local %ENV; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code; } SKIP: { skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002; my $status = run_perl <<' RUN'; my $code = 1 + 2 + 4; use threads; $code -= threads->create(sub { eval q{no autovivification; my $x; my $y = $x->{foo}; $x}; return defined($x) ? 0 : 1; })->join; $code -= defined(eval q{my $x; my $y = $x->{foo}; $x}) ? 2 : 0; $code -= defined(eval q{no autovivification; my $x; my $y = $x->{foo}; $x}) ? 0 : 4; exit $code; RUN is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault'; } autovivification-0.12/t/50-threads.t0000644000175000017500000000305311657265430016327 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use autovivification::TestThreads; use Test::Leaner; my $threads = 10; my $runs = 2; { no autovivification; sub try { my $tid = threads->tid(); for my $run (1 .. $runs) { { my $x; my $y = $x->{foo}; is $x, undef, "fetch does not autovivify at thread $tid run $run"; } { my $x; my $y = exists $x->{foo}; is $x, undef, "exists does not autovivify at thread $tid run $run"; } { my $x; my $y = delete $x->{foo}; is $x, undef, "delete does not autovivify at thread $tid run $run"; } SKIP: { skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3 * 2 unless "$]" >= 5.010; { my $x; eval 'my $y = $x->{foo}'; is $@, '', "fetch in eval does not croak at thread $tid run $run"; is $x, undef, "fetch in eval does not autovivify at thread $tid run $run"; } { my $x; eval 'my $y = exists $x->{foo}'; is $@, '', "exists in eval does not croak at thread $tid run $run"; is $x, undef, "exists in eval does not autovivify at thread $tid run $run"; } { my $x; eval 'my $y = delete $x->{foo}'; is $@, '', "delete in eval does not croak at thread $tid run $run"; is $x, undef, "delete in eval does not autovivify at thread $tid run $run"; } } } } } my @threads = map spawn(\&try), 1 .. $threads; $_->join for @threads; pass 'done'; done_testing(scalar(@threads) * $runs * 3 * (1 + 2) + 1); autovivification-0.12/t/30-array.t0000644000175000017500000005554011625205606016013 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner tests => 9 * 3 * 302; use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '@'); } __DATA__ --- fetch --- $x # $x->[$N[0]] # '', undef, [ ] $x # $x->[$N[0]] # '', undef, undef # $x # $x->[$N[0]] # '', undef, undef # +fetch $x # $x->[$N[0]] # '', undef, [ ] # +exists $x # $x->[$N[0]] # '', undef, [ ] # +delete $x # $x->[$N[0]] # '', undef, [ ] # +store $x # $x->[$N[0]] # '', undef, [ ] # -fetch $x # $x->[$N[0]] # '', undef, [ ] # +fetch -fetch $x # $x->[$N[0]] # '', undef, undef # -fetch +fetch $x # $x->[$N[0]] # '', undef, undef # +fetch -exists $x # $x->[$N[0]] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[$N[0]] # '', undef, [ ] # +strict +exists $x # $x->[$N[0]] # '', undef, [ ] # +strict +delete $x # $x->[$N[0]] # '', undef, [ ] # +strict +store $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] $x # $x->[$N[0]]->[$N[1]] # '', undef, undef # $x # $x->[$N[0]]->[$N[1]] # '', undef, undef # +fetch $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +exists $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +delete $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +store $x # $x->[$N[0]]->[$N[1]] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +exists $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +delete $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +store $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +exists $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +delete $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +store $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +store $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +store $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +store --- aliasing --- $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # +fetch $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # +exists $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # +delete $x # 1 for $x->[$N[0]]; () # qr/^Can't vivify reference/, undef, undef # +store $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +fetch $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +exists $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +delete $x # $_ = 1 for $x->[$N[0]]; () # qr/^Can't vivify reference/, undef, undef # +store $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +fetch $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +exists $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +delete $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +store $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +store $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +fetch $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +exists $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +delete $x # do_nothing($x->[$N[0]]); () # qr/^Can't vivify reference/, undef, undef # +store $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +fetch $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +exists $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +delete $x # set_arg($x->[$N[0]]); () # qr/^Can't vivify reference/, undef, undef # +store --- dereferencing --- $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +fetch $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +exists $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +delete $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +store $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +store --- slice --- $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], undef # $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], undef # +fetch $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +exists $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +delete $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +store $x->[$N[1]] = 0 # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, 0 ], [ undef, 0 ] # +fetch $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +fetch $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +exists $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +delete $x # @$x[$N[0], $N[1]] = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store $x->[$N[0]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +store $x->[$N[2]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2, 0 ] # +store $x->[$N[0]] = 0, $x->[$N[1]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +store --- exists --- $x # exists $x->[$N[0]] # '', '', [ ] $x # exists $x->[$N[0]] # '', '', undef # $x # exists $x->[$N[0]] # '', '', [ ] # +fetch $x # exists $x->[$N[0]] # '', '', undef # +exists $x # exists $x->[$N[0]] # '', '', [ ] # +delete $x # exists $x->[$N[0]] # '', '', [ ] # +store $x # exists $x->[$N[0]] # '', '', [ ] # +strict +fetch $x # exists $x->[$N[0]] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[$N[0]] # '', '', [ ] # +strict +delete $x # exists $x->[$N[0]] # '', '', [ ] # +strict +store $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] $x # exists $x->[$N[0]]->[$N[1]] # '', '', undef # $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +fetch $x # exists $x->[$N[0]]->[$N[1]] # '', '', undef # +exists $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +delete $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +store $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +strict +fetch $x # exists $x->[$N[0]]->[$N[1]] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +strict +delete $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +strict +store $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +fetch $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +fetch $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +exists $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +exists $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +delete $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +delete $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +store $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +store $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +exists $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +delete $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +store $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +store --- delete --- $x # delete $x->[$N[0]] # '', undef, [ ] $x # delete $x->[$N[0]] # '', undef, undef # $x # delete $x->[$N[0]] # '', undef, [ ] # +fetch $x # delete $x->[$N[0]] # '', undef, [ ] # +exists $x # delete $x->[$N[0]] # '', undef, undef # +delete $x # delete $x->[$N[0]] # '', undef, [ ] # +store $x # delete $x->[$N[0]] # '', undef, [ ] # +strict +fetch $x # delete $x->[$N[0]] # '', undef, [ ] # +strict +exists $x # delete $x->[$N[0]] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[$N[0]] # '', undef, [ ] # +strict +store $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] $x # delete $x->[$N[0]]->[$N[1]] # '', undef, undef # $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +fetch $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +exists $x # delete $x->[$N[0]]->[$N[1]] # '', undef, undef # +delete $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +store $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +fetch $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +exists $x # delete $x->[$N[0]]->[$N[1]] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +store $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +fetch $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +exists $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +delete $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +store $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +store $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +fetch $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +exists $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +delete $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +store $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +store --- store --- $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +fetch $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +exists $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +delete $x # $x->[$N[0]] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +strict +fetch $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +strict +exists $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +strict +delete $x # $x->[$N[0]] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +fetch $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +exists $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +delete $x # $x->[$N[0]]->[$N[1]] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +exists $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +delete $x # $x->[$N[0]]->[$N[1]] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +exists $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +exists $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +delete $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +delete $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +store $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +store $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +store $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # qr/^Can't vivify reference/, undef, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +store autovivification-0.12/META.json0000640000175000017500000000262312212134712015424 0ustar vincevince{ "abstract" : "Lexically disable autovivification.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.74, CPAN::Meta::Converter version 2.132140", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "autovivification", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Config" : "0", "Exporter" : "0", "ExtUtils::MakeMaker" : "0", "Test::More" : "0", "XSLoader" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "XSLoader" : "0", "perl" : "5.008003" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Dist/Display.html?Name=autovivification" }, "homepage" : "http://search.cpan.org/dist/autovivification/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://git.profvince.com/?p=perl%2Fmodules%2Fautovivification.git" } }, "version" : "0.12" } autovivification-0.12/README0000644000175000017500000001405112212134712014665 0ustar vincevinceNAME autovivification - Lexically disable autovivification. VERSION Version 0.12 SYNOPSIS no autovivification; my $hashref; my $a = $hashref->{key_a}; # $hashref stays undef if (exists $hashref->{option}) { # Still undef ... } delete $hashref->{old}; # Still undef again $hashref->{new} = $value; # Vivifies to { new => $value } DESCRIPTION When an undefined variable is dereferenced, it gets silently upgraded to an array or hash reference (depending of the type of the dereferencing). This behaviour is called *autovivification* and usually does what you mean (e.g. when you store a value) but it may be unnatural or surprising because your variables gets populated behind your back. This is especially true when several levels of dereferencing are involved, in which case all levels are vivified up to the last, or when it happens in intuitively read-only constructs like "exists". This pragma lets you disable autovivification for some constructs and optionally throws a warning or an error when it would have happened. METHODS "unimport" no autovivification; # defaults to qw no autovivification qw; no autovivification 'warn'; no autovivification 'strict'; Magically called when "no autovivification @opts" is encountered. Enables the features given in @opts, which can be : * 'fetch' Turns off autovivification for rvalue dereferencing expressions, such as : $value = $arrayref->[$idx] $value = $hashref->{$key} keys %$hashref values %$hashref Starting from perl 5.11, it also covers "keys" and "values" on array references : keys @$arrayref values @$arrayref When the expression would have autovivified, "undef" is returned for a plain fetch, while "keys" and "values" return 0 in scalar context and the empty list in list context. * 'exists' Turns off autovivification for dereferencing expressions that are parts of an "exists", such as : exists $arrayref->[$idx] exists $hashref->{$key} '' is returned when the expression would have autovivified. * 'delete' Turns off autovivification for dereferencing expressions that are parts of a "delete", such as : delete $arrayref->[$idx] delete $hashref->{$key} "undef" is returned when the expression would have autovivified. * 'store' Turns off autovivification for lvalue dereferencing expressions, such as : $arrayref->[$idx] = $value $hashref->{$key} = $value for ($arrayref->[$idx]) { ... } for ($hashref->{$key}) { ... } function($arrayref->[$idx]) function($hashref->{$key}) An exception is thrown if vivification is needed to store the value, which means that effectively you can only assign to levels that are already defined. In the example, this would require $arrayref (resp. $hashref) to already be an array (resp. hash) reference. * 'warn' Emits a warning when an autovivification is avoided. * 'strict' Throws an exception when an autovivification is avoided. Each call to "unimport" adds the specified features to the ones already in use in the current lexical scope. When @opts is empty, it defaults to "qw". "import" use autovivification; # default Perl behaviour use autovivification qw; Magically called when "use autovivification @opts" is encountered. Disables the features given in @opts, which can be the same as for "unimport". Each call to "import" removes the specified features to the ones already in use in the current lexical scope. When @opts is empty, it defaults to restoring the original Perl autovivification behaviour. CONSTANTS "A_THREADSAFE" True if and only if the module could have been built with thread-safety features enabled. This constant only has a meaning when your perl is threaded, otherwise it will always be false. "A_FORKSAFE" True if and only if this module could have been built with fork-safety features enabled. This constant will always be true, except on Windows where it is false for perl 5.10.0 and below. CAVEATS The pragma doesn't apply when one dereferences the returned value of an array or hash slice, as in "@array[$id]->{member}" or @hash{$key}->{member}. This syntax is valid Perl, yet it is discouraged as the slice is here useless since the dereferencing enforces scalar context. If warnings are turned on, Perl will complain about one-element slices. DEPENDENCIES perl 5.8.3. A C compiler. This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard. XSLoader (standard since perl 5.6.0). SEE ALSO perlref. AUTHOR Vincent Pit, "", . You can contact me by mail or on "irc.perl.org" (vincent). BUGS Please report any bugs or feature requests to "bug-autovivification at rt.cpan.org", or through the web interface at . I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc autovivification Tests code coverage report is available at . ACKNOWLEDGEMENTS Matt S. Trout asked for it. COPYRIGHT & LICENSE Copyright 2009,2010,2011,2012,2013 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. autovivification-0.12/Changes0000644000175000017500000001144012212134565015305 0ustar vincevinceRevision history for autovivification 0.12 2013-09-05 17:20 UTC + Fix : Check functions are now replaced and restored in a thread-safe manner, either by using the wrap_op_checker() function from perl when it is available (starting from perl 5.16) or by taking the OP_REFCNT mutex on older perls. + Tst : Author tests are no longer bundled with this distribution. They are only made available to authors in the git repository. 0.11 2013-02-08 19:25 UTC This is a maintenance release. The code contains no functional change. Satisfied users of version 0.10 can skip this update. + Doc : POD tweaks and clarifications. + Tst : Threads tests will not fail anymore if resources constraints prevent the system from creating all the required threads. + Tst : Author tests overhaul. 0.10 2011-08-24 15:00 UTC + Fix : The pragma no longer vivifies the "autovivification" entry in the hints hash %^H on perl 5.8. 0.09 2011-01-05 18:40 UTC + Fix : [RT #64435] : Hangs with File::Copy in Config.pm. This was actually a regression introduced together with the new peephole optimizer strategy, and that caused the pragma to hang on constructs like "for (;;) { ... }". Thanks Michael Schilli for reporting. 0.08 2011-01-03 21:00 UTC + Fix : Building on Windows. 0.07 2010-12-31 16:20 UTC + Chg : perl 5.8.3 is required. + Doc : Complements and clarifications. + Fix : Segmentation faults and misbehaviours in threaded applications. + Fix : Compatibility with perl 5.13.7. Thanks Andreas J. König for reporting and Andrew Main for providing a fix. + Fix : Broken linkage on Windows with gcc 3.4, which appears in particular when using ActivePerl's default compiler suite. For those setups, the autovivification shared library will now be linked against the perl dll directly (instead of the import library). + Opt : The pragma takes slightly more time at compile-time, but is slightly faster at run-time. + Tst : Lengthy tests have been ported to Test::Leaner, making the whole test suite about 50% faster. + Tst : Threads tests are now only run on perl 5.13.4 and higher. They could segfault randomly because of what seems to be an internal bug of Perl, which has been addressed in 5.13.4. There is also an environment variable that allows you to forcefully run those tests, but it should be set only for author testing and not for end users. 0.06 2010-04-24 17:40 UTC + Add : The A_THREADSAFE and A_FORKSAFE constants. + Fix : [RT #56870] : "no autovivification" vs Regexp::Common. This was a bug in how tied arrays and hashes were handled. Thanks Michael G. Schwern for reporting. + Fix : Scope leaks under perl 5.8-5.10.0. + Fix : Segfaults when first loading the pragma from inside a thread. 0.05 2010-03-05 23:15 UTC + Fix : [RT #55154] : Crashes and assertion failures when deparsing and re-eval-uating some code compiled while autovivification was in use. Thanks Michael G. Schwern for reporting. + Fix : [RT #53647] : "leys" typo in pod. Thanks Hinrik Orn Sigurdsson for reporting. 0.04 2010-01-10 00:30 UTC + Add : Array and hash slices are now handled by the pragma. + Fix : Work around Kwalitee test misfailures. 0.03 2009-06-23 22:20 UTC + Add : Handle old-fashion dereferencing (like $$hashref{key}). + Chg : Aliasing constructs (for ($x{foo}) { ... }) are now covered by the 'store' category (and no longer the 'fetch' one). This is because there's no way to know at compile-time if the alias will be assigned to. + Fix : Quadratic complexity at compile-time. + Fix : Segfaults when dereferencing globals. + Fix : Segfaults on big-endian systems. + Tst : Really test plain arrays and hashes. + Tst : Improved coverage. 0.02 2009-06-17 18:05 UTC + Add : 'fetch' also applies to aliasing ("for ($hashref->{key}) { }"). + Fix : Don't segfault on "keys/values %$hashref", and don't vivify if 'fetch' is set. + Fix : Plain dereferencing shouldn't have a different behaviour when the pragma is in use. + Tst : Improved coverage. 0.01 2009-06-14 20:10 UTC First version, released on an unsuspecting world. autovivification-0.12/reap.h0000644000175000017500000000350311511133531015104 0ustar vincevince/* This file is part of the autovivification Perl module. * See http://search.cpan.org/dist/autovivification/ */ /* This header provides a specialized version of Scope::Upper::reap that can be * called directly from XS. * See http://search.cpan.org/dist/Scope-Upper/ for details. */ #ifndef REAP_H #define REAP_H 1 #define REAP_DESTRUCTOR_SIZE 3 typedef struct { I32 depth; I32 *origin; void (*cb)(pTHX_ void *); void *ud; char *dummy; } reap_ud; STATIC void reap_pop(pTHX_ void *); STATIC void reap_pop(pTHX_ void *ud_) { reap_ud *ud = ud_; I32 depth, *origin, mark, base; depth = ud->depth; origin = ud->origin; mark = origin[depth]; base = origin[depth - 1]; if (base < mark) { PL_savestack_ix = mark; leave_scope(base); } PL_savestack_ix = base; if ((ud->depth = --depth) > 0) { SAVEDESTRUCTOR_X(reap_pop, ud); } else { void (*cb)(pTHX_ void *) = ud->cb; void *cb_ud = ud->ud; PerlMemShared_free(ud->origin); PerlMemShared_free(ud); SAVEDESTRUCTOR_X(cb, cb_ud); } } STATIC void reap(pTHX_ I32 depth, void (*cb)(pTHX_ void *), void *cb_ud) { #define reap(D, CB, UD) reap(aTHX_ (D), (CB), (UD)) reap_ud *ud; I32 i; if (depth > PL_scopestack_ix) depth = PL_scopestack_ix; ud = PerlMemShared_malloc(sizeof *ud); ud->depth = depth; ud->origin = PerlMemShared_malloc((depth + 1) * sizeof *ud->origin); ud->cb = cb; ud->ud = cb_ud; ud->dummy = NULL; for (i = depth; i >= 1; --i) { I32 j = PL_scopestack_ix - i; ud->origin[depth - i] = PL_scopestack[j]; PL_scopestack[j] += REAP_DESTRUCTOR_SIZE; } ud->origin[depth] = PL_savestack_ix; while (PL_savestack_ix + REAP_DESTRUCTOR_SIZE <= PL_scopestack[PL_scopestack_ix - 1]) { save_pptr(&ud->dummy); } SAVEDESTRUCTOR_X(reap_pop, ud); } #endif /* REAP_H */ autovivification-0.12/autovivification.xs0000644000175000017500000007241312207502475017763 0ustar vincevince/* This file is part of the autovivification Perl module. * See http://search.cpan.org/dist/autovivification/ */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define __PACKAGE__ "autovivification" #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) /* --- Compatibility wrappers ---------------------------------------------- */ #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif #define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #ifndef A_WORKAROUND_REQUIRE_PROPAGATION # define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1) #endif #ifndef A_HAS_RPEEP # define A_HAS_RPEEP A_HAS_PERL(5, 13, 5) #endif /* ... Thread safety and multiplicity ...................................... */ /* Always safe when the workaround isn't needed */ #if !A_WORKAROUND_REQUIRE_PROPAGATION # undef A_FORKSAFE # define A_FORKSAFE 1 /* Otherwise, safe unless Makefile.PL says it's Win32 */ #elif !defined(A_FORKSAFE) # define A_FORKSAFE 1 #endif #ifndef A_MULTIPLICITY # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) # define A_MULTIPLICITY 1 # else # define A_MULTIPLICITY 0 # endif #endif #ifndef tTHX # define tTHX PerlInterpreter* #endif #if A_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV)) # define A_THREADSAFE 1 # ifndef MY_CXT_CLONE # define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # endif #else # define A_THREADSAFE 0 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT a_globaldata # undef START_MY_CXT # define START_MY_CXT STATIC my_cxt_t MY_CXT; # undef MY_CXT_INIT # define MY_CXT_INIT NOOP # undef MY_CXT_CLONE # define MY_CXT_CLONE NOOP #endif #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) # define A_CHECK_MUTEX_LOCK OP_CHECK_MUTEX_LOCK # define A_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK #else # define A_CHECK_MUTEX_LOCK OP_REFCNT_LOCK # define A_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK #endif typedef OP *(*a_ck_t)(pTHX_ OP *); #ifdef wrap_op_checker # define a_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) #else STATIC void a_ck_replace(pTHX_ OPCODE type, a_ck_t new_ck, a_ck_t *old_ck_p) { #define a_ck_replace(T, NC, OCP) a_ck_replace(aTHX_ (T), (NC), (OCP)) A_CHECK_MUTEX_LOCK; if (!*old_ck_p) { *old_ck_p = PL_check[type]; PL_check[type] = new_ck; } A_CHECK_MUTEX_UNLOCK; } #endif STATIC void a_ck_restore(pTHX_ OPCODE type, a_ck_t *old_ck_p) { #define a_ck_restore(T, OCP) a_ck_restore(aTHX_ (T), (OCP)) A_CHECK_MUTEX_LOCK; if (*old_ck_p) { PL_check[type] = *old_ck_p; *old_ck_p = 0; } A_CHECK_MUTEX_UNLOCK; } /* --- Helpers ------------------------------------------------------------- */ /* ... Thread-safe hints ................................................... */ #if A_WORKAROUND_REQUIRE_PROPAGATION typedef struct { U32 bits; IV require_tag; } a_hint_t; #define A_HINT_FREE(H) PerlMemShared_free(H) #if A_THREADSAFE #define PTABLE_NAME ptable_hints #define PTABLE_VAL_FREE(V) A_HINT_FREE(V) #define pPTBL pTHX #define pPTBL_ pTHX_ #define aPTBL aTHX #define aPTBL_ aTHX_ #include "ptable.h" #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V)) #define ptable_hints_free(T) ptable_hints_free(aTHX_ (T)) #endif /* A_THREADSAFE */ #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */ #define PTABLE_NAME ptable_seen #define PTABLE_VAL_FREE(V) NOOP #include "ptable.h" /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */ #define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V)) #define ptable_seen_clear(T) ptable_seen_clear(aPTBLMS_ (T)) #define ptable_seen_free(T) ptable_seen_free(aPTBLMS_ (T)) #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION ptable *tbl; /* It really is a ptable_hints */ tTHX owner; #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */ ptable *seen; /* It really is a ptable_seen */ } my_cxt_t; START_MY_CXT #if A_THREADSAFE #if A_WORKAROUND_REQUIRE_PROPAGATION typedef struct { ptable *tbl; #if A_HAS_PERL(5, 13, 2) CLONE_PARAMS *params; #else CLONE_PARAMS params; #endif } a_ptable_clone_ud; #if A_HAS_PERL(5, 13, 2) # define a_ptable_clone_ud_init(U, T, O) \ (U).tbl = (T); \ (U).params = Perl_clone_params_new((O), aTHX) # define a_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) # define a_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) #else # define a_ptable_clone_ud_init(U, T, O) \ (U).tbl = (T); \ (U).params.stashes = newAV(); \ (U).params.flags = 0; \ (U).params.proto_perl = (O) # define a_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) # define a_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params))) #endif STATIC void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { a_ptable_clone_ud *ud = ud_; a_hint_t *h1 = ent->val; a_hint_t *h2; h2 = PerlMemShared_malloc(sizeof *h2); h2->bits = h1->bits; h2->require_tag = PTR2IV(a_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); ptable_hints_store(ud->tbl, ent->key, h2); } #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */ #include "reap.h" STATIC void a_thread_cleanup(pTHX_ void *ud) { dMY_CXT; #if A_WORKAROUND_REQUIRE_PROPAGATION ptable_hints_free(MY_CXT.tbl); #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */ ptable_seen_free(MY_CXT.seen); } #endif /* A_THREADSAFE */ #if A_WORKAROUND_REQUIRE_PROPAGATION STATIC IV a_require_tag(pTHX) { #define a_require_tag() a_require_tag(aTHX) const CV *cv, *outside; cv = PL_compcv; if (!cv) { /* If for some reason the pragma is operational at run-time, try to discover * the current cv in use. */ const PERL_SI *si; for (si = PL_curstackinfo; si; si = si->si_prev) { I32 cxix; for (cxix = si->si_cxix; cxix >= 0; --cxix) { const PERL_CONTEXT *cx = si->si_cxstack + cxix; switch (CxTYPE(cx)) { case CXt_SUB: case CXt_FORMAT: /* The propagation workaround is only needed up to 5.10.0 and at that * time format and sub contexts were still identical. And even later the * cv members offsets should have been kept the same. */ cv = cx->blk_sub.cv; goto get_enclosing_cv; case CXt_EVAL: cv = cx->blk_eval.cv; goto get_enclosing_cv; default: break; } } } cv = PL_main_cv; } get_enclosing_cv: for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) cv = outside; return PTR2IV(cv); } STATIC SV *a_tag(pTHX_ UV bits) { #define a_tag(B) a_tag(aTHX_ (B)) a_hint_t *h; h = PerlMemShared_malloc(sizeof *h); h->bits = bits; h->require_tag = a_require_tag(); #if A_THREADSAFE { dMY_CXT; /* We only need for the key to be an unique tag for looking up the value later * Allocated memory provides convenient unique identifiers, so that's why we * use the hint as the key itself. */ ptable_hints_store(MY_CXT.tbl, h, h); } #endif /* A_THREADSAFE */ return newSViv(PTR2IV(h)); } STATIC UV a_detag(pTHX_ const SV *hint) { #define a_detag(H) a_detag(aTHX_ (H)) a_hint_t *h; if (!(hint && SvIOK(hint))) return 0; h = INT2PTR(a_hint_t *, SvIVX(hint)); #if A_THREADSAFE { dMY_CXT; h = ptable_fetch(MY_CXT.tbl, h); } #endif /* A_THREADSAFE */ if (a_require_tag() != h->require_tag) return 0; return h->bits; } #else /* A_WORKAROUND_REQUIRE_PROPAGATION */ #define a_tag(B) newSVuv(B) /* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV * from a copy. */ #define a_detag(H) \ ((H) \ ? (SvIOK(H) \ ? SvUVX(H) \ : (SvPOK(H) \ ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \ : 0 \ ) \ ) \ : 0) #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */ /* Used both for hints and op flags */ #define A_HINT_STRICT 1 #define A_HINT_WARN 2 #define A_HINT_FETCH 4 #define A_HINT_STORE 8 #define A_HINT_EXISTS 16 #define A_HINT_DELETE 32 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN) #define A_HINT_DO (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE) #define A_HINT_MASK (A_HINT_NOTIFY|A_HINT_DO) /* Only used in op flags */ #define A_HINT_ROOT 64 #define A_HINT_DEREF 128 STATIC U32 a_hash = 0; STATIC UV a_hint(pTHX) { #define a_hint() a_hint(aTHX) SV *hint; #ifdef cop_hints_fetch_pvn hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, a_hash, 0); #elif A_HAS_PERL(5, 9, 5) hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, NULL, __PACKAGE__, __PACKAGE_LEN__, 0, a_hash); #else SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); if (!val) return 0; hint = *val; #endif return a_detag(hint); } /* ... op => info map ...................................................... */ typedef struct { OP *(*old_pp)(pTHX); void *next; UV flags; } a_op_info; #define PTABLE_NAME ptable_map #define PTABLE_VAL_FREE(V) PerlMemShared_free(V) #include "ptable.h" /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */ #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V)) #define ptable_map_delete(T, K) ptable_map_delete(aPTBLMS_ (T), (K)) STATIC ptable *a_op_map = NULL; #ifdef USE_ITHREADS #define dA_MAP_THX a_op_info a_op_map_tmp_oi STATIC perl_mutex a_op_map_mutex; #define A_LOCK(M) MUTEX_LOCK(M) #define A_UNLOCK(M) MUTEX_UNLOCK(M) STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) { const a_op_info *val; A_LOCK(&a_op_map_mutex); val = ptable_fetch(a_op_map, o); if (val) { *oi = *val; val = oi; } A_UNLOCK(&a_op_map_mutex); return val; } #define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi) #else /* USE_ITHREADS */ #define dA_MAP_THX dNOOP #define A_LOCK(M) NOOP #define A_UNLOCK(M) NOOP #define a_map_fetch(O) ptable_fetch(a_op_map, (O)) #endif /* !USE_ITHREADS */ STATIC const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) { #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F)) a_op_info *oi; if (!(oi = ptable_fetch(a_op_map, o))) { oi = PerlMemShared_malloc(sizeof *oi); ptable_map_store(a_op_map, o, oi); } oi->old_pp = old_pp; oi->next = next; oi->flags = flags; return oi; } STATIC void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) { #define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F)) A_LOCK(&a_op_map_mutex); a_map_store_locked(o, old_pp, next, flags); A_UNLOCK(&a_op_map_mutex); } STATIC void a_map_delete(pTHX_ const OP *o) { #define a_map_delete(O) a_map_delete(aTHX_ (O)) A_LOCK(&a_op_map_mutex); ptable_map_delete(a_op_map, o); A_UNLOCK(&a_op_map_mutex); } STATIC const OP *a_map_descend(const OP *o) { switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { case OA_BASEOP: case OA_UNOP: case OA_BINOP: case OA_BASEOP_OR_UNOP: return cUNOPo->op_first; case OA_LIST: case OA_LISTOP: return cLISTOPo->op_last; } return NULL; } STATIC void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV flags) { #define a_map_store_root(R, PP, F) a_map_store_root(aPTBLMS_ (R), (PP), (F)) const a_op_info *roi; a_op_info *oi; const OP *o = root; A_LOCK(&a_op_map_mutex); roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT); while (o->op_flags & OPf_KIDS) { o = a_map_descend(o); if (!o) break; if ((oi = ptable_fetch(a_op_map, o))) { oi->flags &= ~A_HINT_ROOT; oi->next = (a_op_info *) roi; break; } } A_UNLOCK(&a_op_map_mutex); return; } STATIC void a_map_update_flags_topdown(const OP *root, UV flags) { a_op_info *oi; const OP *o = root; A_LOCK(&a_op_map_mutex); flags &= ~A_HINT_ROOT; do { if ((oi = ptable_fetch(a_op_map, o))) oi->flags = (oi->flags & A_HINT_ROOT) | flags; if (!(o->op_flags & OPf_KIDS)) break; o = a_map_descend(o); } while (o); A_UNLOCK(&a_op_map_mutex); return; } #define a_map_cancel(R) a_map_update_flags_topdown((R), 0) STATIC void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) { a_op_info *oi; A_LOCK(&a_op_map_mutex); flags &= ~A_HINT_ROOT; rflags |= A_HINT_ROOT; oi = ptable_fetch(a_op_map, o); while (!(oi->flags & A_HINT_ROOT)) { oi->flags = flags; oi = oi->next; } oi->flags = rflags; A_UNLOCK(&a_op_map_mutex); return; } /* ... Decide whether this expression should be autovivified or not ........ */ STATIC UV a_map_resolve(const OP *o, const a_op_info *oi) { UV flags = 0, rflags; const OP *root; const a_op_info *roi = oi; while (!(roi->flags & A_HINT_ROOT)) roi = roi->next; if (!roi) goto cancel; rflags = roi->flags & ~A_HINT_ROOT; if (!rflags) goto cancel; root = roi->next; if (root->op_flags & OPf_MOD) { if (rflags & A_HINT_STORE) flags = (A_HINT_STORE|A_HINT_DEREF); } else if (rflags & A_HINT_FETCH) flags = (A_HINT_FETCH|A_HINT_DEREF); if (!flags) { cancel: a_map_update_flags_bottomup(o, 0, 0); return 0; } flags |= (rflags & A_HINT_NOTIFY); a_map_update_flags_bottomup(o, flags, 0); return oi->flags & A_HINT_ROOT ? 0 : flags; } /* ... Inspired from pp_defined() .......................................... */ STATIC int a_undef(pTHX_ SV *sv) { #define a_undef(S) a_undef(aTHX_ (S)) switch (SvTYPE(sv)) { case SVt_NULL: return 1; case SVt_PVAV: if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) return 0; break; case SVt_PVHV: if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) return 0; break; default: SvGETMAGIC(sv); if (SvOK(sv)) return 0; } return 1; } /* --- PP functions -------------------------------------------------------- */ /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp * value, another extension might have saved our pp replacement as the ppaddr * for this op, so this doesn't ensure that our function will never be called * again. That's why we don't remove the op info from our map, so that it can * still run correctly if required. */ /* ... pp_rv2av ............................................................ */ STATIC OP *a_pp_rv2av(pTHX) { dA_MAP_THX; const a_op_info *oi; dSP; oi = a_map_fetch(PL_op); if (oi->flags & A_HINT_DEREF) { if (a_undef(TOPs)) { /* We always need to push an empty array to fool the pp_aelem() that comes * later. */ SV *av; (void) POPs; av = sv_2mortal((SV *) newAV()); PUSHs(av); RETURN; } } return oi->old_pp(aTHX); } /* ... pp_rv2hv ............................................................ */ STATIC OP *a_pp_rv2hv_simple(pTHX) { dA_MAP_THX; const a_op_info *oi; dSP; oi = a_map_fetch(PL_op); if (oi->flags & A_HINT_DEREF) { if (a_undef(TOPs)) RETURN; } return oi->old_pp(aTHX); } STATIC OP *a_pp_rv2hv(pTHX) { dA_MAP_THX; const a_op_info *oi; dSP; oi = a_map_fetch(PL_op); if (oi->flags & A_HINT_DEREF) { if (a_undef(TOPs)) { SV *hv; (void) POPs; hv = sv_2mortal((SV *) newHV()); PUSHs(hv); RETURN; } } return oi->old_pp(aTHX); } /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */ STATIC OP *a_pp_deref(pTHX) { dA_MAP_THX; const a_op_info *oi; UV flags; dSP; oi = a_map_fetch(PL_op); flags = oi->flags; if (flags & A_HINT_DEREF) { OP *o; o = oi->old_pp(aTHX); if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) { SPAGAIN; if (a_undef(TOPs)) { if (flags & A_HINT_STRICT) croak("Reference vivification forbidden"); else if (flags & A_HINT_WARN) warn("Reference was vivified"); else /* A_HINT_STORE */ croak("Can't vivify reference"); } } return o; } return oi->old_pp(aTHX); } /* ... pp_root (exists,delete,keys,values) ................................. */ STATIC OP *a_pp_root_unop(pTHX) { dSP; if (a_undef(TOPs)) { (void) POPs; /* Can only be reached by keys or values */ if (GIMME_V == G_SCALAR) { dTARGET; PUSHi(0); } RETURN; } { dA_MAP_THX; const a_op_info *oi = a_map_fetch(PL_op); return oi->old_pp(aTHX); } } STATIC OP *a_pp_root_binop(pTHX) { dSP; if (a_undef(TOPm1s)) { (void) POPs; (void) POPs; if (PL_op->op_type == OP_EXISTS) RETPUSHNO; else RETPUSHUNDEF; } { dA_MAP_THX; const a_op_info *oi = a_map_fetch(PL_op); return oi->old_pp(aTHX); } } /* --- Check functions ----------------------------------------------------- */ STATIC void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) { #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP)) if (o->op_type == type && o->op_ppaddr != new_pp && cUNOPo->op_first->op_type != OP_GV) { dA_MAP_THX; const a_op_info *oi = a_map_fetch(o); if (oi) { a_map_store(o, o->op_ppaddr, oi->next, oi->flags); o->op_ppaddr = new_pp; } } return; } /* ... ck_pad{any,sv} ...................................................... */ /* Sadly, the padsv OPs we are interested in don't trigger the padsv check * function, but are instead manually mutated from a padany. So we store * the op entry in the op map in the padany check function, and we set their * op_ppaddr member in our peephole optimizer replacement below. */ STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0; STATIC OP *a_ck_padany(pTHX_ OP *o) { UV hint; o = a_old_ck_padany(aTHX_ o); hint = a_hint(); if (hint & A_HINT_DO) a_map_store_root(o, o->op_ppaddr, hint); else a_map_delete(o); return o; } STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0; STATIC OP *a_ck_padsv(pTHX_ OP *o) { UV hint; o = a_old_ck_padsv(aTHX_ o); hint = a_hint(); if (hint & A_HINT_DO) { a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = a_pp_deref; } else a_map_delete(o); return o; } /* ... ck_deref (aelem,helem,rv2sv) ........................................ */ /* Those ops appear both at the root and inside an expression but there's no * way to distinguish both situations. Worse, we can't even know if we are in a * modifying context, so the expression can't be resolved yet. It will be at the * first invocation of a_pp_deref() for this expression. */ STATIC OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0; STATIC OP *(*a_old_ck_helem)(pTHX_ OP *) = 0; STATIC OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0; STATIC OP *a_ck_deref(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; UV hint = a_hint(); switch (o->op_type) { case OP_AELEM: old_ck = a_old_ck_aelem; if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av); break; case OP_HELEM: old_ck = a_old_ck_helem; if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple); break; case OP_RV2SV: old_ck = a_old_ck_rv2sv; break; } o = old_ck(aTHX_ o); if (hint & A_HINT_DO) { a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = a_pp_deref; } else a_map_delete(o); return o; } /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */ /* Those ops also appear both inisde and at the root, hence the caveats for * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the * expression. */ STATIC OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0; STATIC OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0; STATIC OP *a_ck_rv2xv(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; OP * (*new_pp)(pTHX) = 0; UV hint; switch (o->op_type) { case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break; case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break; } o = old_ck(aTHX_ o); if (cUNOPo->op_first->op_type == OP_GV) return o; hint = a_hint(); if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) { a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = new_pp; } else a_map_delete(o); return o; } /* ... ck_xslice (aslice,hslice) ........................................... */ /* I think those are only found at the root, but there's nothing that really * prevent them to be inside the expression too. We only need to update the * root so that the rest of the expression will see the right context when * resolving. That's why we don't replace the ppaddr. */ STATIC OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0; STATIC OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0; STATIC OP *a_ck_xslice(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; UV hint = a_hint(); switch (o->op_type) { case OP_ASLICE: old_ck = a_old_ck_aslice; break; case OP_HSLICE: old_ck = a_old_ck_hslice; if (hint & A_HINT_DO) a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv); break; } o = old_ck(aTHX_ o); if (hint & A_HINT_DO) { a_map_store_root(o, 0, hint); } else a_map_delete(o); return o; } /* ... ck_root (exists,delete,keys,values) ................................. */ /* Those ops are only found at the root of a dereferencing expression. We can * then resolve at compile time if vivification must take place or not. */ STATIC OP *(*a_old_ck_exists)(pTHX_ OP *) = 0; STATIC OP *(*a_old_ck_delete)(pTHX_ OP *) = 0; STATIC OP *(*a_old_ck_keys) (pTHX_ OP *) = 0; STATIC OP *(*a_old_ck_values)(pTHX_ OP *) = 0; STATIC OP *a_ck_root(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; OP * (*new_pp)(pTHX) = 0; bool enabled = FALSE; UV hint = a_hint(); switch (o->op_type) { case OP_EXISTS: old_ck = a_old_ck_exists; new_pp = a_pp_root_binop; enabled = hint & A_HINT_EXISTS; break; case OP_DELETE: old_ck = a_old_ck_delete; new_pp = a_pp_root_binop; enabled = hint & A_HINT_DELETE; break; case OP_KEYS: old_ck = a_old_ck_keys; new_pp = a_pp_root_unop; enabled = hint & A_HINT_FETCH; break; case OP_VALUES: old_ck = a_old_ck_values; new_pp = a_pp_root_unop; enabled = hint & A_HINT_FETCH; break; } o = old_ck(aTHX_ o); if (hint & A_HINT_DO) { if (enabled) { a_map_update_flags_topdown(o, hint | A_HINT_DEREF); a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = new_pp; } else { a_map_cancel(o); } } else a_map_delete(o); return o; } /* ... Our peephole optimizer .............................................. */ STATIC peep_t a_old_peep = 0; /* This is actually the rpeep past 5.13.5 */ STATIC void a_peep_rec(pTHX_ OP *o, ptable *seen); STATIC void a_peep_rec(pTHX_ OP *o, ptable *seen) { #define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen) for (; o; o = o->op_next) { dA_MAP_THX; const a_op_info *oi = NULL; UV flags = 0; if (ptable_fetch(seen, o)) break; ptable_seen_store(seen, o, o); switch (o->op_type) { case OP_PADSV: if (o->op_ppaddr != a_pp_deref) { oi = a_map_fetch(o); if (oi && (oi->flags & A_HINT_DO)) { a_map_store(o, o->op_ppaddr, oi->next, oi->flags); o->op_ppaddr = a_pp_deref; } } /* FALLTHROUGH */ case OP_AELEM: case OP_AELEMFAST: case OP_HELEM: case OP_RV2SV: if (o->op_ppaddr != a_pp_deref) break; oi = a_map_fetch(o); if (!oi) break; flags = oi->flags; if (!(flags & A_HINT_DEREF) && (flags & A_HINT_DO) && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) { /* Decide if the expression must autovivify or not. */ flags = a_map_resolve(o, oi); } if (flags & A_HINT_DEREF) o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER); else o->op_ppaddr = oi->old_pp; break; case OP_RV2AV: case OP_RV2HV: if ( o->op_ppaddr != a_pp_rv2av && o->op_ppaddr != a_pp_rv2hv && o->op_ppaddr != a_pp_rv2hv_simple) break; oi = a_map_fetch(o); if (!oi) break; if (!(oi->flags & A_HINT_DEREF)) o->op_ppaddr = oi->old_pp; break; #if !A_HAS_RPEEP case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: case OP_OR: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_COND_EXPR: case OP_RANGE: # if A_HAS_PERL(5, 10, 0) case OP_ONCE: case OP_DOR: case OP_DORASSIGN: # endif a_peep_rec(cLOGOPo->op_other); break; case OP_ENTERLOOP: case OP_ENTERITER: a_peep_rec(cLOOPo->op_redoop); a_peep_rec(cLOOPo->op_nextop); a_peep_rec(cLOOPo->op_lastop); break; # if A_HAS_PERL(5, 9, 5) case OP_SUBST: a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart); break; # else case OP_QR: case OP_MATCH: case OP_SUBST: a_peep_rec(cPMOPo->op_pmreplstart); break; # endif #endif /* !A_HAS_RPEEP */ default: break; } } } STATIC void a_peep(pTHX_ OP *o) { dMY_CXT; ptable *seen = MY_CXT.seen; a_old_peep(aTHX_ o); ptable_seen_clear(seen); a_peep_rec(o); ptable_seen_clear(seen); } /* --- Interpreter setup/teardown ------------------------------------------ */ STATIC U32 a_initialized = 0; STATIC void a_teardown(pTHX_ void *root) { if (!a_initialized) return; #if A_MULTIPLICITY if (aTHX != root) return; #endif { dMY_CXT; # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION ptable_hints_free(MY_CXT.tbl); # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */ ptable_seen_free(MY_CXT.seen); } a_ck_restore(OP_PADANY, &a_old_ck_padany); a_ck_restore(OP_PADSV, &a_old_ck_padsv); a_ck_restore(OP_AELEM, &a_old_ck_aelem); a_ck_restore(OP_HELEM, &a_old_ck_helem); a_ck_restore(OP_RV2SV, &a_old_ck_rv2sv); a_ck_restore(OP_RV2AV, &a_old_ck_rv2av); a_ck_restore(OP_RV2HV, &a_old_ck_rv2hv); a_ck_restore(OP_ASLICE, &a_old_ck_aslice); a_ck_restore(OP_HSLICE, &a_old_ck_hslice); a_ck_restore(OP_EXISTS, &a_old_ck_exists); a_ck_restore(OP_DELETE, &a_old_ck_delete); a_ck_restore(OP_KEYS, &a_old_ck_keys); a_ck_restore(OP_VALUES, &a_old_ck_values); #if A_HAS_RPEEP PL_rpeepp = a_old_peep; #else PL_peepp = a_old_peep; #endif a_old_peep = 0; a_initialized = 0; } STATIC void a_setup(pTHX) { #define a_setup() a_setup(aTHX) if (a_initialized) return; { MY_CXT_INIT; # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION MY_CXT.tbl = ptable_new(); MY_CXT.owner = aTHX; # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */ MY_CXT.seen = ptable_new(); } a_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany); a_ck_replace(OP_PADSV, a_ck_padsv, &a_old_ck_padsv); a_ck_replace(OP_AELEM, a_ck_deref, &a_old_ck_aelem); a_ck_replace(OP_HELEM, a_ck_deref, &a_old_ck_helem); a_ck_replace(OP_RV2SV, a_ck_deref, &a_old_ck_rv2sv); a_ck_replace(OP_RV2AV, a_ck_rv2xv, &a_old_ck_rv2av); a_ck_replace(OP_RV2HV, a_ck_rv2xv, &a_old_ck_rv2hv); a_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice); a_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice); a_ck_replace(OP_EXISTS, a_ck_root, &a_old_ck_exists); a_ck_replace(OP_DELETE, a_ck_root, &a_old_ck_delete); a_ck_replace(OP_KEYS, a_ck_root, &a_old_ck_keys); a_ck_replace(OP_VALUES, a_ck_root, &a_old_ck_values); #if A_HAS_RPEEP a_old_peep = PL_rpeepp; PL_rpeepp = a_peep; #else a_old_peep = PL_peepp; PL_peepp = a_peep; #endif #if A_MULTIPLICITY call_atexit(a_teardown, aTHX); #else call_atexit(a_teardown, NULL); #endif a_initialized = 1; } STATIC U32 a_booted = 0; /* --- XS ------------------------------------------------------------------ */ MODULE = autovivification PACKAGE = autovivification PROTOTYPES: ENABLE BOOT: { if (!a_booted++) { HV *stash; a_op_map = ptable_new(); #ifdef USE_ITHREADS MUTEX_INIT(&a_op_map_mutex); #endif PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__); stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT)); newCONSTSUB(stash, "A_HINT_WARN", newSVuv(A_HINT_WARN)); newCONSTSUB(stash, "A_HINT_FETCH", newSVuv(A_HINT_FETCH)); newCONSTSUB(stash, "A_HINT_STORE", newSVuv(A_HINT_STORE)); newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS)); newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE)); newCONSTSUB(stash, "A_HINT_MASK", newSVuv(A_HINT_MASK)); newCONSTSUB(stash, "A_THREADSAFE", newSVuv(A_THREADSAFE)); newCONSTSUB(stash, "A_FORKSAFE", newSVuv(A_FORKSAFE)); } a_setup(); } #if A_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PREINIT: #if A_WORKAROUND_REQUIRE_PROPAGATION ptable *t; #endif ptable *s; PPCODE: { dMY_CXT; #if A_WORKAROUND_REQUIRE_PROPAGATION { a_ptable_clone_ud ud; t = ptable_new(); a_ptable_clone_ud_init(ud, t, MY_CXT.owner); ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud); a_ptable_clone_ud_deinit(ud); } #endif s = ptable_new(); } { MY_CXT_CLONE; #if A_WORKAROUND_REQUIRE_PROPAGATION MY_CXT.tbl = t; MY_CXT.owner = aTHX; #endif MY_CXT.seen = s; } reap(3, a_thread_cleanup, NULL); XSRETURN(0); #endif /* A_THREADSAFE */ SV * _tag(SV *hint) PROTOTYPE: $ CODE: RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0); OUTPUT: RETVAL SV * _detag(SV *tag) PROTOTYPE: $ CODE: if (!SvOK(tag)) XSRETURN_UNDEF; RETVAL = newSVuv(a_detag(tag)); OUTPUT: RETVAL autovivification-0.12/ptable.h0000644000175000017500000001313711651337713015445 0ustar vincevince/* This file is part of the autovivification Perl module. * See http://search.cpan.org/dist/autovivification/ */ /* This is a pointer table implementation essentially copied from the ptr_table * implementation in perl's sv.c, except that it has been modified to use memory * shared across threads. * Copyright goes to the original authors, bug reports to me. */ /* This header is designed to be included several times with different * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */ #undef VOID2 #ifdef __cplusplus # define VOID2(T, P) static_cast(P) #else # define VOID2(T, P) (P) #endif #undef pPTBLMS #undef pPTBLMS_ #undef aPTBLMS #undef aPTBLMS_ /* Context for PerlMemShared_* functions */ #ifdef PERL_IMPLICIT_SYS # define pPTBLMS pTHX # define pPTBLMS_ pTHX_ # define aPTBLMS aTHX # define aPTBLMS_ aTHX_ #else # define pPTBLMS void # define pPTBLMS_ # define aPTBLMS # define aPTBLMS_ #endif #ifndef pPTBL # define pPTBL pPTBLMS #endif #ifndef pPTBL_ # define pPTBL_ pPTBLMS_ #endif #ifndef aPTBL # define aPTBL aPTBLMS #endif #ifndef aPTBL_ # define aPTBL_ aPTBLMS_ #endif #ifndef PTABLE_NAME # define PTABLE_NAME ptable #endif #ifndef PTABLE_VAL_FREE # define PTABLE_VAL_FREE(V) #endif #ifndef PTABLE_JOIN # define PTABLE_PASTE(A, B) A ## B # define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B) #endif #ifndef PTABLE_PREFIX # define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X) #endif #ifndef ptable_ent typedef struct ptable_ent { struct ptable_ent *next; const void * key; void * val; } ptable_ent; #define ptable_ent ptable_ent #endif /* !ptable_ent */ #ifndef ptable typedef struct ptable { ptable_ent **ary; size_t max; size_t items; } ptable; #define ptable ptable #endif /* !ptable */ #ifndef ptable_new STATIC ptable *ptable_new(pPTBLMS) { #define ptable_new() ptable_new(aPTBLMS) ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t)); t->max = 63; t->items = 0; t->ary = VOID2(ptable_ent **, PerlMemShared_calloc(t->max + 1, sizeof *t->ary)); return t; } #endif /* !ptable_new */ #ifndef PTABLE_HASH # define PTABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) #endif #ifndef ptable_find STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) { #define ptable_find ptable_find ptable_ent *ent; const UV hash = PTABLE_HASH(key); ent = t->ary[hash & t->max]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } return NULL; } #endif /* !ptable_find */ #ifndef ptable_fetch STATIC void *ptable_fetch(const ptable * const t, const void * const key) { #define ptable_fetch ptable_fetch const ptable_ent *const ent = ptable_find(t, key); return ent ? ent->val : NULL; } #endif /* !ptable_fetch */ #ifndef ptable_split STATIC void ptable_split(pPTBLMS_ ptable * const t) { #define ptable_split(T) ptable_split(aPTBLMS_ (T)) ptable_ent **ary = t->ary; const size_t oldsize = t->max + 1; size_t newsize = oldsize * 2; size_t i; ary = VOID2(ptable_ent **, PerlMemShared_realloc(ary, newsize * sizeof(*ary))); Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary)); t->max = --newsize; t->ary = ary; for (i = 0; i < oldsize; i++, ary++) { ptable_ent **curentp, **entp, *ent; if (!*ary) continue; curentp = ary + oldsize; for (entp = ary, ent = *ary; ent; ent = *entp) { if ((newsize & PTABLE_HASH(ent->key)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; continue; } else entp = &ent->next; } } } #endif /* !ptable_split */ STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { ptable_ent *ent = ptable_find(t, key); if (ent) { void *oldval = ent->val; PTABLE_VAL_FREE(oldval); ent->val = val; } else if (val) { const size_t i = PTABLE_HASH(key) & t->max; ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent)); ent->key = key; ent->val = val; ent->next = t->ary[i]; t->ary[i] = ent; t->items++; if (ent->next && t->items > t->max) ptable_split(t); } } STATIC void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) { ptable_ent *prev, *ent; const size_t i = PTABLE_HASH(key) & t->max; prev = NULL; ent = t->ary[i]; for (; ent; prev = ent, ent = ent->next) { if (ent->key == key) break; } if (ent) { if (prev) prev->next = ent->next; else t->ary[i] = ent->next; PTABLE_VAL_FREE(ent->val); PerlMemShared_free(ent); } } #ifndef ptable_walk STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { #define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD)) if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; do { ptable_ent *entry; for (entry = array[i]; entry; entry = entry->next) if (entry->val) cb(aTHX_ entry, userdata); } while (i--); } } #endif /* !ptable_walk */ STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; do { ptable_ent *entry = array[i]; while (entry) { ptable_ent * const oentry = entry; void *val = oentry->val; entry = entry->next; PTABLE_VAL_FREE(val); PerlMemShared_free(oentry); } array[i] = NULL; } while (i--); t->items = 0; } } STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { if (!t) return; PTABLE_PREFIX(_clear)(aPTBL_ t); PerlMemShared_free(t->ary); PerlMemShared_free(t); } #undef pPTBL #undef pPTBL_ #undef aPTBL #undef aPTBL_ #undef PTABLE_NAME #undef PTABLE_VAL_FREE autovivification-0.12/MANIFEST0000644000175000017500000000167012207502475015152 0ustar vincevinceChanges MANIFEST META.json META.yml Makefile.PL README autovivification.xs lib/autovivification.pm ptable.h reap.h samples/bench.pl samples/hash2array.pl t/00-load.t t/20-hash.t t/22-hash-kv.t t/23-hash-tied.t t/24-hash-numerous.t t/30-array.t t/31-array-fast.t t/32-array-kv.t t/33-array-tied.t t/34-array-numerous.t t/40-scope.t t/41-padsv.t t/42-deparse.t t/43-peep.t t/50-threads.t t/51-threads-teardown.t t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm t/lib/autovivification/TestCases.pm t/lib/autovivification/TestRequired1.pm t/lib/autovivification/TestRequired2.pm t/lib/autovivification/TestRequired4/a0.pm t/lib/autovivification/TestRequired4/b0.pm t/lib/autovivification/TestRequired4/c0.pm t/lib/autovivification/TestRequired5/a0.pm t/lib/autovivification/TestRequired5/b0.pm t/lib/autovivification/TestRequired5/c0.pm t/lib/autovivification/TestRequired5/d0.pm t/lib/autovivification/TestRequired6.pm t/lib/autovivification/TestThreads.pm autovivification-0.12/META.yml0000640000175000017500000000150112212134712015246 0ustar vincevince--- abstract: 'Lexically disable autovivification.' author: - 'Vincent Pit ' build_requires: Config: 0 Exporter: 0 ExtUtils::MakeMaker: 0 Test::More: 0 XSLoader: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.74, CPAN::Meta::Converter version 2.132140' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: autovivification no_index: directory: - t - inc requires: XSLoader: 0 perl: 5.008003 resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Name=autovivification homepage: http://search.cpan.org/dist/autovivification/ license: http://dev.perl.org/licenses/ repository: http://git.profvince.com/?p=perl%2Fmodules%2Fautovivification.git version: 0.12 autovivification-0.12/Makefile.PL0000644000175000017500000000506512207502475015775 0ustar vincevinceuse 5.008_003; use strict; use warnings; use ExtUtils::MakeMaker; use Config; my @DEFINES; my %macro; my $is_gcc_34 = 0; print "Checking if this is gcc 3.4 on Windows trying to link against an import library... "; if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) { my ($libperl, $gccversion) = map $_ || '', @Config{qw}; if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) { $is_gcc_34 = 1; my ($lddlflags, $ldflags) = @Config{qw}; $_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags; $libperl = "-l$libperl"; my $libdirs = join ' ', map { s/(?}; $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl"; $macro{LDFLAGS} = "$ldflags $libdirs $libperl"; $macro{PERL_ARCHIVE} = '', } } print $is_gcc_34 ? "yes\n" : "no\n"; # Threads, Windows and 5.8.x don't seem to be best friends if ($^O eq 'MSWin32' && "$]" < 5.009) { push @DEFINES, '-DA_MULTIPLICITY=0'; } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' && "$]" < 5.010_001) { push @DEFINES, '-DA_FORKSAFE=0'; } @DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES; %macro = (macro => { %macro }) if %macro; # Beware of the circle my $dist = 'autovivification'; (my $name = $dist) =~ s{-}{::}g; (my $file = $dist) =~ s{-}{/}g; $file = "lib/$file.pm"; my %PREREQ_PM = ( 'XSLoader' => 0, ); my %BUILD_REQUIRES = ( 'Config' => 0, 'Exporter' => 0, 'ExtUtils::MakeMaker' => 0, 'Test::More' => 0, %PREREQ_PM, ); my %META = ( configure_requires => { 'ExtUtils::MakeMaker' => 0, }, build_requires => { %BUILD_REQUIRES, }, dynamic_config => 1, resources => { bugtracker => "http://rt.cpan.org/Dist/Display.html?Name=$dist", homepage => "http://search.cpan.org/dist/$dist/", license => 'http://dev.perl.org/licenses/', repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", }, ); WriteMakefile( NAME => $name, AUTHOR => 'Vincent Pit ', LICENSE => 'perl', VERSION_FROM => $file, ABSTRACT_FROM => $file, PL_FILES => {}, @DEFINES, BUILD_REQUIRES => \%BUILD_REQUIRES, PREREQ_PM => \%PREREQ_PM, MIN_PERL_VERSION => '5.008003', META_MERGE => \%META, dist => { PREOP => "pod2text -u $file > \$(DISTVNAME)/README", COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, clean => { FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*" }, %macro, ); autovivification-0.12/samples/0000750000175000017500000000000012212134712015443 5ustar vincevinceautovivification-0.12/samples/hash2array.pl0000644000175000017500000000442611625205565020073 0ustar vincevince#!perl use strict; use warnings; use Fatal qw; use Text::Balanced qw; open my $hash_t, '<', 't/20-hash.t'; open my $array_t, '>', 't/30-array.t'; open my $array_fast_t, '>', 't/31-array-fast.t'; sub num { my ($char) = $_[0] =~ /['"]?([a-z])['"]?/; return ord($char) - ord('a') } sub hash2array { my ($h) = @_; return $h unless $h and ref $h eq 'HASH'; my @array; for (keys %$h) { $array[num($_)] = hash2array($h->{$_}); } return \@array; } sub dump_array { my ($a) = @_; return 'undef' unless defined $a; if (ref $a) { die "Invalid argument" unless ref $a eq 'ARRAY'; return '[ ' . join(', ', map dump_array($_), @$a) . ' ]'; } else { $a = "'\Q$a\E'" if $a !~ /^\s*\d/; return $a; } } sub extract ($$) { extract_bracketed $_[0], $_[1], qr/.*?(?) { if (/^__DATA__$/) { $in_data = 1; print $array_t $_; print $array_fast_t $_; } elsif (!$in_data) { s{'%'}{'\@'}; print $array_t $_; print $array_fast_t $_; } else { print $array_t convert_testcase($_, 0); print $array_fast_t convert_testcase($_, 1); } } close $hash_t; close $array_t; close $array_fast_t; open my $hash_kv_t, '<', 't/22-hash-kv.t'; open my $array_kv_t, '>', 't/32-array-kv.t'; $in_data = 0; while (<$hash_kv_t>) { if (/^__DATA__$/) { $in_data = 1; } elsif (!$in_data) { s{'%'}{'\@'}; if (/\bplan\s*[\s\(]\s*tests\b/) { s/\s*;?\s*$//; s/^(\s*)//; $_ = qq($1if ("\$]" >= 5.011) { $_ } else { plan skip_all => 'perl 5.11 required for keys/values \@array' }\n); } } else { $_ = convert_testcase($_, 1); } print $array_kv_t $_; } autovivification-0.12/samples/bench.pl0000644000175000017500000000373611511133531017074 0ustar vincevince#!perl use strict; use warnings; use Benchmark qw<:hireswallclock cmpthese>; use blib; my $count = -1; my @tests; { my %h = (); push @tests, [ 'Fetch a non-existing key from a hash', { av => sub { $h{a} }, noav => sub { no autovivification; $h{a} }, } ]; } { my %h = (a => 1); push @tests, [ 'Fetch an existing key from a hash', { av => sub { $h{a} }, noav => sub { no autovivification; $h{a} }, } ]; } { my $x = { }; push @tests, [ 'Fetch a non-existing key from a hash reference', { av => sub { $x->{a} }, noav => sub { no autovivification; $x->{a} }, noav_manual => sub { defined $x ? $x->{a} : undef }, } ]; } { my $x = { a => 1 }; push @tests, [ 'Fetch an existing key from a hash reference', { av => sub { $x->{a} }, noav => sub { no autovivification; $x->{a} }, noav_manual => sub { defined $x ? $x->{a} : undef }, } ]; } { my $x = { a => { b => { c => { d => 1 } } } }; push @tests, [ 'Fetch a 4-levels deep existing key from a hash reference', { av => sub { $x->{a}{b}{c}{d} }, noav => sub { no autovivification; $x->{a}{b}{c}{d} }, noav_manual => sub { my $z; defined $x ? ($z = $x->{a}, defined $z ? ($z = $z->{b}, defined $z ? ($z = $z->{c}, defined $z ? $z->{d} : undef) : undef) : undef) : undef }, } ]; } { my $x = { }; $x->{$_} = undef for 100 .. 199; $x->{$_} = { $_ => 1 } for 200 .. 299; my $n = 0; no warnings 'void'; push @tests, [ 'Fetch 2-levels deep existing or non-existing keys from a hash reference', { inc => sub { $n = ($n+1) % 300 }, av => sub { $x->{$n}{$n}; $n = ($n+1) % 300 }, noav => sub { no autovivification; $x->{$n}{$n}; $n = ($n+1) % 300 }, noav_manual => sub { my $z; defined $x ? ($z = $x->{a}, (defined $z ? $z->{b} : undef)) : undef; $n = ($n + 1) % 300 }, } ]; } for my $t (@tests) { printf "--- %s ---\n", $t->[0]; cmpthese $count, $t->[1]; print "\n"; }