17
17
use base qw(Exporter);
19
our @EXPORT_OK = qw(my_hints new_scope ccstash scope fqname on_require);
19
our $VERSION = '0.60';
20
our @EXPORT_OK = qw(my_hints hints new_scope ccstash scope fqname on_require);
20
21
our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
23
# Perform (XS) cleanup on global destruction (DESTROY is defined in Pragma.xs).
24
# END blocks don't work for this: see https://rt.cpan.org/Ticket/Display.html?id=80400
25
# according to perlvar, package variables are garbage collected after END blocks
26
our $__GLOBAL_DESTRUCTION_MONITOR__ = bless {};
24
28
XSLoader::load(__PACKAGE__, $VERSION);
28
32
# set HINT_LOCALIZE_HH (0x20000)
32
unless ($hints->{'Devel::Pragma'}) {
33
$hints->{'Devel::Pragma'} = 1;
35
on_scope_end \&xs_leave;
37
BEGIN { *hints = \&my_hints }
41
39
# make sure the "enable lexically-scoped %^H" flag is set (on by default in 5.10)
42
40
sub check_hints() {
43
41
unless ($^H & 0x20000) {
44
42
carp('Devel::Pragma: unexpected $^H (HINT_LOCALIZE_HH bit not set) - setting it now, but results may be unreliable');
46
return my_hints; # create it if it doesn't exist - in some perls, it starts out NULL
44
return hints; # create it if it doesn't exist - in some perls, it starts out NULL
49
47
# return a unique integer ID for the current scope
58
56
my $hints = check_hints();
60
58
# this is %^H as an integer - it changes as scopes are entered/exited i.e. it's a unique
61
# identifier for the currently-compiling scope (the scope in which new_scope
59
# identifier for the currently-compiling scope (the scope in which new_scope
64
62
# we don't need to stack/unstack it in %^H as %^H itself takes care of that
65
63
# note: we need to call this *after* %^H is referenced (and possibly autovivified) above
67
# every time new_scope is called, we write this scope ID to $^H{"Devel::Pragma::Scope::$caller"}.
68
# if $^H{"Devel::Pragma::Scope::$caller"} == scope() (i.e. the stored scope ID is the same as the
65
# every time new_scope is called, we write this scope ID to $^H{"Devel::Pragma::new_scope::$caller"}.
66
# if $^H{"Devel::Pragma::new_scope::$caller"} == scope() (i.e. the stored scope ID is the same as the
69
67
# current scope ID), then we're augmenting the current scope; otherwise we're in a new scope - i.e.
70
68
# a nested or outer scope that didn't previously "use MyPragma"
72
70
my $current_scope = scope();
73
my $id = "Devel::Pragma::Scope($caller)";
71
my $id = "Devel::Pragma::new_scope::$caller";
74
72
my $old_scope = exists($hints->{$id}) ? $hints->{$id} : 0;
75
73
my $new_scope; # is this a scope in which new_scope has not previously been called?
118
116
# run registered callbacks after performing a compile-time require or do FILE
119
117
sub _post_require($) {
120
local $@; # if there was an exception on require, make sure we don't clobber it
118
local $@; # if there was an exception on require, make sure we don't clobber it
121
119
_callback(1, shift)
124
122
# common code for pre- and post-require hooks
126
124
my ($index, $hints) = @_;
128
if (my $hooks = $hints->{'Devel::Pragma(Hooks)'}) {
129
for my $key (sort(keys(%$hooks))) {
130
eval { $hooks->{$key}->[$index]->($hints) };
133
my $stage = $index == 0 ? 'pre' : 'post';
134
carp __PACKAGE__ . ": exception in $stage-require callback: $@";
125
my $pairs = $hints->{'Devel::Pragma::on_require'} || [];
127
for my $pair (@$pairs) {
128
eval { $pair->[$index]->($hints) };
131
my $stage = [ qw(pre post) ]->[$index];
132
carp __PACKAGE__ . ": exception in $stage-require callback: $@";
150
147
unless ($arg and _isa($arg, 'CODE'));
153
$hints->{'Devel::Pragma(Hooks)'}->{++$REQUIRE_KEY} = [ @_ ];
150
my $old_callbacks = $hints->{'Devel::Pragma::on_require'} || [];
151
$hints->{'Devel::Pragma::on_require'} = [ @$old_callbacks, [ @_ ] ];
155
# return $REQUIRE_KEY;
159
# sub on_require_remove($) {
161
# my $hints = my_hints();
162
# my $hooks = $hints->{'Devel::Pragma(Hooks)'};
164
# croak(sprintf('%s: attempt to remove a non-existent require hook', __PACKAGE__))
165
# unless ($hooks->{$index});
167
# delete $hooks->{$index};
170
156
# make sure "enable lexically-scoped %^H" is set in older perls, and export the requested functions
172
158
my $class = shift;
189
use Devel::Pragma qw(:all);
192
my ($class, %options) = @_;
193
my $hints = my_hints; # lexically-scoped %^H
194
my $caller = ccstash(); # currently-compiling stash
196
unless ($hints->{MyPragma}) { # top-level
197
$hints->{MyPragma} = 1;
199
# disable/enable this pragma before/after compile-time requires
200
on_require \&teardown, \&setup;
203
if (new_scope($class)) {
207
my $scope_id = scope();
175
use Devel::Pragma qw(:all);
178
my ($class, %options) = @_;
179
my $hints = hints; # lexically-scoped %^H
180
my $caller = ccstash(); # currently-compiling stash
182
unless ($hints->{MyPragma}) { # top-level
183
$hints->{MyPragma} = 1;
185
# disable/enable this pragma before/after compile-time requires
186
on_require \&teardown, \&setup;
189
if (new_scope($class)) {
193
my $scope_id = scope();
210
196
=head1 DESCRIPTION
220
206
use Devel::Pragma qw(:all);
224
Until perl change #33311, which isn't currently available in any stable
225
perl release, values set in %^H are visible in files compiled by C<use>, C<require> and C<do FILE>.
226
This makes pragmas leak from the scope in which they're meant to be enabled into scopes in which
227
they're not. C<my_hints> fixes that by making %^H lexically scoped i.e. it prevents %^H leaking
228
across file boundaries.
230
C<my_hints> installs versions of perl's C<require> and C<do FILE> builtins in the
231
currently-compiling scope which clear %^H before they execute and restore its values afterwards.
232
Thus it can be thought of a lexically-scoped backport of change #33311.
234
Note that C<my_hints> also sets the $^H bit that "localizes" (or in this case "lexicalizes") %^H.
236
The return value is a reference to %^H.
210
This function enables the scoped behaviour of the hints hash (C<%^H>) and then returns a reference to it.
212
The hints hash is a compile-time global variable (which is also available at runtime in recent perls) that
213
can be used to implement lexically-scoped features and pragmas. This function provides a convenient
214
way to access this hash without the need to perform the bit-twiddling that enables it on older perls.
215
In addition, this module loads L<Lexical::SealRequireHints>, which implements bugfixes
216
that are required for the correct operation of the hints hash on older perls (< 5.12.0).
218
Typically, C<hints> should be called from a pragma's C<import> (and optionally C<unimport>) method:
222
use Devel::Pragma qw(hints);
228
if ($hints->{MyPragma}) {
231
$hints->{MyPragma} = ...;
264
263
A warning is issued if C<scope> (or C<new_scope>) is called in a context in which it doesn't make sense i.e. if the
265
264
scoped behaviour of C<%^H> has not been enabled - either by explicitly modifying C<$^H>, or by calling
266
L<"my_hints"> or L<"on_require">.
265
L<"hints"> or L<"on_require">.
363
362
typically via C<use> statements.
365
364
C<on_require> takes two callbacks (i.e. anonymous subs or sub references), each of which is called
366
with a reference to C<%^H>. The first callback is called before C<require>, and the second is called
367
after C<require> has loaded and compiled its file. %^H is cleared before C<require> and restored
368
afterwards. (If the file has already been loaded, or the required value is a vstring rather than
369
a file name, then both the callbacks and the clearance/restoration of C<%^H> are skipped.)
365
with a reference to a copy of C<%^H>. The first callback is called before C<require>, and the second
366
is called after C<require> has loaded and compiled its file. If the file has already been loaded,
367
or the required value is a vstring rather than a file name, then both the callbacks are skipped.
371
369
Multiple callbacks can be registered in a given scope, and they are called in the order in which they
372
370
are registered. Callbacks are unregistered automatically at the end of the (compilation of) the scope
373
371
in which they are registered.
375
C<on_require> callbacks can be used to disable/re-enable OP check hooks installed via
376
L<B::Hooks::OP::Check|B::Hooks::OP::Check> i.e. they can be used to make check hooks
381
use Devel::Pragma qw(:all);
384
my ($class, %args) = @_;
385
my $hints = my_hints;
387
unless ($hints->{MyPragma}) { # top-level
388
$hints->{MyPragma} = 1;
389
on_scope_end \&teardown;
390
on_require \&teardown, \&setup;
395
C<on_require> callbacks can also be used to rollback/restore lexical side-effects i.e. lexical features
396
whose side-effects extend beyond C<%^H> (like L<"my_hints">, C<on_require> implicitly renders C<%^H> lexically-scoped).
373
C<on_require> callbacks can be used to rollback/restore lexical side-effects i.e. lexical features
374
whose side-effects extend beyond C<%^H> (like L<"hints">, C<on_require> implicitly enables the scoped
375
behaviour of C<%^H>).
398
377
Fatal exceptions raised in C<on_require> callbacks are trapped and reported as warnings. If a fatal
399
378
exception is raised in the C<require> or C<do FILE> call, the post-C<require> callbacks are invoked
436
415
=head1 COPYRIGHT AND LICENSE
438
Copyright (C) 2008-2010 by chocolateboy
417
Copyright (C) 2008-2013 by chocolateboy
440
419
This library is free software; you can redistribute it and/or modify
441
420
it under the same terms as Perl itself, either Perl version 5.8.1 or,
added
removed
lib/Devel/Pragma.pm
