Commit | Line | Data |
f3aa04c2 |
1 | package caller; |
2 | use vars qw($VERSION); |
3 | $VERSION = "1.0"; |
4 | |
5 | =head1 NAME |
6 | |
7 | caller - inherit pragmatic attributes from the context of the caller |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | use caller qw(encoding); |
12 | |
13 | =head1 DESCRIPTION |
14 | |
15 | This pragma allows a module to inherit some attributes from the |
16 | context which loaded it. |
17 | |
18 | Inheriting attributes takes place at compile time; this means |
19 | only attributes that are visible in the calling context at compile |
20 | time will be propagated. |
21 | |
22 | Currently, the only supported attribute is C<encoding>. |
23 | |
24 | =over |
25 | |
26 | =item encoding |
27 | |
28 | Indicates that the character set encoding of the caller's context |
29 | must be inherited. This can be used to inherit the C<use utf8> |
30 | setting in the calling context. |
31 | |
32 | =back |
33 | |
34 | =cut |
35 | |
22b491d3 |
36 | my %bitmask = ( |
f3aa04c2 |
37 | # only HINT_UTF8 supported for now |
38 | encoding => 0x8 |
39 | ); |
40 | |
41 | sub bits { |
42 | my $bits = 0; |
43 | for my $s (@_) { $bits |= $bitmask{$s} || 0; }; |
44 | $bits; |
45 | } |
46 | |
47 | sub import { |
48 | shift; |
49 | my @cxt = caller(3); |
50 | if (@cxt and $cxt[7]) { # was our parent require-d? |
22b491d3 |
51 | $^H |= bits(@_) & $cxt[8]; |
f3aa04c2 |
52 | } |
53 | } |
54 | |
55 | sub unimport { |
56 | # noop currently |
57 | } |
58 | |
59 | 1; |