diff options
Diffstat (limited to 'contrib/perl5/ext/Devel/Peek')
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Changes | 64 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Makefile.PL | 11 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.pm | 432 | ||||
| -rw-r--r-- | contrib/perl5/ext/Devel/Peek/Peek.xs | 218 |
4 files changed, 725 insertions, 0 deletions
diff --git a/contrib/perl5/ext/Devel/Peek/Changes b/contrib/perl5/ext/Devel/Peek/Changes new file mode 100644 index 0000000..e143f87 --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Changes @@ -0,0 +1,64 @@ +0.3: Some functions return SV * now. +0.4: Hashes dumped recursively. + Additional fields for CV added. +0.5: Prototypes for functions supported. + Strings are consostently in quotes now. + Name changed to Devel::Peek (former ExtUtils::Peek). +0.7: + New function mstat added. + Docs added (thanks to Dean Roehrich). + +0.8: + Exports Dump and mstat. + Docs list more details. + Arrays print addresses of SV. + CV: STASH renamed to COMP_STASH. The package of GV is printed now. + Updated for newer overloading implementation (but will not report + packages with overloading). +0.81: + Implements and exports DeadCode(). + Buglet in the definition of mstat for malloc-less perl corrected. +0.82: + New style PADless CV allowed. +0.83: + DumpArray added. + Compatible with PerlIO. + When calculating junk inside subs, divide by refcount. +0.84: + Indented output. +0.85: + By Gisle Aas: format SvPVX, print magic (but not unrefcounted mg_obj); + A lot of new fields stolen from sv_dump(); +0.86: + By Gisle Aas: + - Updated the documentation. + - Move string printer to it's own function: fprintpv() + - Use it to print PVs, HV keys, MG_PTR + - Don't print IV for hashes as KEY is the same field + - Tag GvSTASH as "GvSTASH" in order to not confuse it with + the other STASH field, e.g. Dump(bless \*foo, "bar") +0.87: + Extra indentation of SvRV. + AMAGIC removed. + Head of OOK data printed too. +0.88: + PADLIST and OUTSIDE of CVs itemized. + Prints the value of the hash of HV keys. + Changes by Gisle: do not print both if AvARRAY == AvALLOC; + print hash fill statistics. +0.89: + Changes by Gisle: optree dump. +0.90: + DumpWithOP, DumpProg exported. + Better indent for AV, HV elts. + Address of SV printed. + Corrected Zero code which was causing segfaults. +0.91: + Compiles, runs test under 5.005beta2. + Update DEBUGGING_MSTATS-less MSTATS. +0.92: + Should compile without MYMALLOC too. +0.94: + Had problems with HEf_SVKEY magic. +0.95: + Added "hash quality" output to estimate Perl's hash functions. diff --git a/contrib/perl5/ext/Devel/Peek/Makefile.PL b/contrib/perl5/ext/Devel/Peek/Makefile.PL new file mode 100644 index 0000000..3c6dbf5 --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => "Devel::Peek", + VERSION_FROM => 'Peek.pm', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, +); diff --git a/contrib/perl5/ext/Devel/Peek/Peek.pm b/contrib/perl5/ext/Devel/Peek/Peek.pm new file mode 100644 index 0000000..080251b --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Peek.pm @@ -0,0 +1,432 @@ +# Devel::Peek - A data debugging tool for the XS programmer +# The documentation is after the __END__ + +package Devel::Peek; + +# Underscore to allow older Perls to access older version from CPAN +$VERSION = '1.00_01'; + +require Exporter; +use XSLoader (); + +@ISA = qw(Exporter); +@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg); +@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV); +%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); + +XSLoader::load 'Devel::Peek'; + +sub DumpWithOP ($;$) { + local($Devel::Peek::dump_ops)=1; + my $depth = @_ > 1 ? $_[1] : 4 ; + Dump($_[0],$depth); +} + +1; +__END__ + +=head1 NAME + +Devel::Peek - A data debugging tool for the XS programmer + +=head1 SYNOPSIS + + use Devel::Peek; + Dump( $a ); + Dump( $a, 5 ); + DumpArray( 5, $a, $b, ... ); + mstat "Point 5"; + +=head1 DESCRIPTION + +Devel::Peek contains functions which allows raw Perl datatypes to be +manipulated from a Perl script. This is used by those who do XS programming +to check that the data they are sending from C to Perl looks as they think +it should look. The trick, then, is to know what the raw datatype is +supposed to look like when it gets to Perl. This document offers some tips +and hints to describe good and bad raw data. + +It is very possible that this document will fall far short of being useful +to the casual reader. The reader is expected to understand the material in +the first few sections of L<perlguts>. + +Devel::Peek supplies a C<Dump()> function which can dump a raw Perl +datatype, and C<mstat("marker")> function to report on memory usage +(if perl is compiled with corresponding option). The function +DeadCode() provides statistics on the data "frozen" into inactive +C<CV>. Devel::Peek also supplies C<SvREFCNT()>, C<SvREFCNT_inc()>, and +C<SvREFCNT_dec()> which can query, increment, and decrement reference +counts on SVs. This document will take a passive, and safe, approach +to data debugging and for that it will describe only the C<Dump()> +function. For format of output of mstats() see +L<perldebug/Using C<$ENV{PERL_DEBUG_MSTATS}>>. + +Function C<DumpArray()> allows dumping of multiple values (useful when you +need to analize returns of functions). + +The global variable $Devel::Peek::pv_limit can be set to limit the +number of character printed in various string values. Setting it to 0 +means no limit. + +=head1 EXAMPLES + +The following examples don't attempt to show everything as that would be a +monumental task, and, frankly, we don't want this manpage to be an internals +document for Perl. The examples do demonstrate some basics of the raw Perl +datatypes, and should suffice to get most determined people on their way. +There are no guidewires or safety nets, nor blazed trails, so be prepared to +travel alone from this point and on and, if at all possible, don't fall into +the quicksand (it's bad for business). + +Oh, one final bit of advice: take L<perlguts> with you. When you return we +expect to see it well-thumbed. + +=head2 A simple scalar string + +Let's begin by looking a simple scalar which is holding a string. + + use Devel::Peek; + $a = "hello"; + Dump $a; + +The output: + + SV = PVIV(0xbc288) + REFCNT = 1 + FLAGS = (POK,pPOK) + IV = 0 + PV = 0xb2048 "hello"\0 + CUR = 5 + LEN = 6 + +This says C<$a> is an SV, a scalar. The scalar is a PVIV, a string. +Its reference count is 1. It has the C<POK> flag set, meaning its +current PV field is valid. Because POK is set we look at the PV item +to see what is in the scalar. The \0 at the end indicate that this +PV is properly NUL-terminated. +If the FLAGS had been IOK we would look +at the IV item. CUR indicates the number of characters in the PV. +LEN indicates the number of bytes requested for the PV (one more than +CUR, in this case, because LEN includes an extra byte for the +end-of-string marker). + +=head2 A simple scalar number + +If the scalar contains a number the raw SV will be leaner. + + use Devel::Peek; + $a = 42; + Dump $a; + +The output: + + SV = IV(0xbc818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV, a scalar. The scalar is an IV, a number. Its +reference count is 1. It has the C<IOK> flag set, meaning it is currently +being evaluated as a number. Because IOK is set we look at the IV item to +see what is in the scalar. + +=head2 A simple scalar with an extra reference + +If the scalar from the previous example had an extra reference: + + use Devel::Peek; + $a = 42; + $b = \$a; + Dump $a; + +The output: + + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Notice that this example differs from the previous example only in its +reference count. Compare this to the next example, where we dump C<$b> +instead of C<$a>. + +=head2 A reference to a simple scalar + +This shows what a reference looks like when it references a simple scalar. + + use Devel::Peek; + $a = 42; + $b = \$a; + Dump $b; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xbab08 + SV = IV(0xbe860) + REFCNT = 2 + FLAGS = (IOK,pIOK) + IV = 42 + +Starting from the top, this says C<$b> is an SV. The scalar is an RV, a +reference. It has the C<ROK> flag set, meaning it is a reference. Because +ROK is set we have an RV item rather than an IV or PV. Notice that Dump +follows the reference and shows us what C<$b> was referencing. We see the +same C<$a> that we found in the previous example. + +Note that the value of C<RV> coincides with the numbers we see when we +stringify $b. The addresses inside RV() and IV() are addresses of +C<X***> structure which holds the current state of an C<SV>. This +address may change during lifetime of an SV. + +=head2 A reference to an array + +This shows what a reference to an array looks like. + + use Devel::Peek; + $a = [42]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This says C<$a> is an SV and that it is an RV. That RV points to +another SV which is a PVAV, an array. The array has one element, +element zero, which is another SV. The field C<FILL> above indicates +the last element in the array, similar to C<$#$a>. + +If C<$a> pointed to an array of two elements then we would see the +following. + + use Devel::Peek 'Dump'; + $a = [42,24]; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVAV(0xbd448) + REFCNT = 1 + FLAGS = () + IV = 0 + NV = 0 + ARRAY = 0xb2048 + ALLOC = 0xb2048 + FILL = 0 + MAX = 0 + ARYLEN = 0x0 + FLAGS = (REAL) + Elt No. 0 0xb5658 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + Elt No. 1 0xb5680 + SV = IV(0xbe818) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 24 + +Note that C<Dump> will not report I<all> the elements in the array, +only several first (depending on how deep it already went into the +report tree). + +=head2 A reference to a hash + +The following shows the raw form of a reference to a hash. + + use Devel::Peek; + $a = {hello=>42}; + Dump $a; + +The output: + + SV = RV(0xf041c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb2850 + SV = PVHV(0xbd448) + REFCNT = 1 + FLAGS = () + NV = 0 + ARRAY = 0xbd748 + KEYS = 1 + FILL = 1 + MAX = 7 + RITER = -1 + EITER = 0x0 + Elt "hello" => 0xbaaf0 + SV = IV(0xbe860) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 42 + +This shows C<$a> is a reference pointing to an SV. That SV is a PVHV, a +hash. Fields RITER and EITER are used by C<L<each>>. + +=head2 Dumping a large array or hash + +The C<Dump()> function, by default, dumps up to 4 elements from a +toplevel array or hash. This number can be increased by supplying a +second argument to the function. + + use Devel::Peek; + $a = [10,11,12,13,14]; + Dump $a; + +Notice that C<Dump()> prints only elements 10 through 13 in the above code. +The following code will print all of the elements. + + use Devel::Peek 'Dump'; + $a = [10,11,12,13,14]; + Dump $a, 5; + +=head2 A reference to an SV which holds a C pointer + +This is what you really need to know as an XS programmer, of course. When +an XSUB returns a pointer to a C structure that pointer is stored in an SV +and a reference to that SV is placed on the XSUB stack. So the output from +an XSUB which uses something like the T_PTROBJ map might look something like +this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (OBJECT,IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + STASH = 0xc1d10 "CookBookB::Opaque" + +This shows that we have an SV which is an RV. That RV points at another +SV. In this case that second SV is a PVMG, a blessed scalar. Because it is +blessed it has the C<OBJECT> flag set. Note that an SV which holds a C +pointer also has the C<IOK> flag set. The C<STASH> is set to the package +name which this SV was blessed into. + +The output from an XSUB which uses something like the T_PTRREF map, which +doesn't bless the object, might look something like this: + + SV = RV(0xf381c) + REFCNT = 1 + FLAGS = (ROK) + RV = 0xb8ad8 + SV = PVMG(0xbb3c8) + REFCNT = 1 + FLAGS = (IOK,pIOK) + IV = 729160 + NV = 0 + PV = 0 + +=head2 A reference to a subroutine + +Looks like this: + + SV = RV(0x798ec) + REFCNT = 1 + FLAGS = (TEMP,ROK) + RV = 0x1d453c + SV = PVCV(0x1c768c) + REFCNT = 2 + FLAGS = () + IV = 0 + NV = 0 + COMP_STASH = 0x31068 "main" + START = 0xb20e0 + ROOT = 0xbece0 + XSUB = 0x0 + XSUBANY = 0 + GVGV::GV = 0x1d44e8 "MY" :: "top_targets" + FILE = "(eval 5)" + DEPTH = 0 + PADLIST = 0x1c9338 + +This shows that + +=over + +=item * + +the subroutine is not an XSUB (since C<START> and C<ROOT> are +non-zero, and C<XSUB> is zero); + +=item * + +that it was compiled in the package C<main>; + +=item * + +under the name C<MY::top_targets>; + +=item * + +inside a 5th eval in the program; + +=item * + +it is not currently executed (see C<DEPTH>); + +=item * + +it has no prototype (C<PROTOTYPE> field is missing). + +=back + +=head1 EXPORTS + +C<Dump>, C<mstat>, C<DeadCode>, C<DumpArray>, C<DumpWithOP> and +C<DumpProg> by default. Additionally available C<SvREFCNT>, +C<SvREFCNT_inc> and C<SvREFCNT_dec>. + +=head1 BUGS + +Readers have been known to skip important parts of L<perlguts>, causing much +frustration for all. + +=head1 AUTHOR + +Ilya Zakharevich ilya@math.ohio-state.edu + +Copyright (c) 1995-98 Ilya Zakharevich. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +Author of this software makes no claim whatsoever about suitability, +reliability, edability, editability or usability of this product, and +should not be kept liable for any damage resulting from the use of +it. If you can use it, you are in luck, if not, I should not be kept +responsible. Keep a handy copy of your backup tape at hand. + +=head1 SEE ALSO + +L<perlguts>, and L<perlguts>, again. + +=cut diff --git a/contrib/perl5/ext/Devel/Peek/Peek.xs b/contrib/perl5/ext/Devel/Peek/Peek.xs new file mode 100644 index 0000000..9837e9c --- /dev/null +++ b/contrib/perl5/ext/Devel/Peek/Peek.xs @@ -0,0 +1,218 @@ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +SV * +DeadCode(pTHX) +{ +#ifdef PURIFY + return Nullsv; +#else + SV* sva; + SV* sv, *dbg; + SV* ret = newRV_noinc((SV*)newAV()); + register SV* svend; + int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; + + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) == SVt_PVCV) { + CV *cv = (CV*)sv; + AV* padlist = CvPADLIST(cv), *argav; + SV** svp; + SV** pad; + int i = 0, j, levelm, totm = 0, levelref, totref = 0; + int levels, tots = 0, levela, tota = 0, levelas, totas = 0; + int dumpit = 0; + + if (CvXSUB(sv)) { + continue; /* XSUB */ + } + if (!CvGV(sv)) { + continue; /* file-level scope. */ + } + if (!CvROOT(cv)) { + /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ + continue; /* autoloading stub. */ + } + do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); + if (CvDEPTH(cv)) { + PerlIO_printf(Perl_debug_log, " busy\n"); + continue; + } + svp = AvARRAY(padlist); + while (++i <= AvFILL(padlist)) { /* Depth. */ + SV **args; + + pad = AvARRAY((AV*)svp[i]); + argav = (AV*)pad[0]; + if (!argav || (SV*)argav == &PL_sv_undef) { + PerlIO_printf(Perl_debug_log, " closure-template\n"); + continue; + } + args = AvARRAY(argav); + levelm = levels = levelref = levelas = 0; + levela = sizeof(SV*) * (AvMAX(argav) + 1); + if (AvREAL(argav)) { + for (j = 0; j < AvFILL(argav); j++) { + if (SvROK(args[j])) { + PerlIO_printf(Perl_debug_log, " ref in args!\n"); + levelref++; + } + /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ + else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { + levelas += SvLEN(args[j])/SvREFCNT(args[j]); + } + } + } + for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ + if (SvROK(pad[j])) { + levelref++; + do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); + dumpit = 1; + } + /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ + else if (SvTYPE(pad[j]) >= SVt_PVAV) { + if (!SvPADMY(pad[j])) { + levelref++; + do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); + dumpit = 1; + } + } + else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { + int db_len = SvLEN(pad[j]); + SV *db_sv = pad[j]; + levels++; + levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); + /* Dump(pad[j],4); */ + } + } + PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", + i, levelref, levelm, levels, levela, levelas); + totm += levelm; + tota += levela; + totas += levelas; + tots += levels; + totref += levelref; + if (dumpit) + do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); + } + if (AvFILL(padlist) > 1) { + PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", + totref, totm, tots, tota, totas); + } + tref += totref; + tm += totm; + ts += tots; + ta += tota; + tas += totas; + } + } + } + PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); + + return ret; +#endif /* !PURIFY */ +} + +#if defined(PERL_DEBUGGING_MSTATS) || defined(DEBUGGING_MSTATS) \ + || (defined(MYMALLOC) && !defined(PLAIN_MALLOC)) +# define mstat(str) dump_mstats(str) +#else +# define mstat(str) \ + PerlIO_printf(Perl_debug_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",str); +#endif + +#define _CvGV(cv) \ + (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ + ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) + +MODULE = Devel::Peek PACKAGE = Devel::Peek + +void +mstat(str="Devel::Peek::mstat: ") +char *str + +void +Dump(sv,lim=4) +SV * sv +I32 lim +PPCODE: +{ + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + do_sv_dump(0, Perl_debug_log, sv, 0, lim, dumpop && SvTRUE(dumpop), pv_lim); + PL_dumpindent = save_dumpindent; +} + +void +DumpArray(lim,...) +I32 lim +PPCODE: +{ + long i; + SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", FALSE); + STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; + SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", FALSE); + I32 save_dumpindent = PL_dumpindent; + PL_dumpindent = 2; + + for (i=1; i<items; i++) { + PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); + do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, dumpop && SvTRUE(dumpop), pv_lim); + } + PL_dumpindent = save_dumpindent; +} + +void +DumpProg() +PPCODE: +{ + warn("dumpindent is %d", PL_dumpindent); + if (PL_main_root) + op_dump(PL_main_root); +} + +I32 +SvREFCNT(sv) +SV * sv + +# PPCODE needed since otherwise sv_2mortal is inserted that will kill the value. + +SV * +SvREFCNT_inc(sv) +SV * sv +PPCODE: +{ + RETVAL = SvREFCNT_inc(sv); + PUSHs(RETVAL); +} + +# PPCODE needed since by default it is void + +SV * +SvREFCNT_dec(sv) +SV * sv +PPCODE: +{ + SvREFCNT_dec(sv); + PUSHs(sv); +} + +SV * +DeadCode() +CODE: + RETVAL = DeadCode(aTHX); +OUTPUT: + RETVAL + +MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ + +SV * +_CvGV(cv) + SV *cv |
