From: Jesse Luehrs Date: Sun, 14 Nov 2010 17:24:36 +0000 (-0600) Subject: reimplement the %DB::sub functionality X-Git-Tag: 0.14~13 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d1d0e437f4a989ddd7b1c8061b1f5900447a4db0;p=gitmo%2FPackage-Stash-XS.git reimplement the %DB::sub functionality --- diff --git a/.gitignore b/.gitignore index 92100a6..b168bbb 100644 --- a/.gitignore +++ b/.gitignore @@ -12,4 +12,5 @@ MANIFEST.bak Package-Stash-* *.bs *.c +!stolen_bits_of_padwalker.c *.o diff --git a/Stash.xs b/Stash.xs index 44e7ce4..e1d66e1 100644 --- a/Stash.xs +++ b/Stash.xs @@ -80,6 +80,12 @@ GvIOp(g) = (IO*)(v); \ } while (0) +/* XXX: the core implementation of caller() is private, so we need a + * a reimplementation. luckily, padwalker already has done this. rafl says + * that there should be a public interface in 5.14, so maybe look into + * converting to use that at some point */ +#include "stolen_bits_of_padwalker.c" + typedef enum { VAR_NONE = 0, VAR_SCALAR, @@ -416,24 +422,13 @@ add_symbol(self, variable, initial=NULL, ...) sv_catpvs(name, "::"); sv_catpv(name, variable.name); - /* XXX: come back to this when i feel like reimplementing caller() */ -/* - my $filename = $opts{filename}; - my $first_line_num = $opts{first_line_num}; - - (undef, $filename, $first_line_num) = caller - if not defined $filename; - - my $last_line_num = $opts{last_line_num} || ($first_line_num ||= 0); - - # http://perldoc.perl.org/perldebguts.html#Debugger-Internals - $DB::sub{$pkg . '::' . $name} = "$filename:$first_line_num-$last_line_num"; -*/ -/* if (items > 2 && (PL_perldb & 0x10) && variable.type == VAR_CODE) { int i; - char *filename = NULL, *name; - I32 first_line_num, last_line_num; + char *filename = NULL, *namepv; + I32 first_line_num = -1, last_line_num = -1; + STRLEN namelen; + SV *dbval; + HV *dbsub; if ((items - 3) % 2) croak("add_symbol: Odd number of elements in %%opts"); @@ -458,10 +453,33 @@ add_symbol(self, variable, initial=NULL, ...) } } - if (!filename) { + if (!filename || first_line_num == -1) { + I32 cxix_from, cxix_to; + PERL_CONTEXT *cx, *ccstack; + COP *cop = NULL; + + cx = upcontext(0, &cop, &ccstack, &cxix_from, &cxix_to); + if (!cop) + cop = PL_curcop; + + if (!filename) + filename = CopFILE(cop); + if (first_line_num == -1) + first_line_num = cop->cop_line; + } + + if (last_line_num == -1) + last_line_num = first_line_num; + + /* http://perldoc.perl.org/perldebguts.html#Debugger-Internals */ + dbsub = get_hv("DB::sub", 1); + dbval = newSVpvf("%s:%d-%d", filename, first_line_num, last_line_num); + namepv = SvPV(name, namelen); + if (!hv_store(dbsub, namepv, namelen, dbval, 0)) { + warn("Failed to update $DB::sub for subroutine %s", namepv); + SvREFCNT_dec(dbval); } } -*/ /* GV_ADDMULTI rather than GV_ADD because otherwise you get 'used only * once' warnings in some situations... i can't reproduce this, but CMOP diff --git a/stolen_bits_of_padwalker.c b/stolen_bits_of_padwalker.c new file mode 100644 index 0000000..0f8d2ea --- /dev/null +++ b/stolen_bits_of_padwalker.c @@ -0,0 +1,82 @@ +/* For development testing */ +#ifdef PACKAGE_STASH_DEBUGGING +# define debug_print(x) printf x +#else +# define debug_print(x) +#endif + +/* Originally stolen from pp_ctl.c; now significantly different */ + +I32 +dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock) +{ + dTHR; + I32 i; + PERL_CONTEXT *cx; + for (i = startingblock; i >= 0; i--) { + cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_SUB: + /* In Perl 5.005, formats just used CXt_SUB */ +#ifdef CXt_FORMAT + case CXt_FORMAT: +#endif + debug_print(("**dopoptosub_at: found sub #%ld\n", (long)i)); + return i; + } + } + debug_print(("**dopoptosub_at: not found #%ld\n", (long)i)); + return i; +} + +I32 +dopoptosub(pTHX_ I32 startingblock) +{ + dTHR; + return dopoptosub_at(aTHX_ cxstack, startingblock); +} + +/* This function is based on the code of pp_caller */ +PERL_CONTEXT* +upcontext(pTHX_ I32 count, COP **cop_p, PERL_CONTEXT **ccstack_p, + I32 *cxix_from_p, I32 *cxix_to_p) +{ + PERL_SI *top_si = PL_curstackinfo; + I32 cxix = dopoptosub(aTHX_ cxstack_ix); + PERL_CONTEXT *ccstack = cxstack; + + if (cxix_from_p) *cxix_from_p = cxstack_ix+1; + if (cxix_to_p) *cxix_to_p = cxix; + for (;;) { + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix); + if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p; + if (cxix_to_p) *cxix_to_p = cxix; + } + if (cxix < 0 && count == 0) { + if (ccstack_p) *ccstack_p = ccstack; + return (PERL_CONTEXT *)0; + } + else if (cxix < 0) + return (PERL_CONTEXT *)-1; + if (PL_DBsub && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + count++; + if (!count--) + break; + + if (cop_p) *cop_p = ccstack[cxix].blk_oldcop; + cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1); + if (cxix_to_p && cxix_from_p) *cxix_from_p = *cxix_to_p; + if (cxix_to_p) *cxix_to_p = cxix; + } + if (ccstack_p) *ccstack_p = ccstack; + return &ccstack[cxix]; +} + +/* end thievery */ diff --git a/t/06-addsub.t b/t/06-addsub.t index 50a67fd..1965afd 100644 --- a/t/06-addsub.t +++ b/t/06-addsub.t @@ -29,7 +29,6 @@ ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function'); my $line = (Foo->funk())[1]; -{ local $TODO = "need to reimplement the db stuff in xs"; is $DB::sub{'Foo::funk'}, sprintf "%s:%d-%d", __FILE__, $line, $line, '... got the right %DB::sub value for funk default args'; @@ -42,6 +41,5 @@ $foo_stash->add_symbol( is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199, '... got the right %DB::sub value for dunk with specified args'; -} done_testing;