Commit | Line | Data |
---|---|---|
f3aa04c2 GS |
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 GS |
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 GS |
52 | } |
53 | } | |
54 | ||
55 | sub unimport { | |
56 | # noop currently | |
57 | } | |
58 | ||
59 | 1; |