ÿØÿà JFIF    ÿÛ „ ( %!1!%*+...983,7(-.- Peek.pm000064400000043215152343615660006006 0ustar00# Devel::Peek - A data debugging tool for the XS programmer # The documentation is after the __END__ package Devel::Peek; $VERSION = '1.26'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; require Exporter; require XSLoader; @ISA = qw(Exporter); @EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg fill_mstats mstats_fillhash mstats2hash runops_debug debug_flags); @EXPORT_OK = qw(SvREFCNT CvGV); %EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]); XSLoader::load(); sub import { my $c = shift; my $ops_rx = qr/^:opd(=[stP]*)?\b/; my @db = grep m/$ops_rx/, @_; @_ = grep !m/$ops_rx/, @_; if (@db) { die "Too many :opd options" if @db > 1; runops_debug(1); my $flags = ($db[0] =~ m/$ops_rx/ and $1); $flags = 'st' unless defined $flags; my $f = 0; $f |= 2 if $flags =~ /s/; $f |= 8 if $flags =~ /t/; $f |= 64 if $flags =~ /P/; $^D |= $f if $f; } unshift @_, $c; goto &Exporter::import; } sub DumpWithOP ($;$) { local($Devel::Peek::dump_ops)=1; my $depth = @_ > 1 ? $_[1] : 4 ; Dump($_[0],$depth); } $D_flags = 'psltocPmfrxuLHXDSTR'; sub debug_flags (;$) { my $out = ""; for my $i (0 .. length($D_flags)-1) { $out .= substr $D_flags, $i, 1 if $^D & (1<<$i); } my $arg = shift; my $num = $arg; if (defined $arg and $arg =~ /\D/) { die "unknown flags in debug_flags()" if $arg =~ /[^-$D_flags]/; my ($on,$off) = split /-/, "$arg-"; $num = $^D; $num |= (1<deparse($op->first, 6); my $sib = $op->first->sibling; if (ref $sib ne 'B::NULL') { push @kids, $deparse->deparse($sib, 6); } return "Devel::Peek::Dump(" . join(", ", @kids) . ")"; } 1; __END__ =head1 NAME Devel::Peek - A data debugging tool for the XS programmer =head1 SYNOPSIS use Devel::Peek; Dump( $a ); Dump( $a, 5 ); Dump( @a ); Dump( %h ); DumpArray( 5, $a, $b, ... ); mstat "Point 5"; use Devel::Peek ':opd=st'; =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. Devel::Peek supplies a C function which can dump a raw Perl datatype, and C 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. Devel::Peek also supplies C which can query 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 function. All output is to STDERR. The C function takes one or two arguments: something to dump, and an optional limit for recursion and array elements (default is 4). The first argument is evaluted in rvalue scalar context, with exceptions for @array and %hash, which dump the array or hash itself. So C works, as does C. And C will call C in rvalue context, whereas C will call it in lvalue context. Function C allows dumping of multiple values (useful when you need to analyze 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. If C directive has a C<:opd=FLAGS> argument, this switches on debugging of opcode dispatch. C should be a combination of C, C, and C

(see L<< B<-D> flags in perlrun|perlrun/B<-D>I >>). C<:opd> is a shortcut for C<:opd=st>. =head2 Runtime debugging C return one of the globs associated to a subroutine reference $cv. debug_flags() returns a string representation of C<$^D> (similar to what is allowed for B<-D> flag). When called with a numeric argument, sets $^D to the corresponding value. When called with an argument of the form C<"flags-flags">, set on/off bits of C<$^D> corresponding to letters before/after C<->. (The returned value is for C<$^D> before the modification.) runops_debug() returns true if the current I is the debugging one. When called with an argument, switches to debugging or non-debugging dispatcher depending on the argument (active for newly-entered subs/etc only). (The returned value is for the dispatcher before the modification.) =head2 Memory footprint debugging When perl is compiled with support for memory footprint debugging (default with Perl's malloc()), Devel::Peek provides an access to this API. Use mstat() function to emit a memory state statistic to the terminal. For more information on the format of output of mstat() see L. Three additional functions allow access to this statistic from Perl. First, use C to get the information contained in the output of mstat() into %hash. The field of this hash are minbucket nbuckets sbrk_good sbrk_slack sbrked_remains sbrks start_slack topbucket topbucket_ev topbucket_odd total total_chain total_sbrk totfree Two additional fields C, C contain array references which provide per-bucket count of free and used chunks. Two other fields C, C contain array references which provide the information about the allocated size and usable size of chunks in each bucket. Again, see L for details. Keep in mind that only the first several "odd-numbered" buckets are used, so the information on size of the "odd-numbered" buckets which are not used is probably meaningless. The information in mem_size available_size minbucket nbuckets is the property of a particular build of perl, and does not depend on the current process. If you do not provide the optional argument to the functions mstats_fillhash(), fill_mstats(), mstats2hash(), then the information in fields C, C is not updated. C is a much cheaper call (both speedwise and memory-wise) which collects the statistic into $buf in machine-readable form. At a later moment you may need to call C to use this information to fill %hash. All three APIs C, C, and C are designed to allocate no memory if used I on the same $buf and/or %hash. So, if you want to collect memory info in a cycle, you may call $#buf = 999; fill_mstats($_) for @buf; mstats_fillhash(%report, 1); # Static info too foreach (@buf) { # Do something... fill_mstats $_; # Collect statistic } foreach (@buf) { mstats2hash($_, %report); # Preserve static info # Do something with %report } =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 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 = 42; $a = "hello"; Dump $a; The output: SV = PVIV(0xbc288) at 0xbe9a8 REFCNT = 1 FLAGS = (POK,pPOK) IV = 42 PV = 0xb2048 "hello"\0 CUR = 5 LEN = 8 This says C<$a> is an SV, a scalar. The scalar type is a PVIV, which is capable of holding an integer (IV) and/or a string (PV) value. The scalar's head is allocated at address 0xbe9a8, while the body is at 0xbc288. Its reference count is 1. It has the C 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. Note that the IV field still contains its old numeric value, but because FLAGS doesn't have IOK set, we must ignore the IV item. CUR indicates the number of characters in the PV. LEN indicates the number of bytes allocated for the PV (at least one more than CUR, because LEN includes an extra byte for the end-of-string marker, then usually rounded up to some efficient allocation unit). =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) at 0xbe9a8 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 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) at 0xbe9a8 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 = IV(0xf041c) at 0xbe9a0 REFCNT = 1 FLAGS = (ROK) RV = 0xbab08 SV = IV(0xbe860) at 0xbe9a8 REFCNT = 2 FLAGS = (IOK,pIOK) IV = 42 Starting from the top, this says C<$b> is an SV. The scalar is an IV, which is capable of holding an integer or reference value. It has the C flag set, meaning it is a reference (rather than an integer or string). 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 coincides with the numbers we see when we stringify $b. The addresses inside IV() are addresses of C structures which hold the current state of an C. 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 = IV(0xc85998) at 0xc859a8 REFCNT = 1 FLAGS = (ROK) RV = 0xc70de8 SV = PVAV(0xc71e10) at 0xc70de8 REFCNT = 1 FLAGS = () ARRAY = 0xc7e820 FILL = 0 MAX = 0 FLAGS = (REAL) Elt No. 0 SV = IV(0xc70f88) at 0xc70f98 REFCNT = 1 FLAGS = (IOK,pIOK) IV = 42 This says C<$a> is a reference (ROK), which points to another SV which is a PVAV, an array. The array has one element, element zero, which is another SV. The field C 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 = IV(0x158c998) at 0x158c9a8 REFCNT = 1 FLAGS = (ROK) RV = 0x1577de8 SV = PVAV(0x1578e10) at 0x1577de8 REFCNT = 1 FLAGS = () ARRAY = 0x1585820 FILL = 1 MAX = 1 FLAGS = (REAL) Elt No. 0 SV = IV(0x1577f88) at 0x1577f98 REFCNT = 1 FLAGS = (IOK,pIOK) IV = 42 Elt No. 1 SV = IV(0x158be88) at 0x158be98 REFCNT = 1 FLAGS = (IOK,pIOK) IV = 24 Note that C will not report I 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 = IV(0x8177858) at 0x816a618 REFCNT = 1 FLAGS = (ROK) RV = 0x814fc10 SV = PVHV(0x8167768) at 0x814fc10 REFCNT = 1 FLAGS = (SHAREKEYS) ARRAY = 0x816c5b8 (0:7, 1:1) hash quality = 100.0% KEYS = 1 FILL = 1 MAX = 7 RITER = -1 EITER = 0x0 Elt "hello" HASH = 0xc8fd181b SV = IV(0x816c030) at 0x814fcf4 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>. The "quality" of a hash is defined as the total number of comparisons needed to access every element once, relative to the expected number needed for a random hash. The value can go over 100%. The total number of comparisons is equal to the sum of the squares of the number of entries in each bucket. For a random hash of C<> keys into C<> buckets, the expected value is: n + n(n-1)/2k =head2 Dumping a large array or hash The C 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 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 = IV(0xf381c) at 0xc859a8 REFCNT = 1 FLAGS = (ROK) RV = 0xb8ad8 SV = PVMG(0xbb3c8) at 0xc859a0 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 a reference, which points at another SV. In this case that second SV is a PVMG, a blessed scalar. Because it is blessed it has the C flag set. Note that an SV which holds a C pointer also has the C flag set. The C 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 = IV(0xf381c) at 0xc859a8 REFCNT = 1 FLAGS = (ROK) RV = 0xb8ad8 SV = PVMG(0xbb3c8) at 0xc859a0 REFCNT = 1 FLAGS = (IOK,pIOK) IV = 729160 NV = 0 PV = 0 =head2 A reference to a subroutine Looks like this: SV = IV(0x24d2dd8) at 0x24d2de8 REFCNT = 1 FLAGS = (TEMP,ROK) RV = 0x24e79d8 SV = PVCV(0x24e5798) at 0x24e79d8 REFCNT = 2 FLAGS = () COMP_STASH = 0x22c9c50 "main" START = 0x22eed60 ===> 0 ROOT = 0x22ee490 GVGV::GV = 0x22de9d8 "MY" :: "top_targets" FILE = "(eval 5)" DEPTH = 0 FLAGS = 0x0 OUTSIDE_SEQ = 93 PADLIST = 0x22e9ed8 PADNAME = 0x22e9ec0(0x22eed00) PAD = 0x22e9ea8(0x22eecd0) OUTSIDE = 0x22c9fb0 (MAIN) This shows that =over 4 =item * the subroutine is not an XSUB (since C and C are non-zero, and C is not listed, and is thus null); =item * that it was compiled in the package C
; =item * under the name C; =item * inside a 5th eval in the program; =item * it is not currently executed (because C is 0); =item * it has no prototype (C field is missing). =back =head1 EXPORTS C, C, C, C, C and C, C, C, C by default. Additionally available C, C and C. =head1 BUGS Readers have been known to skip important parts of L, 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, and L, again. =cut Peek/Peek.so000075500000047220152343623750006701 0ustar00ELF>p@G@8 @22 0<0< 0<  << < 888$$111 Std111 PtdP-P-P-QtdRtd0<0< 0< GNUm靚XY sO)H )+,BE|qX iR ,29Q =eKxq, qfF"@ ,@ @ ` (__gmon_start___ITM_deregisterTMCloneTable_ITM_registerTMCloneTable__cxa_finalizelibpthread.so.0Perl_get_svPerl_PerlIO_stderrPerl_do_sv_dumpPerl_sv_2iv_flagsPerl_sv_2bool_flagsPerl_newSVpvn_flagsPerl_ck_entersub_args_protoPerl_op_sibling_splicePerl_op_freePerl_Slab_AllocPerl_croak_xs_usagePL_thr_keypthread_getspecificPerl_runops_standardPerl_runops_debugPerl_sv_2mortalPerl_cvgv_from_hekPerlIO_printfPerl_newSV_typePerl_newRV_noincPerl_do_gvgv_dumpPerl_mg_sizePerl_sv_newmortalPerl_mg_getPerl_sv_setuv_mgPerl_warn_nocontextPerl_op_dumpPerl_sv_2pv_flagsPerl_croak_nocontextboot_Devel__PeekPerl_xs_handshakePerl_newXS_deffilePerl_newXS_flagsPerl_get_cvn_flagsPerl_cv_set_call_checkerPerl_custom_op_registerPerl_xs_boot_epiloglibperl.so.5.26libc.so.6_edata__bss_start_endGLIBC_2.2.5 ui 1Uui 10< 08< @< @< h< ,p< o+? ?  ?  ? ? #? %? '> > > > > > > >  >  >  > > ? ? ? ?  ? (? 0? 8? @? H? P? X? `? h? p? x?  ? !? "? $? &? '? (HH0 HtH5j/ %k/ hhhhhhhhqhah Qh Ah 1h !h hhhhhhhhhhqhahQhAh1h!hhhh h!%E- D%=- D%5- D%-- D%%- D%- D%- D% - D%- D%, D%, D%, D%, D%, D%, D%, D%, D%, D%, D%, D%, D%, D%, D%, D%, D%}, D%u, D%m, D%e, D%], D%U, D%M, D%E, D%=, D%! fDH=y, Hr, H9tH, Ht H=I, H5B, H)HHH?HHtH+ HtfD=, u+UH=+ Ht H=.( 9d+ ]wAWA1AVIH5AUATE1USHHHtP  HL` 1H5dH1DfHt>P "HHtHRHH5ATELUHE1H1fDH[]A\A]A^A_DHHIAvс uaft;tHHy fbH1ff.@(@EC1HH.H"H@180@DHHhATUSHGHH/x#Hut'HH8HEHCH+[H]A\DF Le% =uHHP HuLDHAUATIUHH5qSHӺHcHHLH2Hu(F!@uHF(@!@HHfHLnHAE!@IUHB!@AM"HDAE f%f=Af=AEu fȃAE"Hts1ɺgHL 8L?H@ f%f ~fC HuHCC#L11C"HHH[]A\A]1ɺHL8LH@ f%f ~fC HHCȃ*fDATUSHHHCxH+LCHPHHSxHcH֍BIH)HQwaHcHHM$H)պ~HcI4F % =uHP LHH+[]A\@HH5H3AUATUSHHHGxHHPHWxHWHchHH)HHHcL$H4F % =uyHDh Hs& 8HhEH W& Hh& HhH9HhHSHPHDHLcL#H[]A\A]f.A|fDH% 8jH% Hhf.H% HqH% kHH5DATUSHGxHHHPHWxHWHchHH)HHukHcHL$@ u$H8H%HSHLcL#[]A\ÐHp~ uH@]uHp8HtǃFfDsHHH5W/ff.@AWAVAUIATUSH(HGxHHPHHWxHWHchHH)HHcLcH4JH)F HL$% =_H@ D$1H5|LH$Ht P  HH@ H$1H5TLIAfAfD$`IGH,1HD$e%= DIELHL4(H4$E11AWHLLDL$(XZH;\$IELE1L4(HH5 HL1|MtAT$ UtHI$E1H`H@AHLE1H@ID$E180A,@tstI$AHx  E1I$1fAf.B(@DDD$fAHD$IEH([]A\A]A^A_1LLDfLLDHLH$D$HH5Y .ff.AWAVAUIATUSHHGxHPHWxHcHWX$HHH)HHD$< LH)MD$LH$D$HD$DD$@MMMAD$Il$H@IHD$PH9MLd$hIIL9|$PA uIP\u߀H@8HtIHx0t@]QHX8L%I1LHH & IP`H@HI8D$8D$$HpD$ D$(Ht$0D$,D$D$ H\$`HD$HD$ HcT$ H9dHL$0HHtHBL0HD$XM:L;t$`/ID$1H@$AF @1E1AL|$pSHH@H9}kHD$XL 0    ooh oo o< 0@P`p 0@P`p 0@GA$3a1) GA$3p1113p)GA*GA$annobin gcc 8.5.0 20210514GA$plugin name: gcc-annobinGA$running gcc 8.5.0 20210514GA*GA*GA! GA*FORTIFYGA+GLIBCXX_ASSERTIONS GA*GOW*GA*cf_protectionGA+omit_frame_pointerGA+stack_clashGA!stack_realign GA*FORTIFY@)GA+GLIBCXX_ASSERTIONSPeek.so-5.26.3-423.el8_10.x86_64.debugzw 7zXZִF!t/_]?Eh=ڊ2N$=V$$)X!hմBM\EC!j8W!N牀KeywmF䴸$~eЎIlbLge6gմX'3~cK>p'av`%#MumsNi1l$/4kXB3W L38 kP;*)'3xмQ9퉒a::B8 GZrNdBY1X9"eWj0P\j\gć{ nGm&d-]58H M`ʛwAWX]ɾeJdF2#74)Uɽo ;aK(˸d4|&/kg1W,Wg5uiV`[nEq)$rG oJO}::#XdD15s֟[-uVC;AHA|FS0'!+¹~ ҇Um s3UFFY'SGyctpx" #"֮ksf&}j)kkfSu,0*KXhe,*bT:Eٿ*-j7Zi># wRHz|RޟxzJ M dfK\Nsyo@JCQf0q>n +1EYcIDugzbz*VSq ~ -o(yer]vG[64߸0 ءLx B3S [YxFRÖ'EDbZ>I #oՓ' GL/ivT$0rAv|瀣}uy|h3ƠmeƁVSvn%1Qu y"pTlR]^kq |xO;j|\$2歷wJ$r~k~礔O:}B 7(gYZ.shstrtab.note.gnu.build-id.gnu.hash.dynsym.dynstr.gnu.version.gnu.version_r.rela.dyn.rela.plt.init.plt.sec.text.fini.rodata.eh_frame_hdr.eh_frame.note.gnu.property.init_array.fini_array.data.rel.ro.dynamic.got.bss.gnu.build.attributes.gnu_debuglink.gnu_debugdata 88$o``4( 80=8o  ZEoh h @T ^B 0hc  0nPP wppY})) 2))pP-P---11 0< 0<8< 8<@< @<H < <> >`@ ?@`?H0B,\BlF"StackTrace/.packlist000064400000000303152345134220010400 0ustar00/usr/local/share/man/man3/Devel::StackTrace.3pm /usr/local/share/man/man3/Devel::StackTrace::Frame.3pm /usr/local/share/perl5/Devel/StackTrace.pm /usr/local/share/perl5/Devel/StackTrace/Frame.pm StackTrace/Frame.pm000044400000014615152346254770010204 0ustar00package Devel::StackTrace::Frame; use strict; use warnings; our $VERSION = '2.05'; # Create accessor routines BEGIN { ## no critic (TestingAndDebugging::ProhibitNoStrict) no strict 'refs'; my @attrs = qw( package filename line subroutine hasargs wantarray evaltext is_require hints bitmask ); for my $attr (@attrs) { *{$attr} = sub { my $s = shift; return $s->{$attr} }; } } { my @args = qw( package filename line subroutine hasargs wantarray evaltext is_require hints bitmask ); sub new { my $proto = shift; my $class = ref $proto || $proto; my $self = bless {}, $class; @{$self}{@args} = @{ shift() }; $self->{args} = shift; $self->{respect_overload} = shift; $self->{max_arg_length} = shift; $self->{message} = shift; $self->{indent} = shift; # fixup unix-style paths on win32 $self->{filename} = File::Spec->canonpath( $self->{filename} ); return $self; } } sub args { my $self = shift; return @{ $self->{args} }; } sub as_string { my $self = shift; my $first = shift; my $p = shift; my $sub = $self->subroutine; # This code stolen straight from Carp.pm and then tweaked. All # errors are probably my fault -dave if ($first) { $sub = defined $self->{message} ? $self->{message} : 'Trace begun'; } else { # Build a string, $sub, which names the sub-routine called. # This may also be "require ...", "eval '...' or "eval {...}" if ( my $eval = $self->evaltext ) { if ( $self->is_require ) { $sub = "require $eval"; } else { $eval =~ s/([\\\'])/\\$1/g; $sub = "eval '$eval'"; } } elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; } # if there are any arguments in the sub-routine call, format # them according to the format variables defined earlier in # this file and join them onto the $sub sub-routine string # # We copy them because they're going to be modified. # if ( my @a = $self->args ) { for (@a) { # set args to the string "undef" if undefined unless ( defined $_ ) { $_ = 'undef'; next; } # hack! ## no critic (Subroutines::ProtectPrivateSubs) $_ = $self->Devel::StackTrace::_ref_to_string($_) if ref $_; ## use critic; ## no critic (Variables::RequireInitializationForLocalVars) local $SIG{__DIE__}; local $@; ## use critic; ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval) eval { my $max_arg_length = exists $p->{max_arg_length} ? $p->{max_arg_length} : $self->{max_arg_length}; if ( $max_arg_length && length $_ > $max_arg_length ) { ## no critic (BuiltinFunctions::ProhibitLvalueSubstr) substr( $_, $max_arg_length ) = '...'; } s/'/\\'/g; # 'quote' arg unless it looks like a number $_ = "'$_'" unless /^-?[\d.]+$/; # print control/high ASCII chars as 'M-' or '^' s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; }; ## use critic if ( my $e = $@ ) { $_ = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?'; } } # append ('all', 'the', 'arguments') to the $sub string $sub .= '(' . join( ', ', @a ) . ')'; $sub .= ' called'; } } # If the user opted into indentation (a la Carp::confess), pre-add a tab my $tab = $self->{indent} && !$first ? "\t" : q{}; return "${tab}$sub at " . $self->filename . ' line ' . $self->line; } 1; # ABSTRACT: A single frame in a stack trace __END__ =pod =encoding UTF-8 =head1 NAME Devel::StackTrace::Frame - A single frame in a stack trace =head1 VERSION version 2.05 =head1 DESCRIPTION See L for details. =for Pod::Coverage new =head1 METHODS See Perl's C documentation for more information on what these methods return. =head2 $frame->package The package which created this frame. =head2 $frame->filename The filename which created this frame. =head2 $frame->line The line where the frame was created. =head2 $frame->subroutine The subroutine which created this frame. =head2 $frame->hasargs This will be true if a new C<@_> was created for this this frame. =head2 $frame->wantarray This indicates the context for the call for this frame. This will be true if called in array context, false in scalar context, and C in void context. =head2 $frame->evaltext Returns undef if the frame was not part of an eval. =head2 $frame->is_require Returns undef if the frame was not part of a require. =head2 $frame->args Returns the arguments passed to the frame. Note that any arguments that are references are returned as references, not copies. =head2 $frame->hints Returns the value of C<$^H> for this frame. =head2 $frame->bitmask Returns the value of C<$bitmask> for this frame. =head2 $frame->as_string Returns a string containing a description of the frame. =head1 SUPPORT Bugs may be submitted at L. =head1 SOURCE The source code repository for Devel-StackTrace can be found at L. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2000 - 2024 by David Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) The full text of the license can be found in the F file included with this distribution. =cut InnerPackage.pm000055500000004622152346254770007455 0ustar00package Devel::InnerPackage; use strict; use Exporter 5.57 'import'; use if $] > 5.017, 'deprecate'; our $VERSION = '0.4'; our @EXPORT_OK = qw(list_packages); =pod =head1 NAME Devel::InnerPackage - find all the inner packages of a package =head1 SYNOPSIS use Foo::Bar; use Devel::InnerPackage qw(list_packages); my @inner_packages = list_packages('Foo::Bar'); =head1 DESCRIPTION Given a file like this package Foo::Bar; sub foo {} package Foo::Bar::Quux; sub quux {} package Foo::Bar::Quirka; sub quirka {} 1; then list_packages('Foo::Bar'); will return Foo::Bar::Quux Foo::Bar::Quirka =head1 METHODS =head2 list_packages Return a list of all inner packages of that package. =cut sub list_packages { my $pack = shift; $pack .= "::" unless $pack =~ m!::$!; no strict 'refs'; my @packs; my @stuff = grep !/^(main|)::$/, keys %{$pack}; for my $cand (grep /::$/, @stuff) { $cand =~ s!::$!!; my @children = list_packages($pack.$cand); push @packs, "$pack$cand" unless $cand =~ /^::/ || !__PACKAGE__->_loaded($pack.$cand); # or @children; push @packs, @children; } return grep {$_ !~ /::(::ISA::CACHE|SUPER)/} @packs; } ### XXX this is an inlining of the Class-Inspector->loaded() ### method, but inlined to remove the dependency. sub _loaded { my ($class, $name) = @_; no strict 'refs'; # Handle by far the two most common cases # This is very fast and handles 99% of cases. return 1 if defined ${"${name}::VERSION"}; return 1 if @{"${name}::ISA"}; # Are there any symbol table entries other than other namespaces foreach ( keys %{"${name}::"} ) { next if substr($_, -2, 2) eq '::'; return 1 if defined &{"${name}::$_"}; } # No functions, and it doesn't have a version, and isn't anything. # As an absolute last resort, check for an entry in %INC my $filename = join( '/', split /(?:'|::)/, $name ) . '.pm'; return 1 if defined $INC{$filename}; ''; } =head1 AUTHOR Simon Wistow =head1 COPYING Copyright, 2005 Simon Wistow Distributed under the same terms as Perl itself. =head1 BUGS None known. =cut 1; StackTrace.pm000044400000041424152346254770007150 0ustar00package Devel::StackTrace; use 5.006; use strict; use warnings; our $VERSION = '2.05'; use Devel::StackTrace::Frame; use File::Spec; use Scalar::Util qw( blessed ); use overload '""' => \&as_string, bool => sub {1}, fallback => 1; sub new { my $class = shift; my %p = @_; $p{unsafe_ref_capture} = !delete $p{no_refs} if exists $p{no_refs}; my $self = bless { index => undef, frames => [], raw => [], %p, }, $class; $self->_record_caller_data; return $self; } sub _record_caller_data { my $self = shift; my $filter = $self->{filter_frames_early} && $self->_make_frame_filter; # We exclude this method by starting at least one frame back. my $x = 1 + ( $self->{skip_frames} || 0 ); while ( my @c = $self->{no_args} ? caller( $x++ ) : do { ## no critic (Modules::ProhibitMultiplePackages, Variables::ProhibitPackageVars) package # the newline keeps dzil from adding a version here DB; @DB::args = (); caller( $x++ ); } ) { my @args; ## no critic (Variables::ProhibitPackageVars, BuiltinFunctions::ProhibitComplexMappings) unless ( $self->{no_args} ) { # This is the same workaroud as was applied to Carp.pm a little # while back # (https://rt.perl.org/Public/Bug/Display.html?id=131046): # # Guard our serialization of the stack from stack refcounting # bugs NOTE this is NOT a complete solution, we cannot 100% # guard against these bugs. However in many cases Perl *is* # capable of detecting them and throws an error when it # does. Unfortunately serializing the arguments on the stack is # a perfect way of finding these bugs, even when they would not # affect normal program flow that did not poke around inside the # stack. Inside of Carp.pm it makes little sense reporting these # bugs, as Carp's job is to report the callers errors, not the # ones it might happen to tickle while doing so. See: # https://rt.perl.org/Public/Bug/Display.html?id=131046 and: # https://rt.perl.org/Public/Bug/Display.html?id=52610 for more # details and discussion. - Yves @args = map { my $arg; local $@ = $@; eval { $arg = $_; 1; } or do { $arg = '** argument not available anymore **'; }; $arg; } @DB::args; } ## use critic my $raw = { caller => \@c, args => \@args, }; next if $filter && !$filter->($raw); unless ( $self->{unsafe_ref_capture} ) { $raw->{args} = [ map { ref $_ ? $self->_ref_to_string($_) : $_ } @{ $raw->{args} } ]; } push @{ $self->{raw} }, $raw; } } sub _ref_to_string { my $self = shift; my $ref = shift; return overload::AddrRef($ref) if blessed $ref && $ref->isa('Exception::Class::Base'); return overload::AddrRef($ref) unless $self->{respect_overload}; ## no critic (Variables::RequireInitializationForLocalVars) local $@; local $SIG{__DIE__}; ## use critic my $str = eval { $ref . q{} }; return $@ ? overload::AddrRef($ref) : $str; } sub _make_frames { my $self = shift; my $filter = !$self->{filter_frames_early} && $self->_make_frame_filter; my $raw = delete $self->{raw}; for my $r ( @{$raw} ) { next if $filter && !$filter->($r); $self->_add_frame( $r->{caller}, $r->{args} ); } } my $default_filter = sub {1}; sub _make_frame_filter { my $self = shift; my ( @i_pack_re, %i_class ); if ( $self->{ignore_package} ) { ## no critic (Variables::RequireInitializationForLocalVars) local $@; local $SIG{__DIE__}; ## use critic $self->{ignore_package} = [ $self->{ignore_package} ] unless eval { @{ $self->{ignore_package} } }; @i_pack_re = map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $self->{ignore_package} }; } my $p = __PACKAGE__; push @i_pack_re, qr/^\Q$p\E$/; if ( $self->{ignore_class} ) { $self->{ignore_class} = [ $self->{ignore_class} ] unless ref $self->{ignore_class}; %i_class = map { $_ => 1 } @{ $self->{ignore_class} }; } my $user_filter = $self->{frame_filter}; return sub { return 0 if grep { $_[0]{caller}[0] =~ /$_/ } @i_pack_re; return 0 if grep { $_[0]{caller}[0]->isa($_) } keys %i_class; if ($user_filter) { return $user_filter->( $_[0] ); } return 1; }; } sub _add_frame { my $self = shift; my $c = shift; my $p = shift; # eval and is_require are only returned when applicable under 5.00503. push @$c, ( undef, undef ) if scalar @$c == 6; push @{ $self->{frames} }, Devel::StackTrace::Frame->new( $c, $p, $self->{respect_overload}, $self->{max_arg_length}, $self->{message}, $self->{indent} ); } sub next_frame { my $self = shift; # reset to top if necessary. $self->{index} = -1 unless defined $self->{index}; my @f = $self->frames; if ( defined $f[ $self->{index} + 1 ] ) { return $f[ ++$self->{index} ]; } else { $self->{index} = undef; ## no critic (Subroutines::ProhibitExplicitReturnUndef) return undef; } } sub prev_frame { my $self = shift; my @f = $self->frames; # reset to top if necessary. $self->{index} = scalar @f unless defined $self->{index}; if ( defined $f[ $self->{index} - 1 ] && $self->{index} >= 1 ) { return $f[ --$self->{index} ]; } else { ## no critic (Subroutines::ProhibitExplicitReturnUndef) $self->{index} = undef; return undef; } } sub reset_pointer { my $self = shift; $self->{index} = undef; return; } sub frames { my $self = shift; if (@_) { die "Devel::StackTrace->frames can only take Devel::StackTrace::Frame args\n" if grep { !$_->isa('Devel::StackTrace::Frame') } @_; $self->{frames} = \@_; delete $self->{raw}; } else { $self->_make_frames if $self->{raw}; } return @{ $self->{frames} }; } sub frame { my $self = shift; my $i = shift; return unless defined $i; return ( $self->frames )[$i]; } sub frame_count { my $self = shift; return scalar( $self->frames ); } sub message { $_[0]->{message} } sub as_string { my $self = shift; my $p = shift; my @frames = $self->frames; if (@frames) { my $st = q{}; my $first = 1; for my $f (@frames) { $st .= $f->as_string( $first, $p ) . "\n"; $first = 0; } return $st; } my $msg = $self->message; return $msg if defined $msg; return 'Trace begun'; } { ## no critic (Modules::ProhibitMultiplePackages, ClassHierarchies::ProhibitExplicitISA) package # hide from PAUSE Devel::StackTraceFrame; our @ISA = 'Devel::StackTrace::Frame'; } 1; # ABSTRACT: An object representing a stack trace __END__ =pod =encoding UTF-8 =head1 NAME Devel::StackTrace - An object representing a stack trace =head1 VERSION version 2.05 =head1 SYNOPSIS use Devel::StackTrace; my $trace = Devel::StackTrace->new; print $trace->as_string; # like carp # from top (most recent) of stack to bottom. while ( my $frame = $trace->next_frame ) { print "Has args\n" if $frame->hasargs; } # from bottom (least recent) of stack to top. while ( my $frame = $trace->prev_frame ) { print "Sub: ", $frame->subroutine, "\n"; } =head1 DESCRIPTION The C module contains two classes, C and L. These objects encapsulate the information that can retrieved via Perl's C function, as well as providing a simple interface to this data. The C object contains a set of C objects, one for each level of the stack. The frames contain all the data available from C. This code was created to support my L class (part of L) but may be useful in other contexts. =head1 'TOP' AND 'BOTTOM' OF THE STACK When describing the methods of the trace object, I use the words 'top' and 'bottom'. In this context, the 'top' frame on the stack is the most recent frame and the 'bottom' is the least recent. Here's an example: foo(); # bottom frame is here sub foo { bar(); } sub bar { Devel::StackTrace->new; # top frame is here. } =head1 METHODS This class provide the following methods: =head2 Devel::StackTrace->new(%named_params) Returns a new Devel::StackTrace object. Takes the following parameters: =over 4 =item * frame_filter => $sub By default, Devel::StackTrace will include all stack frames before the call to its constructor. However, you may want to filter out some frames with more granularity than 'ignore_package' or 'ignore_class' allow. You can provide a subroutine which is called with the raw frame data for each frame. This is a hash reference with two keys, "caller", and "args", both of which are array references. The "caller" key is the raw data as returned by Perl's C function, and the "args" key are the subroutine arguments found in C<@DB::args>. The filter should return true if the frame should be included, or false if it should be skipped. =item * filter_frames_early => $boolean If this parameter is true, C will be called as soon as the stacktrace is created, and before refs are stringified (if C is not set), rather than being filtered lazily when L objects are first needed. This is useful if you want to filter based on the frame's arguments and want to be able to examine object properties, for example. =item * ignore_package => $package_name OR \@package_names Any frames where the package is one of these packages will not be on the stack. =item * ignore_class => $package_name OR \@package_names Any frames where the package is a subclass of one of these packages (or is the same package) will not be on the stack. Devel::StackTrace internally adds itself to the 'ignore_package' parameter, meaning that the Devel::StackTrace package is B ignored. However, if you create a subclass of Devel::StackTrace it will not be ignored. =item * skip_frames => $integer This will cause this number of stack frames to be excluded from top of the stack trace. This prevents the frames from being captured at all, and applies before the C, C, or C options, even with C. =item * unsafe_ref_capture => $boolean If this parameter is true, then Devel::StackTrace will store references internally when generating stacktrace frames. B. Using this option will keep any objects or references alive past their normal lifetime, until the stack trace object goes out of scope. It can keep objects alive even after their C sub is called, resulting it it being called multiple times on the same object. If not set, Devel::StackTrace replaces any references with their stringified representation. =item * no_args => $boolean If this parameter is true, then Devel::StackTrace will not store caller arguments in stack trace frames at all. =item * respect_overload => $boolean By default, Devel::StackTrace will call C to get the underlying string representation of an object, instead of respecting the object's stringification overloading. If you would prefer to see the overloaded representation of objects in stack traces, then set this parameter to true. =item * max_arg_length => $integer By default, Devel::StackTrace will display the entire argument for each subroutine call. Setting this parameter causes truncates each subroutine argument's string representation if it is longer than this number of characters. =item * message => $string By default, Devel::StackTrace will use 'Trace begun' as the message for the first stack frame when you call C. You can supply an alternative message using this option. =item * indent => $boolean If this parameter is true, each stack frame after the first will start with a tab character, just like C. =back =head2 $trace->next_frame Returns the next L object on the stack, going down. If this method hasn't been called before it returns the first frame. It returns C when it reaches the bottom of the stack and then resets its pointer so the next call to C<< $trace->next_frame >> or C<< $trace->prev_frame >> will work properly. =head2 $trace->prev_frame Returns the next L object on the stack, going up. If this method hasn't been called before it returns the last frame. It returns undef when it reaches the top of the stack and then resets its pointer so the next call to C<< $trace->next_frame >> or C<< $trace->prev_frame >> will work properly. =head2 $trace->reset_pointer Resets the pointer so that the next call to C<< $trace->next_frame >> or C<< $trace->prev_frame >> will start at the top or bottom of the stack, as appropriate. =head2 $trace->frames When this method is called with no arguments, it returns a list of L objects. They are returned in order from top (most recent) to bottom. This method can also be used to set the object's frames if you pass it a list of L objects. This is useful if you want to filter the list of frames in ways that are more complex than can be handled by the C<< $trace->filter_frames >> method: $stacktrace->frames( my_filter( $stacktrace->frames ) ); =head2 $trace->frame($index) Given an index, this method returns the relevant frame, or undef if there is no frame at that index. The index is exactly like a Perl array. The first frame is 0 and negative indexes are allowed. =head2 $trace->frame_count Returns the number of frames in the trace object. =head2 $trace->as_string(\%p) Calls C<< $frame->as_string >> on each frame from top to bottom, producing output quite similar to the Carp module's cluck/confess methods. The optional C<\%p> parameter only has one option. The C parameter truncates each subroutine argument's string representation if it is longer than this number of characters. If all the frames in a trace are skipped then this just returns the C passed to the constructor or the string C<"Trace begun">. =head2 $trace->message Returns the message passed to the constructor. If this wasn't passed then this method returns C. =head1 SUPPORT Bugs may be submitted at L. =head1 SOURCE The source code repository for Devel-StackTrace can be found at L. =head1 DONATIONS If you'd like to thank me for the work I've done on this module, please consider making a "donation" to me via PayPal. I spend a lot of free time creating free software, and would appreciate any support you'd care to offer. Please note that B in order for me to continue working on this particular software. I will continue to do so, inasmuch as I have in the past, for as long as it interests me. Similarly, a donation made in this way will probably not make me work on this software much more, unless I get so many donations that I can consider working on free software full time (let's all have a chuckle at that together). To donate, log into PayPal and send money to autarch@urth.org, or use the button at L. =head1 AUTHOR Dave Rolsky =head1 CONTRIBUTORS =for stopwords Dagfinn Ilmari Mannsåker David Cantrell Graham Knop Ivan Bessarabov Mark Fowler Pali Ricardo Signes =over 4 =item * Dagfinn Ilmari Mannsåker =item * David Cantrell =item * Graham Knop =item * Ivan Bessarabov =item * Mark Fowler =item * Pali =item * Ricardo Signes =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2000 - 2024 by David Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) The full text of the license can be found in the F file included with this distribution. =cut