implement C<use caller 'encoding'>

p4raw-id: //depot/perl@3534

1 files changed, 61 insertions, 0 deletions

diff --git a/lib/caller.pm b/lib/caller.pm
new file mode 100644
index 0000000000..70292122d7
--- /dev/null
+++ b/lib/caller.pm
@@ -0,0 +1,61 @@
+package caller;
+use vars qw($VERSION);
+$VERSION = "1.0";
+
+=head1 NAME
+
+caller - inherit pragmatic attributes from the context of the caller
+
+=head1 SYNOPSIS
+
+        use caller qw(encoding);
+
+=head1 DESCRIPTION
+
+This pragma allows a module to inherit some attributes from the
+context which loaded it.
+
+Inheriting attributes takes place at compile time; this means
+only attributes that are visible in the calling context at compile
+time will be propagated.
+
+Currently, the only supported attribute is C<encoding>.
+
+=over
+
+=item encoding
+
+Indicates that the character set encoding of the caller's context
+must be inherited.  This can be used to inherit the C<use utf8>
+setting in the calling context.
+
+=back
+
+=cut
+
+my %bits = (
+    # only HINT_UTF8 supported for now
+    encoding => 0x8
+);
+
+sub bits {
+    my $bits = 0;
+    for my $s (@_) { $bits |= $bitmask{$s} || 0; };
+    $bits;
+}
+
+sub import {
+    shift;
+    my @cxt = caller(3);
+    if (@cxt and $cxt[7]) {	# was our parent require-d?
+	#warn "hints was $^H\n";
+	$^H |= bits(@_) | $cxt[8];
+	#warn "hints now $^H\n";
+    }
+}
+
+sub unimport {
+    # noop currently
+}
+
+1;