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
# 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
# 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) {
#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) {
} \
} 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) {
}
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: &;$
=item *
-return values immediately to an upper level with L</unwind>, L</yield> and L</leave>, and know which context was in use then with L</want_at> ;
+return values immediately to an upper level with L</unwind>, L</yield> and L</leave> ;
+
+=item *
+
+gather information about an upper context with L</want_at> and L</context_info> ;
=item *
} @things;
Like for L</unwind>, the upper context isn't coerced onto C<@values>.
+You can use the fifth value returned by L</context_info> to handle context coercion.
=head2 C<leave>
Immediately returns C<@values> from the current block, whatever it may be (besides a C<s///e> substitution context).
C<leave> is actually a synonym for C<unwind HERE>, while C<leave @values> is a synonym for C<yield @values, HERE>.
+Like for L</yield>, you can use the fifth value returned by L</context_info> to handle context coercion.
+
=head2 C<want_at>
my $want = want_at;
will rightfully set C<$num> to C<26>.
+=head2 C<context_info>
+
+ 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<perlfunc/caller> 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<undef> 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<undef> if this is not a subroutine context ;
+
+=item *
+
+I<(index 5)> : the context (in the sense of L<perlfunc/wantarray>) 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<undef> if this is not an eval context ;
+
+=item *
+
+I<(index 7)> : a boolean indicating whether this eval context was created by C<require>, or C<undef> 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<uplevel>
my @ret = uplevel { ...; return @ret };
# $cxt = SCOPE(4), UP SUB UP SUB = UP SUB EVAL = UP CALLER(2) = TOP
...
-Where L</unwind>, L</yield>, L</want_at> and L</uplevel> point to depending on the C<$cxt>:
+Where L</unwind>, L</yield>, L</want_at>, L</context_info> and L</uplevel> point to depending on the C<$cxt>:
sub {
eval {
=head1 EXPORT
-The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>, L</unwind>, L</yield>, L</leave>, L</want_at> and L</uplevel> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
+The functions L</reap>, L</localize>, L</localize_elem>, L</localize_delete>, L</unwind>, L</yield>, L</leave>, L</want_at>, L</context_info> and L</uplevel> are only exported on request, either individually or by the tags C<':funcs'> and C<':all'>.
The constant L</SU_THREADSAFE> is also only exported on request, individually or by the tags C<':consts'> and C<':all'>.
reap
localize localize_elem localize_delete
unwind yield leave
- want_at
+ want_at context_info
uplevel
uid validate_uid
> ],
use strict;
use warnings;
-use Test::More tests => 2 * 19;
+use Test::More tests => 2 * 20;
require Scope::Upper;
yield => undef,
leave => undef,
want_at => ';$',
+ context_info => ';$',
uplevel => '&@',
uid => ';$',
validate_uid => '$',
--- /dev/null
+#!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<context_info UP HERE CALLER>;
+
+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<context_info UP HERE is_deeply expected>) {
+ 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();
projects / perl / modules / Scope-Upper.git / commitdiff