1################################################################################
2##
3##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
4##  Version 2.x, Copyright (C) 2001, Paul Marquess.
5##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
6##
7##  This program is free software; you can redistribute it and/or
8##  modify it under the same terms as Perl itself.
9##
10################################################################################
11
12=provides
13
14caller_cx
15__UNDEFINED__
16
17=implementation
18
19#ifdef USE_ITHREADS
20
21__UNDEFINED__  CopFILE(c)               ((c)->cop_file)
22__UNDEFINED__  CopFILEGV(c)             (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
23__UNDEFINED__  CopFILE_set(c,pv)        ((c)->cop_file = savepv(pv))
24__UNDEFINED__  CopFILESV(c)             (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
25__UNDEFINED__  CopFILEAV(c)             (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
26__UNDEFINED__  CopSTASHPV(c)            ((c)->cop_stashpv)
27__UNDEFINED__  CopSTASHPV_set(c,pv)     ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
28__UNDEFINED__  CopSTASH(c)              (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
29__UNDEFINED__  CopSTASH_set(c,hv)       CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
30__UNDEFINED__  CopSTASH_eq(c,hv)        ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
31                                        || (CopSTASHPV(c) && HvNAME(hv) \
32                                        && strEQ(CopSTASHPV(c), HvNAME(hv)))))
33
34#else
35
36__UNDEFINED__  CopFILEGV(c)             ((c)->cop_filegv)
37__UNDEFINED__  CopFILEGV_set(c,gv)      ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
38__UNDEFINED__  CopFILE_set(c,pv)        CopFILEGV_set((c), gv_fetchfile(pv))
39__UNDEFINED__  CopFILESV(c)             (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
40__UNDEFINED__  CopFILEAV(c)             (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
41__UNDEFINED__  CopFILE(c)               (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
42__UNDEFINED__  CopSTASH(c)              ((c)->cop_stash)
43__UNDEFINED__  CopSTASH_set(c,hv)       ((c)->cop_stash = (hv))
44__UNDEFINED__  CopSTASHPV(c)            (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
45__UNDEFINED__  CopSTASHPV_set(c,pv)     CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
46__UNDEFINED__  CopSTASH_eq(c,hv)        (CopSTASH(c) == (hv))
47
48#endif /* USE_ITHREADS */
49
50#if { VERSION >= 5.6.0 }
51#ifndef caller_cx
52
53# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
54static I32
55DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
56{
57    I32 i;
58
59    for (i = startingblock; i >= 0; i--) {
60	register const PERL_CONTEXT * const cx = &cxstk[i];
61	switch (CxTYPE(cx)) {
62	default:
63	    continue;
64	case CXt_EVAL:
65	case CXt_SUB:
66	case CXt_FORMAT:
67	    return i;
68	}
69    }
70    return i;
71}
72# endif
73
74# if { NEED caller_cx }
75
76const PERL_CONTEXT *
77caller_cx(pTHX_ I32 level, const PERL_CONTEXT **dbcxp)
78{
79    register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix);
80    register const PERL_CONTEXT *cx;
81    register const PERL_CONTEXT *ccstack = cxstack;
82    const PERL_SI *top_si = PL_curstackinfo;
83
84    for (;;) {
85	/* we may be in a higher stacklevel, so dig down deeper */
86	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
87	    top_si = top_si->si_prev;
88	    ccstack = top_si->si_cxstack;
89	    cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
90	}
91	if (cxix < 0)
92	    return NULL;
93	/* caller() should not report the automatic calls to &DB::sub */
94	if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
95		ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
96	    level++;
97	if (!level--)
98	    break;
99	cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
100    }
101
102    cx = &ccstack[cxix];
103    if (dbcxp) *dbcxp = cx;
104
105    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
106        const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
107	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
108	   field below is defined for any cx. */
109	/* caller() should not report the automatic calls to &DB::sub */
110	if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
111	    cx = &ccstack[dbcxix];
112    }
113
114    return cx;
115}
116
117# endif
118#endif /* caller_cx */
119#endif /* 5.6.0 */
120
121=xsinit
122
123#define NEED_caller_cx
124
125=xsubs
126
127char *
128CopSTASHPV()
129        CODE:
130                RETVAL = CopSTASHPV(PL_curcop);
131        OUTPUT:
132                RETVAL
133
134char *
135CopFILE()
136        CODE:
137                RETVAL = CopFILE(PL_curcop);
138        OUTPUT:
139                RETVAL
140
141#if { VERSION >= 5.6.0 }
142
143void
144caller_cx(level)
145        I32 level
146    PREINIT:
147        const PERL_CONTEXT *cx, *dbcx;
148        const char *pv;
149        const GV *gv;
150    PPCODE:
151        cx = caller_cx(level, &dbcx);
152        if (!cx) XSRETURN_EMPTY;
153
154        EXTEND(SP, 4);
155
156        pv = CopSTASHPV(cx->blk_oldcop);
157        ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
158        gv = CvGV(cx->blk_sub.cv);
159        ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
160
161        pv = CopSTASHPV(dbcx->blk_oldcop);
162        ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
163        gv = CvGV(dbcx->blk_sub.cv);
164        ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
165
166        XSRETURN(4);
167
168#endif /* 5.6.0 */
169
170=tests plan => 8
171
172my $package;
173{
174  package MyPackage;
175  $package = &Devel::PPPort::CopSTASHPV();
176}
177print "# $package\n";
178is($package, "MyPackage");
179
180my $file = &Devel::PPPort::CopFILE();
181print "# $file\n";
182ok($file =~ /cop/i);
183
184BEGIN {
185  if ("$]" < 5.006000) {
186    skip("Perl version too early", 8);
187    exit;
188  }
189}
190
191BEGIN {
192    package DB;
193    no strict "refs";
194    local $^P = 1;
195    sub sub { &$DB::sub }
196}
197
198{ package One; sub one { Devel::PPPort::caller_cx($_[0]) } }
199{
200    package Two;
201    sub two { One::one(@_) }
202    sub dbtwo {
203        BEGIN { $^P = 1 }
204        One::one(@_);
205        BEGIN { $^P = 0 }
206    }
207}
208
209for (
210    # This is rather confusing. The package is the package the call is
211    # made *from*, the sub name is the sub the call is made *to*. When
212    # DB::sub is involved the first call is to DB::sub from the calling
213    # package, the second is to the real sub from package DB.
214    [\&One::one, 0, qw/main one main one/],
215    [\&One::one, 2, ],
216    [\&Two::two, 0, qw/Two one Two one/],
217    [\&Two::two, 1, qw/main two main two/],
218    [\&Two::dbtwo, 0, qw/Two sub DB one/],
219    [\&Two::dbtwo, 1, qw/main dbtwo main dbtwo/],
220) {
221    my ($sub, $arg, @want) = @$_;
222    my @got = $sub->($arg);
223    ok(eq_array(\@got, \@want));
224}
225
226