-#!./perl
+#!/usr/bin/perl
-# Tests for @{^COMPILE_SCOPE_CONTAINER}
-
-use strict;
use warnings;
-use Test::More tests => 12;
+use strict;
+use Test::More tests => 17;
+
use XS::APItest;
+use t::BHK (); # make sure it gets compiled early
-BEGIN {
- # this has to be a full glob alias, since the GvAV gets replaced
- *COMPILE_SCOPE_CONTAINER = \*XS::APItest::COMPILE_SCOPE_CONTAINER;
-}
-our @COMPILE_SCOPE_CONTAINER;
+BEGIN { package XS::APItest; *main::bhkav = \@XS::APItest::bhkav }
-my %destroyed;
+# 'use t::BHK' switches on recording hooks, and clears @bhkav.
+# 'no t::BHK' switches recording off again.
+# 'use t::BHK push => "foo"' pushes onto @bhkav
-BEGIN {
- package CounterObject;
+BEGIN { diag "## COMPILE TIME ##" }
+diag "## RUN TIME ##";
- sub new {
- my ($class, $name) = @_;
- return bless { name => $name }, $class;
- }
+use t::BHK;
+ 1;
+no t::BHK;
- sub name {
- my ($self) = @_;
- return $self->{name};
- }
+BEGIN { is_deeply \@bhkav, [], "no blocks" }
- sub DESTROY {
- my ($self) = @_;
- $destroyed{ $self->name }++;
+use t::BHK;
+ {
+ 1;
}
+no t::BHK;
+BEGIN { is_deeply \@bhkav,
+ [[start => 1], qw/pre_end post_end/],
+ "plain block";
+}
+
+use t::BHK;
+ if (1) { 1 }
+no t::BHK;
- package ReplaceCounter;
- $INC{'ReplaceCounter.pm'} = __FILE__;
+BEGIN { is_deeply \@bhkav,
+ [
+ [start => 1],
+ [start => 0],
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ ],
+ "if block";
+}
- sub import {
- my ($self, $counter) = @_;
- $COMPILE_SCOPE_CONTAINER[-1] = CounterObject->new($counter);
+use t::BHK;
+ for (1) { 1 }
+no t::BHK;
+
+BEGIN { is_deeply \@bhkav,
+ [
+ [start => 1],
+ [start => 0],
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ ],
+ "for loop";
+}
+
+use t::BHK;
+ {
+ { 1; }
}
+no t::BHK;
- package InstallCounter;
- $INC{'InstallCounter.pm'} = __FILE__;
+BEGIN { is_deeply \@bhkav,
+ [
+ [start => 1],
+ [start => 1],
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ ],
+ "nested blocks";
+}
- sub import {
- my ($class, $counter) = @_;
- push @COMPILE_SCOPE_CONTAINER, CounterObject->new($counter);
+use t::BHK;
+ use t::BHK push => "before";
+ {
+ use t::BHK push => "inside";
}
+ use t::BHK push => "after";
+no t::BHK;
- package TestCounter;
- $INC{'TestCounter.pm'} = __FILE__;
+BEGIN { is_deeply \@bhkav,
+ [
+ "before",
+ [start => 1],
+ "inside",
+ qw/pre_end post_end/,
+ "after"
+ ],
+ "hooks called in the correct places";
+}
- sub import {
- my ($class, $counter, $number, $message) = @_;
+use t::BHK;
+ BEGIN { 1 }
+no t::BHK;
- $number = 1
- unless defined $number;
- $message = "counter $counter is found $number times"
- unless defined $message;
+BEGIN { is_deeply \@bhkav,
+ [
+ [start => 1],
+ qw/pre_end post_end/,
+ ],
+ "BEGIN block";
+}
- ::is scalar(grep { $_->name eq $counter } @{COMPILE_SCOPE_CONTAINER}),
- $number,
- $message;
- }
+use t::BHK; t::BHK->import;
+ eval "1";
+no t::BHK; t::BHK->unimport;
+
+BEGIN { is_deeply \@bhkav, [], "string eval (compile)" }
+is_deeply \@bhkav,
+ [
+ [eval => "entereval"],
+ [start => 1],
+ qw/pre_end post_end/,
+ ],
+ "string eval (run)";
+
+delete @INC{qw{t/Null.pm t/Block.pm}};
+
+t::BHK->import;
+ do "t/Null.pm";
+t::BHK->unimport;
+
+is_deeply \@bhkav,
+ [
+ [eval => "dofile"],
+ [start => 1],
+ qw/pre_end post_end/,
+ ],
+ "do file (null)";
+
+t::BHK->import;
+ do "t/Block.pm";
+t::BHK->unimport;
+
+is_deeply \@bhkav,
+ [
+ [eval => "dofile"],
+ [start => 1],
+ [start => 1],
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ ],
+ "do file (single block)";
+
+delete @INC{qw{t/Null.pm t/Block.pm}};
+
+t::BHK->import;
+ require t::Null;
+t::BHK->unimport;
+
+is_deeply \@bhkav,
+ [
+ [eval => "require"],
+ [start => 1],
+ qw/pre_end post_end/,
+ ],
+ "require (null)";
+
+t::BHK->import;
+ require t::Block;
+t::BHK->unimport;
+
+is_deeply \@bhkav,
+ [
+ [eval => "require"],
+ [start => 1],
+ [start => 1],
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ ],
+ "require (single block)";
+
+BEGIN { delete $INC{"t/Block.pm"} }
+
+use t::BHK;
+ use t::Block;
+no t::BHK;
+
+BEGIN { is_deeply \@bhkav,
+ [
+ [eval => "require"],
+ [start => 1],
+ [start => 1],
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ ],
+ "use (single block)";
}
-{
- use InstallCounter 'root';
- use InstallCounter '3rd-party';
+BEGIN { delete $INC{"t/Markers.pm"} }
- {
- BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+use t::BHK;
+ use t::BHK push => "compile/main/before";
+ use t::Markers;
+ use t::BHK push => "compile/main/after";
+no t::BHK;
- use ReplaceCounter 'replace';
+BEGIN { is_deeply \@bhkav,
+ [
+ "compile/main/before",
+ [eval => "require"],
+ [start => 1],
+ "compile/pm/before",
+ [start => 1],
+ "compile/pm/inside",
+ qw/pre_end post_end/,
+ "compile/pm/after",
+ qw/pre_end post_end/,
+ "run/pm",
+ "run/import",
+ "compile/main/after",
+ ],
+ "use with markers";
+}
- BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+# OK, now some *really* evil stuff...
- use TestCounter '3rd-party', 0, '3rd-party no longer visible';
- use TestCounter 'replace', 1, 'replacement now visible';
- use TestCounter 'root';
+BEGIN {
+ package EvalDestroy;
- BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
- }
+ sub DESTROY { $_[0]->() }
+}
- BEGIN {
- ok $destroyed{replace}, 'replacement has been destroyed after end of outer scope';
+use t::BHK;
+ {
+ BEGIN {
+ # grumbleSCOPECHECKgrumble
+ push @XS::APItest::COMPILE_SCOPE_CONTAINER,
+ bless sub {
+ push @bhkav, "DESTROY";
+ }, "EvalDestroy";
+ }
+ 1;
}
+no t::BHK;
- use TestCounter 'root', 1, 'root visible again';
- use TestCounter 'replace', 0, 'lower replacement no longer visible';
- use TestCounter '3rd-party';
+BEGIN { is_deeply \@bhkav,
+ [
+ [start => 1], # block
+ [start => 1], # BEGIN
+ [start => 1], # sub
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ "pre_end",
+ "DESTROY",
+ "post_end",
+ ],
+ "compile-time DESTROY comes between pre_ and post_end";
}
-ok $destroyed{ $_ }, "$_ has been destroyed after end of outer scope"
- for 'root', '3rd-party';
+use t::BHK;
+ {
+ BEGIN {
+ push @XS::APItest::COMPILE_SCOPE_CONTAINER,
+ bless sub {
+ eval "{1}";
+ }, "EvalDestroy";
+ }
+ 1;
+ }
+no t::BHK;
+
+BEGIN { is_deeply \@bhkav,
+ [
+ [start => 1], # block
+ [start => 1], # BEGIN
+ [start => 1], # sub
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ "pre_end",
+ [eval => "entereval"],
+ [start => 1], # eval
+ [start => 1], # block inside eval
+ qw/pre_end post_end/,
+ qw/pre_end post_end/,
+ "post_end",
+ ],
+ "evil eval-in-DESTROY tricks";
+}
https://perl5.git.perl.org / perl5.git / blobdiff