dist/Devel-PPPort/parts/inc/cop

   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
  14 caller_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)
  54 static I32
  55 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
  56 {
  57     I32 i;
  58
  59     for (i = startingblock; i >= 0; i--) {
  60         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
  76 const PERL_CONTEXT *
  77 caller_cx(pTHX_ I32 level, const PERL_CONTEXT **dbcxp)
  78 {
  79     I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix);
  80     const PERL_CONTEXT *cx;
  81     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
 127 char *
 128 CopSTASHPV()
 129         CODE:
 130                 RETVAL = CopSTASHPV(PL_curcop);
 131         OUTPUT:
 132                 RETVAL
 133
 134 char *
 135 CopFILE()
 136         CODE:
 137                 RETVAL = CopFILE(PL_curcop);
 138         OUTPUT:
 139                 RETVAL
 140
 141 #if { VERSION >= 5.6.0 }
 142
 143 void
 144 caller_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
 172 my $package;
 173 {
 174   package MyPackage;
 175   $package = &Devel::PPPort::CopSTASHPV();
 176 }
 177 print "# $package\n";
 178 is($package, "MyPackage");
 179
 180 my $file = &Devel::PPPort::CopFILE();
 181 print "# $file\n";
 182 ok($file =~ /cop/i);
 183
 184 BEGIN {
 185   if (ivers($]) < ivers('5.006000')) {
 186     skip("Perl version too early", 8);
 187     exit;
 188   }
 189 }
 190
 191 BEGIN {
 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
 209 for (
 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