SV *sv;
GV *cscgv;
AV *cscav;
+ AV *bhkav;
+ bool bhk_record;
} my_cxt_t;
START_MY_CXT
STATIC MGVTBL rmagical_b = { 0 };
STATIC void
-blockhook_start(pTHX_ int full)
+blockhook_csc_start(pTHX_ int full)
{
dMY_CXT;
AV *const cur = GvAV(MY_CXT.cscgv);
}
STATIC void
-blockhook_pre_end(pTHX_ OP **o)
+blockhook_csc_pre_end(pTHX_ OP **o)
{
dMY_CXT;
}
+STATIC void
+blockhook_test_start(pTHX_ int full)
+{
+ dMY_CXT;
+ AV *av;
+
+ if (MY_CXT.bhk_record) {
+ av = newAV();
+ av_push(av, newSVpvs("start"));
+ av_push(av, newSViv(full));
+ av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
+ }
+}
+
+STATIC void
+blockhook_test_pre_end(pTHX_ OP **o)
+{
+ dMY_CXT;
+
+ if (MY_CXT.bhk_record)
+ av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
+}
+
+STATIC void
+blockhook_test_post_end(pTHX_ OP **o)
+{
+ dMY_CXT;
+
+ if (MY_CXT.bhk_record)
+ av_push(MY_CXT.bhkav, newSVpvs("post_end"));
+}
+
+STATIC void
+blockhook_test_eval(pTHX_ OP *const o)
+{
+ dMY_CXT;
+ AV *av;
+
+ if (MY_CXT.bhk_record) {
+ av = newAV();
+ av_push(av, newSVpvs("eval"));
+ av_push(av, newSVpv(OP_NAME(o), 0));
+ av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
+ }
+}
+
+STATIC BHK bhk_csc, bhk_test;
+
#include "const-c.inc"
MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
BOOT:
{
- BHK *bhk;
MY_CXT_INIT;
MY_CXT.i = 99;
MY_CXT.sv = newSVpv("initial",0);
+
+ MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
+ MY_CXT.bhk_record = 0;
+
+ BhkENTRY_set(&bhk_test, start, blockhook_test_start);
+ BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
+ BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
+ BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
+ Perl_blockhook_register(aTHX_ &bhk_test);
+
MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
- GV_ADD, SVt_PVAV);
+ GV_ADDMULTI, SVt_PVAV);
MY_CXT.cscav = GvAV(MY_CXT.cscgv);
- Newxz(bhk, 1, BHK);
- BhkENTRY_set(bhk, start, blockhook_start);
- BhkENTRY_set(bhk, pre_end, blockhook_pre_end);
- Perl_blockhook_register(aTHX_ bhk);
+ BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
+ BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
+ Perl_blockhook_register(aTHX_ &bhk_csc);
}
void
MY_CXT_CLONE;
MY_CXT.sv = newSVpv("initial_clone",0);
MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
- GV_ADD, SVt_PVAV);
+ GV_ADDMULTI, SVt_PVAV);
MY_CXT.cscav = NULL;
+ MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
+ MY_CXT.bhk_record = 0;
void
print_double(val)
RETVAL = PL_sv_count;
OUTPUT:
RETVAL
+
+void
+bhk_record(bool on)
+ CODE:
+ dMY_CXT;
+ MY_CXT.bhk_record = on;
+ if (on)
+ av_clear(MY_CXT.bhkav);
--- /dev/null
+package t::BHK;
+
+sub import {
+ shift;
+ unless (@_) {
+ XS::APItest::bhk_record(1);
+ return;
+ }
+ if ($_[0] eq "push") {
+ push @XS::APItest::bhkav, $_[1];
+ return;
+ }
+}
+sub unimport { XS::APItest::bhk_record(0) }
+
+1;
--- /dev/null
+package t::Markers;
+
+push @XS::APItest::bhkav, "run/pm";
+
+use t::BHK push => "compile/pm/before";
+sub import {
+ use t::BHK push => "compile/pm/inside";
+ push @XS::APItest::bhkav, "run/import";
+}
+
+use t::BHK push => "compile/pm/after";
+
+1;
--- /dev/null
+#!./perl
+
+# Tests for @{^COMPILE_SCOPE_CONTAINER}
+
+use strict;
+use warnings;
+use Test::More tests => 12;
+use XS::APItest;
+
+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;
+
+my %destroyed;
+
+BEGIN {
+ package CounterObject;
+
+ sub new {
+ my ($class, $name) = @_;
+ return bless { name => $name }, $class;
+ }
+
+ sub name {
+ my ($self) = @_;
+ return $self->{name};
+ }
+
+ sub DESTROY {
+ my ($self) = @_;
+ $destroyed{ $self->name }++;
+ }
+
+
+ package ReplaceCounter;
+ $INC{'ReplaceCounter.pm'} = __FILE__;
+
+ sub import {
+ my ($self, $counter) = @_;
+ $COMPILE_SCOPE_CONTAINER[-1] = CounterObject->new($counter);
+ }
+
+ package InstallCounter;
+ $INC{'InstallCounter.pm'} = __FILE__;
+
+ sub import {
+ my ($class, $counter) = @_;
+ push @COMPILE_SCOPE_CONTAINER, CounterObject->new($counter);
+ }
+
+ package TestCounter;
+ $INC{'TestCounter.pm'} = __FILE__;
+
+ sub import {
+ my ($class, $counter, $number, $message) = @_;
+
+ $number = 1
+ unless defined $number;
+ $message = "counter $counter is found $number times"
+ unless defined $message;
+
+ ::is scalar(grep { $_->name eq $counter } @{COMPILE_SCOPE_CONTAINER}),
+ $number,
+ $message;
+ }
+}
+
+{
+ use InstallCounter 'root';
+ use InstallCounter '3rd-party';
+
+ {
+ BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+
+ use ReplaceCounter 'replace';
+
+ BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+
+ use TestCounter '3rd-party', 0, '3rd-party no longer visible';
+ use TestCounter 'replace', 1, 'replacement now visible';
+ use TestCounter 'root';
+
+ BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+ }
+
+ BEGIN {
+ ok $destroyed{replace}, 'replacement has been destroyed after end of outer scope';
+ }
+
+ use TestCounter 'root', 1, 'root visible again';
+ use TestCounter 'replace', 0, 'lower replacement no longer visible';
+ use TestCounter '3rd-party';
+}
+
+ok $destroyed{ $_ }, "$_ has been destroyed after end of outer scope"
+ for 'root', '3rd-party';
-#!./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";
+}
projects / platform / upstream / perl.git / commitdiff