implement C<use caller 'encoding'>

p4raw-id: //depot/perl@3534

diff --git a/MANIFEST b/MANIFEST
index 8ec17f5..5aaf7ae 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -639,6 +639,7 @@ lib/bigint.pl               An arbitrary precision integer arithmetic package
 lib/bigrat.pl          An arbitrary precision rational arithmetic package
 lib/blib.pm            For "use blib"
 lib/cacheout.pl                Manages output filehandles when you need too many
+lib/caller.pm          Inherit pragmatic attributes from caller's context
 lib/chat2.pl            Obsolete ipc library (use Comm.pm etc instead)
 lib/complete.pl                A command completion subroutine
 lib/constant.pm                For "use constant"

diff --git a/lib/caller.pm b/lib/caller.pm
new file mode 100644 (file)
index 0000000..7029212
--- /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;

diff --git a/perl.h b/perl.h
index d8a035e..33368b1 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2286,6 +2286,7 @@ enum {            /* pass one of these to get_vtbl */
 
                                /* Note: the lowest 8 bits are reserved for
                                   stuffing into op->op_private */
+#define HINT_PRIVATE_MASK      0x000000ff
 #define HINT_INTEGER           0x00000001
 #define HINT_STRICT_REFS       0x00000002
 /* #define HINT_notused4       0x00000004 */

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 9408d32..b330e5d 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -296,6 +296,11 @@ Verify operations that access pad objects (lexicals and temporaries).
 
 =over 4
 
+=item caller
+
+Allows modules to inherit pragmatic attributes from the caller's
+context.  C<utf8> is currently the only supported attribute.
+
 =item Dumpvalue
 
 Added Dumpvalue module provides screen dumps of Perl data.

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 4043301..0ac2810 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -512,8 +512,8 @@ With EXPR, it returns some extra information that the debugger uses to
 print a stack trace.  The value of EXPR indicates how many call frames
 to go back before the current one.
 
-    ($package, $filename, $line, $subroutine,
-     $hasargs, $wantarray, $evaltext, $is_require) = caller($i);
+    ($package, $filename, $line, $subroutine, $hasargs,
+    $wantarray, $evaltext, $is_require, $hints) = caller($i);
 
 Here $subroutine may be C<"(eval)"> if the frame is not a subroutine
 call, but an C<eval>.  In such a case additional elements $evaltext and
@@ -522,7 +522,9 @@ C<require> or C<use> statement, $evaltext contains the text of the
 C<eval EXPR> statement.  In particular, for a C<eval BLOCK> statement,
 $filename is C<"(eval)">, but $evaltext is undefined.  (Note also that
 each C<use> statement creates a C<require> frame inside an C<eval EXPR>)
-frame.
+frame.  C<$hints> contains pragmatic hints that the caller was
+compiled with.  It currently only reflects the hint corresponding to
+C<use utf8>.
 
 Furthermore, when called from within the DB package, caller returns more
 detailed information: it sets the list variable C<@DB::args> to be the

diff --git a/pp_ctl.c b/pp_ctl.c
index e253b92..436498f 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1475,7 +1475,7 @@ PP(pp_caller)
 
     if (MAXARG)
        count = POPi;
-    EXTEND(SP, 6);
+    EXTEND(SP, 7);
     for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -1573,6 +1573,11 @@ PP(pp_caller)
        Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
        AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
     }
+    /* XXX only hints propagated via op_private are currently
+     * visible (others are not easily accessible, since they
+     * use the global PL_hints) */
+    PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
+                            HINT_PRIVATE_MASK)));
     RETURN;
 }