From f3aa04c29a85dd63d563ae8e27316ff34501ccd5 Mon Sep 17 00:00:00 2001 From: Gurusamy Sarathy Date: Fri, 11 Jun 1999 20:41:51 +0000 Subject: [PATCH] implement C p4raw-id: //depot/perl@3534 --- MANIFEST | 1 + lib/caller.pm | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ perl.h | 1 + pod/perldelta.pod | 5 +++++ pod/perlfunc.pod | 8 +++++--- pp_ctl.c | 7 ++++++- 6 files changed, 79 insertions(+), 4 deletions(-) create mode 100644 lib/caller.pm diff --git a/MANIFEST b/MANIFEST index 8ec17f5..5aaf7ae 100644 --- 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 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. + +=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 +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 --- 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 --- 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 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 --- 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. In such a case additional elements $evaltext and @@ -522,7 +522,9 @@ C or C statement, $evaltext contains the text of the C statement. In particular, for a C statement, $filename is C<"(eval)">, but $evaltext is undefined. (Note also that each C statement creates a C frame inside an C) -frame. +frame. C<$hints> contains pragmatic hints that the caller was +compiled with. It currently only reflects the hint corresponding to +C. 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 --- 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; } -- 2.7.4