« back to all changes in this revision
Viewing changes to lib/Devel/Pragma.pm
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Package Import Robot
- Author(s): Stig Sandbeck Mathisen
- Date: 2012-04-22 00:28:54 UTC
- Revision ID: package-import@ubuntu.com-20120422002854-88zt34apr9nwlh8u
Tags: upstream-0.54
Import upstream version 0.54
- files added:
- lib
- lib/Devel
- t
added
removed
lib/Devel/Pragma.pm
1
package Devel::Pragma;
2
3
use 5.008;
4
5
use strict;
6
use warnings;
7
8
our $VERSION = '0.54';
9
10
use B::Hooks::EndOfScope;
11
use B::Hooks::OP::Annotation;
12
use B::Hooks::OP::Check;
13
use Carp qw(carp croak);
14
use Scalar::Util;
15
use XSLoader;
16
17
use base qw(Exporter);
18
19
our @EXPORT_OK = qw(my_hints new_scope ccstash scope fqname on_require);
20
our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
21
22
my $REQUIRE_KEY = 0;
23
24
XSLoader::load(__PACKAGE__, $VERSION);
25
26
# return a reference to the hints hash
27
sub my_hints() {
28
# set HINT_LOCALIZE_HH (0x20000)
29
$^H |= 0x20000;
30
my $hints = \%^H;
31
32
unless ($hints->{'Devel::Pragma'}) {
33
$hints->{'Devel::Pragma'} = 1;
34
xs_enter();
35
on_scope_end \&xs_leave;
36
}
37
38
return $hints;
39
}
40
41
# make sure the "enable lexically-scoped %^H" flag is set (on by default in 5.10)
42
sub check_hints() {
43
unless ($^H & 0x20000) {
44
carp('Devel::Pragma: unexpected $^H (HINT_LOCALIZE_HH bit not set) - setting it now, but results may be unreliable');
45
}
46
return my_hints; # create it if it doesn't exist - in some perls, it starts out NULL
47
}
48
49
# return a unique integer ID for the current scope
50
sub scope() {
51
check_hints;
52
xs_scope();
53
}
54
55
# return a boolean indicating whether this is the first time "use MyPragma" has been called in this scope
56
sub new_scope(;$) {
57
my $caller = shift || caller;
58
my $hints = check_hints();
59
60
# 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
62
# is called)
63
#
64
# we don't need to stack/unstack it in %^H as %^H itself takes care of that
65
# note: we need to call this *after* %^H is referenced (and possibly autovivified) above
66
#
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
69
# current scope ID), then we're augmenting the current scope; otherwise we're in a new scope - i.e.
70
# a nested or outer scope that didn't previously "use MyPragma"
71
72
my $current_scope = scope();
73
my $id = "Devel::Pragma::Scope($caller)";
74
my $old_scope = exists($hints->{$id}) ? $hints->{$id} : 0;
75
my $new_scope; # is this a scope in which new_scope has not previously been called?
76
77
if ($current_scope == $old_scope) {
78
$new_scope = 0;
79
} else {
80
$hints->{$id} = $current_scope;
81
$new_scope = 1;
82
}
83
84
return $new_scope;
85
}
86
87
# given a short name (e.g. "foo"), expand it into a fully-qualified name with the caller's package prefixed
88
# e.g. "main::foo"
89
#
90
# if the name is already fully-qualified, return it unchanged
91
sub fqname ($;$) {
92
my $name = shift;
93
my ($package, $subname);
94
95
$name =~ s{'}{::}g;
96
97
if ($name =~ /::/) {
98
($package, $subname) = $name =~ m{^(.+)::(\w+)$};
99
} else {
100
my $caller = @_ ? shift : ccstash();
101
($package, $subname) = ($caller, $name);
102
}
103
104
return wantarray ? ($package, $subname) : "$package\::$subname";
105
}
106
107
# helper function: return true if $ref ISA $class - works with non-references, unblessed references and objects
108
sub _isa($$) {
109
my ($ref, $class) = @_;
110
return Scalar::Util::blessed($ref) ? $ref->isa($class) : ref($ref) eq $class;
111
}
112
113
# run registered callbacks before performing a compile-time require or do FILE
114
sub _pre_require($) {
115
_callback(0, shift);
116
}
117
118
# run registered callbacks after performing a compile-time require or do FILE
119
sub _post_require($) {
120
local $@; # if there was an exception on require, make sure we don't clobber it
121
_callback(1, shift)
122
}
123
124
# common code for pre- and post-require hooks
125
sub _callback($) {
126
my ($index, $hints) = @_;
127
128
if (my $hooks = $hints->{'Devel::Pragma(Hooks)'}) {
129
for my $key (sort(keys(%$hooks))) {
130
eval { $hooks->{$key}->[$index]->($hints) };
131
132
if ($@) {
133
my $stage = $index == 0 ? 'pre' : 'post';
134
carp __PACKAGE__ . ": exception in $stage-require callback: $@";
135
}
136
}
137
}
138
}
139
140
# register pre- and/or post-require hooks
141
# these are only called if the require occurs at compile-time
142
sub on_require($$) {
143
my $hints = my_hints();
144
145
for my $index (0 .. 1) {
146
my $arg = $_[$index];
147
my $ref = defined($arg) ? ref($arg) : '<undef>';
148
149
croak(sprintf('%s: invalid arg %d; expected CODE, got %s', __PACKAGE__, $index + 1, $ref))
150
unless ($arg and _isa($arg, 'CODE'));
151
}
152
153
$hints->{'Devel::Pragma(Hooks)'}->{++$REQUIRE_KEY} = [ @_ ];
154
155
# return $REQUIRE_KEY;
156
return;
157
}
158
159
# sub on_require_remove($) {
160
# my $index = shift;
161
# my $hints = my_hints();
162
# my $hooks = $hints->{'Devel::Pragma(Hooks)'};
163
#
164
# croak(sprintf('%s: attempt to remove a non-existent require hook', __PACKAGE__))
165
# unless ($hooks->{$index});
166
#
167
# delete $hooks->{$index};
168
# }
169
170
# make sure "enable lexically-scoped %^H" is set in older perls, and export the requested functions
171
sub import {
172
my $class = shift;
173
$^H |= 0x20000; # set HINT_LOCALIZE_HH (0x20000)
174
$class->export_to_level(1, undef, @_);
175
}
176
177
1;
178
179
__END__
180
181
=head1 NAME
182
183
Devel::Pragma - helper functions for developers of lexical pragmas
184
185
=head1 SYNOPSIS
186
187
package MyPragma;
188
189
use Devel::Pragma qw(:all);
190
191
sub import {
192
my ($class, %options) = @_;
193
my $hints = my_hints; # lexically-scoped %^H
194
my $caller = ccstash(); # currently-compiling stash
195
196
unless ($hints->{MyPragma}) { # top-level
197
$hints->{MyPragma} = 1;
198
199
# disable/enable this pragma before/after compile-time requires
200
on_require \&teardown, \&setup;
201
}
202
203
if (new_scope($class)) {
204
...
205
}
206
207
my $scope_id = scope();
208
}
209
210
=head1 DESCRIPTION
211
212
This module provides helper functions for developers of lexical pragmas. These can be used both in older versions of
213
perl (from 5.8.1), which have limited support for lexical pragmas, and in the most recent versions, which have improved
214
support.
215
216
=head1 EXPORTS
217
218
C<Devel::Pragma> exports the following functions on demand. They can all be imported at once by using the C<:all> tag. e.g.
219
220
use Devel::Pragma qw(:all);
221
222
=head2 my_hints
223
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.
229
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.
233
234
Note that C<my_hints> also sets the $^H bit that "localizes" (or in this case "lexicalizes") %^H.
235
236
The return value is a reference to %^H.
237
238
=head2 new_scope
239
240
This function returns true if the currently-compiling scope differs from the scope being compiled the last
241
time C<new_scope> was called. Subsequent calls will return false while the same scope is being compiled.
242
243
C<new_scope> takes an optional parameter that is used to uniquely identify its caller. This should usually be
244
supplied as the pragma's class name unless C<new_scope> is called by a module that is not intended
245
to be subclassed. e.g.
246
247
package MyPragma;
248
249
sub import {
250
my ($class, %options) = @_;
251
252
if (new_scope($class)) {
253
...
254
}
255
}
256
257
If not supplied, the identifier defaults to the name of the calling package.
258
259
=head2 scope
260
261
This returns an integer that uniquely identifies the currently-compiling scope. It can be used to
262
distinguish or compare scopes.
263
264
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
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">.
267
268
=head2 ccstash
269
270
This returns the name of the currently-compiling stash. It can be used as a replacement for the scalar form of
271
C<caller> to provide the name of the package in which C<use MyPragma> is called. Unlike C<caller>, it
272
returns the same value regardless of the number of intervening calls before C<MyPragma::import>
273
is reached.
274
275
e.g. given a pragma:
276
277
package MySuperPragma;
278
279
use Devel::Hints qw(ccstash);
280
281
sub import {
282
my ($class, %options) = @_;
283
my $caller = ccstash();
284
285
no strict 'refs';
286
287
*{"$caller\::whatever"} = ... ;
288
}
289
290
and a subclass:
291
292
package MySubPragma
293
294
use base qw(MySuperPragma);
295
296
sub import {
297
my ($class, %options) = @_;
298
$class->SUPER::import(...);
299
}
300
301
and a script that uses the subclass:
302
303
#!/usr/bin/env perl
304
305
use MySubPragma;
306
307
- the C<ccstash> call in C<MySuperPragma::import> returns the name of the package that's being compiled when
308
the call to C<MySuperPragma::import> (via C<MySubPragma::import>) takes place i.e. C<main> in this case.
309
310
=head2 fqname
311
312
Given a subroutine name, usually supplied by the caller of the pragma's import method, this function returns
313
the name in package-qualified form. In addition, old-style C<'> separators are converted to new-style C<::>.
314
315
If the name contains no separators, then the optional calling package is prepended. If not supplied, the caller
316
defaults to the value returned by L<"ccstash">. If the name is already package-qualified,
317
then it is returned unchanged.
318
319
In list context, C<fqname> returns the package and unqualified subroutine name (e.g. 'main' and 'foo'), and in scalar
320
context it returns the package and sub name joined by '::' (e.g. 'main::foo').
321
322
e.g.
323
324
package MyPragma;
325
326
sub import {
327
my ($class, @names) = @_;
328
329
for my $name (@names) {
330
my $fqname = fqname($name);
331
say $fqname;
332
}
333
}
334
335
package MySubPragma;
336
337
use base qw(MyPragma);
338
339
sub import { shift->SUPER::import(@_) }
340
341
#!/usr/bin/env perl
342
343
use MyPragma qw(foo Foo::Bar::baz Foo'Bar'baz Foo'Bar::baz);
344
345
{
346
package Some::Other::Package;
347
348
use MySubPragma qw(quux);
349
}
350
351
prints:
352
353
main::foo
354
Foo::Bar::baz
355
Foo::Bar::baz
356
Foo::Bar::baz
357
Some::Other::Package::quux
358
359
=head2 on_require
360
361
This function allows pragmas to register pre- and post-C<require> (and C<do FILE>) callbacks.
362
These are called whenever C<require> or C<do FILE> OPs are executed at compile-time,
363
typically via C<use> statements.
364
365
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.)
370
371
Multiple callbacks can be registered in a given scope, and they are called in the order in which they
372
are registered. Callbacks are unregistered automatically at the end of the (compilation of) the scope
373
in which they are registered.
374
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
377
lexically-scoped.
378
379
package MyPragma;
380
381
use Devel::Pragma qw(:all);
382
383
sub import {
384
my ($class, %args) = @_;
385
my $hints = my_hints;
386
387
unless ($hints->{MyPragma}) { # top-level
388
$hints->{MyPragma} = 1;
389
on_scope_end \&teardown;
390
on_require \&teardown, \&setup;
391
setup;
392
}
393
}
394
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).
397
398
Fatal exceptions raised in C<on_require> callbacks are trapped and reported as warnings. If a fatal
399
exception is raised in the C<require> or C<do FILE> call, the post-C<require> callbacks are invoked
400
before that exception is thrown.
401
402
=head1 VERSION
403
404
0.54
405
406
=head1 SEE ALSO
407
408
=over
409
410
=item * L<pragma|pragma>
411
412
=item * L<perlpragma|perlpragma>
413
414
=item * L<perlvar|perlvar>
415
416
=item * L<B::Hooks::EndOfScope|B::Hooks::EndOfScope>
417
418
=item * L<B::Hooks::OP::Check|B::Hooks::OP::Check>
419
420
=item * L<B::Hooks::OP::PPAddr|B::Hooks::OP::PPAddr>
421
422
=item * L<B::Hooks::OP::Annotation|B::Hooks::OP::Annotation>
423
424
=item * L<Devel::Hints|Devel::Hints>
425
426
=item * L<Lexical::SealRequireHints|Lexical::SealRequireHints>
427
428
=item * http://tinyurl.com/45pwzo
429
430
=back
431
432
=head1 AUTHOR
433
434
chocolateboy <chocolate@cpan.org>
435
436
=head1 COPYRIGHT AND LICENSE
437
438
Copyright (C) 2008-2010 by chocolateboy
439
440
This library is free software; you can redistribute it and/or modify
441
it under the same terms as Perl itself, either Perl version 5.8.1 or,
442
at your option, any later version of Perl 5 you may have available.
443
444
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1