From: Vincent Pit Date: Sun, 16 Sep 2012 22:19:33 +0000 (+0200) Subject: Implement context_info() X-Git-Tag: v0.20~1 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=commitdiff_plain;h=aadd0157199345b7e2570fa1d45d998479691b5e Implement context_info() --- diff --git a/MANIFEST b/MANIFEST index cb425fd..ace04e6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -13,6 +13,7 @@ t/00-load.t t/01-import.t t/05-words.t t/06-want_at.t +t/07-context_info.t t/11-reap-level.t t/12-reap-block.t t/13-reap-ctl.t diff --git a/Upper.xs b/Upper.xs index 3de19a9..ca702be 100644 --- a/Upper.xs +++ b/Upper.xs @@ -80,6 +80,13 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define newSV_type(T) su_newSV_type(aTHX_ (T)) #endif +#ifdef newSVpvn_flags +# define su_newmortal_pvn(S, L) newSVpvn_flags((S), (L), SVs_TEMP) +#else +# define su_newmortal_pvn(S, L) sv_2mortal(newSVpvn((S), (L))) +#endif +#define su_newmortal_pvs(S) su_newmortal_pvn((S), sizeof(S)-1) + #ifndef SvPV_const # define SvPV_const(S, L) SvPV(S, L) #endif @@ -125,14 +132,55 @@ STATIC SV *su_newSV_type(pTHX_ svtype t) { # define CxHASARGS(C) ((C)->blk_sub.hasargs) #endif +#ifndef CxGIMME +# ifdef G_WANT +# define CxGIMME(C) ((C)->blk_gimme & G_WANT) +# else +# define CxGIMME(C) ((C)->blk_gimme) +# endif +#endif + +#ifndef CxOLD_OP_TYPE +# define CxOLD_OP_TYPE(C) (C)->blk_eval.old_op_type +#endif + +#ifndef OutCopFILE +# define OutCopFILE(C) CopFILE(C) +#endif + +#ifndef OutCopFILE_len +# define OutCopFILE_len(C) strlen(OutCopFILE(C)) +#endif + +#ifndef CopHINTS_get +# define CopHINTS_get(C) ((I32) (C)->op_private & HINT_PRIVATE_MASK) +#endif + +#ifndef CopHINTHASH_get +# define CopHINTHASH_get(C) (C)->cop_hints_hash +#endif + +#ifndef cophh_2hv +# define COPHH struct refcounted_he +# define cophh_2hv(H, F) Perl_refcounted_he_chain_2hv(aTHX_ (H)) +#endif + #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif +#ifndef HvNAMELEN +# define HvNAMELEN(H) strlen(HvNAME(H)) +#endif + #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(A, B, C, D) gv_fetchpv((A), (C), (D)) #endif +#ifndef hv_fetchs +# define hv_fetchs(H, K, L) hv_fetch((H), (K), sizeof(K)-1, (L)) +#endif + #ifndef OP_GIMME_REVERSE STATIC U8 su_op_gimme_reverse(U8 gimme) { switch (gimme) { @@ -2075,6 +2123,48 @@ STATIC I32 su_context_normalize_down(pTHX_ I32 cxix) { #define su_context_here() su_context_normalize_up(su_context_skip_db(cxstack_ix)) +STATIC I32 su_context_gimme(pTHX_ I32 cxix) { +#define su_context_gimme(C) su_context_gimme(aTHX_ (C)) + I32 i; + + for (i = cxix; i >= 0; --i) { + PERL_CONTEXT *cx = cxstack + i; + + switch (CxTYPE(cx)) { + /* gimme is always G_ARRAY for loop contexts. */ +#if SU_HAS_PERL(5, 11, 0) + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LAZYIV: +#else + case CXt_LOOP: +#endif + case CXt_SUBST: { + const COP *cop = cx->blk_oldcop; + if (cop && cop->op_sibling) { + switch (cop->op_sibling->op_flags & OPf_WANT) { + case OPf_WANT_VOID: + return G_VOID; + case OPf_WANT_SCALAR: + return G_SCALAR; + case OPf_WANT_LIST: + return G_ARRAY; + default: + break; + } + } + break; + } + default: + return CxGIMME(cx); + break; + } + } + + return G_VOID; +} + /* --- Interpreter setup/teardown ------------------------------------------ */ STATIC void su_teardown(pTHX_ void *param) { @@ -2171,6 +2261,12 @@ default_cx: \ } \ } STMT_END +#if SU_HAS_PERL(5, 10, 0) +# define SU_INFO_COUNT 11 +#else +# define SU_INFO_COUNT 10 +#endif + XS(XS_Scope__Upper_unwind); /* prototype to pass -Wmissing-prototypes */ XS(XS_Scope__Upper_unwind) { @@ -2463,6 +2559,148 @@ PPCODE: } XSRETURN_UNDEF; +void +context_info(...) +PROTOTYPE: ;$ +PREINIT: + I32 cxix; + const PERL_CONTEXT *cx, *dbcx; + COP *cop; +PPCODE: + SU_GET_CONTEXT(0, 0, su_context_skip_db(cxstack_ix)); + cxix = su_context_normalize_up(cxix); + cx = cxstack + cxix; + dbcx = cx; + if (PL_DBsub && cxix && (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)) { + I32 i = su_context_skip_db(cxix - 1) + 1;; + if (i < cxix && CxTYPE(cxstack + i) == CXt_SUB) + cx = cxstack + i; + } + cop = cx->blk_oldcop; + EXTEND(SP, SU_INFO_COUNT); + /* stash (0) */ + { + HV *stash = CopSTASH(cop); + if (stash) + PUSHs(su_newmortal_pvn(HvNAME(stash), HvNAMELEN(stash))); + else + PUSHs(&PL_sv_undef); + } + /* file (1) */ + PUSHs(su_newmortal_pvn(OutCopFILE(cop), OutCopFILE_len(cop))); + /* line (2) */ + mPUSHi(CopLINE(cop)); + /* subroutine (3) and has_args (4) */ + switch (CxTYPE(cx)) { + case CXt_SUB: + case CXt_FORMAT: { + GV *cvgv = CvGV(dbcx->blk_sub.cv); + if (cvgv && isGV(cvgv)) { + SV *sv = sv_newmortal(); + gv_efullname3(sv, cvgv, NULL); + PUSHs(sv); + } else { + PUSHs(su_newmortal_pvs("(unknown)")); + } + if (CxHASARGS(cx)) + PUSHs(&PL_sv_yes); + else + PUSHs(&PL_sv_no); + break; + } + case CXt_EVAL: + PUSHs(su_newmortal_pvs("(eval)")); + mPUSHi(0); + break; + default: + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } + /* gimme (5) */ + switch (su_context_gimme(cxix)) { + case G_ARRAY: + PUSHs(&PL_sv_yes); + break; + case G_SCALAR: + PUSHs(&PL_sv_no); + break; + default: /* G_VOID */ + PUSHs(&PL_sv_undef); + break; + } + /* eval text (6) and is_require (7) */ + switch (CxTYPE(cx)) { + case CXt_EVAL: + if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { + /* eval STRING */ +#if SU_HAS_PERL(5, 17, 4) + PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text), + SvCUR(cx->blk_eval.cur_text)-2, + SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP)); +#else + PUSHs(cx->blk_eval.cur_text); +#endif + PUSHs(&PL_sv_no); + break; + } else if (cx->blk_eval.old_namesv) { + /* require */ + PUSHs(sv_mortalcopy(cx->blk_eval.old_namesv)); + PUSHs(&PL_sv_yes); + break; + } + /* FALLTHROUGH */ + default: + /* Anything else including eval BLOCK */ + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + break; + } + /* hints (8) */ + mPUSHi(CopHINTS_get(cop)); + /* warnings (9) */ + { + SV *mask = NULL; +#if SU_HAS_PERL(5, 9, 4) + STRLEN *old_warnings = cop->cop_warnings; +#else + SV *old_warnings = cop->cop_warnings; +#endif + if (old_warnings == pWARN_NONE || + (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) { + mask = su_newmortal_pvn(WARN_NONEstring, WARNsize); + } else if (old_warnings == pWARN_ALL || + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { + HV *bits = get_hv("warnings::Bits", 0); + if (bits) { + SV **bits_all = hv_fetchs(bits, "all", FALSE); + if (bits_all) + mask = sv_mortalcopy(*bits_all); + } + if (!mask) + mask = su_newmortal_pvn(WARN_ALLstring, WARNsize); + } else { +#if SU_HAS_PERL(5, 9, 4) + mask = su_newmortal_pvn((char *) (old_warnings + 1), old_warnings[0]); +#else + mask = sv_mortalcopy(old_warnings); +#endif + } + PUSHs(mask); + } +#if SU_HAS_PERL(5, 10, 0) + /* hints hash (10) */ + { + COPHH *hints_hash = CopHINTHASH_get(cop); + if (hints_hash) { + SV *rhv = sv_2mortal(newRV_noinc((SV *) cophh_2hv(hints_hash, 0))); + PUSHs(rhv); + } else { + PUSHs(&PL_sv_undef); + } + } +#endif + XSRETURN(SU_INFO_COUNT); + void reap(SV *hook, ...) PROTOTYPE: &;$ diff --git a/lib/Scope/Upper.pm b/lib/Scope/Upper.pm index 6ca286c..e36cbca 100644 --- a/lib/Scope/Upper.pm +++ b/lib/Scope/Upper.pm @@ -170,7 +170,11 @@ localize variables, array/hash values or deletions of elements in higher context =item * -return values immediately to an upper level with L, L and L, and know which context was in use then with L ; +return values immediately to an upper level with L, L and L ; + +=item * + +gather information about an upper context with L and L ; =item * @@ -339,6 +343,7 @@ Hence you can use it to return values from a C or a C block : } @things; Like for L, the upper context isn't coerced onto C<@values>. +You can use the fifth value returned by L to handle context coercion. =head2 C @@ -348,6 +353,8 @@ Like for L, the upper context isn't coerced onto C<@values>. Immediately returns C<@values> from the current block, whatever it may be (besides a C substitution context). C is actually a synonym for C, while C is a synonym for C. +Like for L, you can use the fifth value returned by L to handle context coercion. + =head2 C my $want = want_at; @@ -365,6 +372,65 @@ It can be used to revise the example showed in L : will rightfully set C<$num> to C<26>. +=head2 C + + my ($package, $filename, $line, $subroutine, $hasargs, + $wantarray, $evaltext, $is_require, $hints, $bitmask, + $hinthash) = context_info $context; + +Gives information about the context denoted by C<$context>, akin to what L provides but not limited only to subroutine, eval and format contexts. +When C<$context> is omitted, it defaults to the current context. + +The values returned are, in order : + +=over 4 + +=item * + +I<(index 0)> : the namespace in use when the context was created ; + +=item * + +I<(index 1)> : the name of the file at the point where the context was created ; + +=item * + +I<(index 2)> : the line number at the point where the context was created ; + +=item * + +I<(index 3)> : the name of the subroutine called for this context, or C if this is not a subroutine context ; + +=item * + +I<(index 4)> : a boolean indicating whether a new instance of C<@_> was set up for this context, or C if this is not a subroutine context ; + +=item * + +I<(index 5)> : the context (in the sense of L) in which the context (in our sense) is executed ; + +=item * + +I<(index 6)> : the contents of the string being compiled for this context, or C if this is not an eval context ; + +=item * + +I<(index 7)> : a boolean indicating whether this eval context was created by C, or C if this is not an eval context ; + +=item * + +I<(index 8)> : the value of the lexical hints in use when the context was created ; + +=item * + +I<(index 9)> : a bit string representing the warnings in use when the context was created ; + +=item * + +I<(index 10)> : a reference to the lexical hints hash in use when the context was created (only on perl 5.10 or greater). + +=back + =head2 C my @ret = uplevel { ...; return @ret }; @@ -623,7 +689,7 @@ Where L, L and L act depending on t # $cxt = SCOPE(4), UP SUB UP SUB = UP SUB EVAL = UP CALLER(2) = TOP ... -Where L, L, L and L point to depending on the C<$cxt>: +Where L, L, L, L and L point to depending on the C<$cxt>: sub { eval { @@ -646,7 +712,7 @@ Where L, L, L and L point to depending on t =head1 EXPORT -The functions L, L, L, L, L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. +The functions L, L, L, L, L, L, L, L, L and L are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>. The constant L is also only exported on request, individually or by the tags C<':consts'> and C<':all'>. @@ -662,7 +728,7 @@ our %EXPORT_TAGS = ( reap localize localize_elem localize_delete unwind yield leave - want_at + want_at context_info uplevel uid validate_uid > ], diff --git a/t/01-import.t b/t/01-import.t index 2474705..700f9b3 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2 * 19; +use Test::More tests => 2 * 20; require Scope::Upper; @@ -16,6 +16,7 @@ my %syms = ( yield => undef, leave => undef, want_at => ';$', + context_info => ';$', uplevel => '&@', uid => ';$', validate_uid => '$', diff --git a/t/07-context_info.t b/t/07-context_info.t new file mode 100644 index 0000000..aab24fb --- /dev/null +++ b/t/07-context_info.t @@ -0,0 +1,154 @@ +#!perl -T + +my $exp0 = ::expected('block', 0, undef); + +use strict; +use warnings; + +# We're using Test::Leaner here because Test::More loads overload, which itself +# uses warning::register, which may cause the "all warnings on" bitmask to +# change ; and that doesn't fit well with how we're testing things. + +use lib 't/lib'; +use Test::Leaner tests => 19 + 6; + +use Scope::Upper qw; + +sub expected { + my ($type, $line, $want) = @_; + + my $top; + + my @caller = caller 1; + my @here = caller 0; + unless (@caller) { + @caller = @here; + $top++; + } + + my $pkg = $here[0]; + my ($file, $eval, $require, $hints, $warnings, $hinthash) + = @caller[1, 6, 7, 8, 9, 10]; + + $line = $caller[2] unless defined $line; + + my ($sub, $hasargs); + if ($type eq 'sub' or $type eq 'eval' or $type eq 'format') { + $sub = $caller[3]; + $hasargs = $caller[4]; + $want = $caller[5]; + $want = '' if defined $want and not $want; + } + + $want = "$]" < 5.015_001 ? '' : undef if $top; + + my @exp = ( + $pkg, + $file, + $line, + $sub, + $hasargs, + $want, + $eval, + $require, + $hints, + $warnings, + ); + push @exp, $hinthash if "$]" >= 5.010; + + return \@exp; +} + +sub setup () { + my $pkg = caller; + + for my $sub (qw) { + no strict 'refs'; + *{"${pkg}::$sub"} = \&{"main::$sub"}; + } +} + +is_deeply [ context_info ], $exp0, 'main : context_info'; +is_deeply [ context_info(HERE) ], $exp0, 'main : context_info HERE'; +is_deeply [ context_info(UP) ], $exp0, 'main : context_info UP'; +is_deeply [ context_info(-1) ], $exp0, 'main : context_info -1'; + +package Scope::Upper::TestPkg::A; BEGIN { ::setup } +my @a = sub { + my $exp1 = expected('sub', undef); + is_deeply [ context_info ], $exp1, 'sub0 : context_info'; + package Scope::Upper::TestPkg::B; BEGIN { ::setup } + { + my $exp2 = expected('block', __LINE__, 1); + is_deeply [ context_info ], $exp2, 'sub : context_info'; + is_deeply [ context_info(UP) ], $exp1, 'sub : context_info UP'; + package Scope::Upper::TestPkg::C; BEGIN { ::setup } + for (1) { + my $exp3 = expected('loop', __LINE__ - 1, undef); + is_deeply [ context_info ], $exp3, 'for : context_info'; + is_deeply [ context_info(UP) ], $exp2, 'for : context_info UP'; + is_deeply [ context_info(UP UP) ], $exp1, 'for : context_info UP UP'; + } + package Scope::Upper::TestPkg::D; BEGIN { ::setup } + my $eval_line = __LINE__+1; + eval <<'CODE'; + my $exp4 = expected('eval', $eval_line); + is_deeply [ context_info ], $exp4, 'eval string : context_info'; + is_deeply [ context_info(UP) ], $exp2, 'eval string : context_info UP'; + is_deeply [ context_info(UP UP) ], $exp1, 'eval string : context_info UP UP'; +CODE + die $@ if $@; + package Scope::Upper::TestPkg::E; BEGIN { ::setup } + my $x = eval { + my $exp5 = expected('eval', __LINE__ - 1); + package Scope::Upper::TestPkg::F; BEGIN { ::setup } + do { + my $exp6 = expected('block', __LINE__ - 1, undef); + is_deeply [ context_info ], $exp6, 'do : context_info'; + is_deeply [ context_info(UP) ], $exp5, 'do : context_info UP'; + is_deeply [ context_info(UP UP) ], $exp2, 'do : context_info UP UP'; + }; + is_deeply [ context_info ], $exp5, 'eval : context_info'; + is_deeply [ context_info(UP) ], $exp2, 'eval : context_info UP'; + is_deeply [ context_info(UP UP) ], $exp1, 'eval : context_info UP UP'; + }; + } +}->(1); + +package main; + +sub first { + do { + second(@_); + } +} + +my $fourth; + +sub second { + my $x = eval { + my @y = $fourth->(); + }; + die $@ if $@; +} + +$fourth = sub { + my $z = do { + my $dummy; + eval q[ + call(@_); + ]; + die $@ if $@; + } +}; + +sub call { + for my $depth (0 .. 5) { + my @got = context_info(CALLER $depth); + my @exp = caller $depth; + defined and not $_ and $_ = '' for $exp[5]; + is_deeply \@got, \@exp, "context_info vs caller $depth"; + } +} + +first();