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