Integrate from mainperl.

p4raw-id: //depot/cfgperl@2350

9 files changed, 754 insertions, 13 deletions

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 0fff04de87..75dcfb3b74 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -13,7 +13,7 @@ require Exporter;
 		class peekop cast_I32 cstring cchar hash threadsv_names
 		main_root main_start main_cv svref_2object
 		walkoptree walkoptree_slow walkoptree_exec walksymtable
-		parents comppadlist sv_undef compile_stats timing_info);
+		parents comppadlist sv_undef compile_stats timing_info init_av);
 
 use strict;
 @B::SV::ISA = 'B::OBJECT';
@@ -722,6 +722,10 @@ get an initial "handle" on an internal object.
 Return the (faked) CV corresponding to the main part of the Perl
 program.
 
+=item init_av
+
+Returns the AV object (i.e. in class B::AV) representing INIT blocks.
+
 =item main_root
 
 Returns the root op (i.e. an object in the appropriate B::OP-derived
diff --git a/ext/B/B.xs b/ext/B/B.xs
index ccc3f266c1..5943e128de 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -437,6 +437,7 @@ BOOT:
     INIT_SPECIALSV_LIST;
 
 #define B_main_cv()	PL_main_cv
+#define B_init_av()	PL_initav
 #define B_main_root()	PL_main_root
 #define B_main_start()	PL_main_start
 #define B_comppadlist()	(PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
@@ -444,6 +445,9 @@ BOOT:
 #define B_sv_yes()	&PL_sv_yes
 #define B_sv_no()	&PL_sv_no
 
+B::AV
+B_init_av()
+
 B::CV
 B_main_cv()
 
diff --git a/ext/B/B/Assembler.pm b/ext/B/B/Assembler.pm
index fd5acb6880..06e00adeb5 100644
--- a/ext/B/B/Assembler.pm
+++ b/ext/B/B/Assembler.pm
@@ -80,7 +80,7 @@ sub B::Asmdata::PUT_PV {
     error "bad string argument: $arg" unless defined($arg);
     return pack("N", length($arg)) . $arg;
 }
-sub B::Asmdata::PUT_comment {
+sub B::Asmdata::PUT_comment_t {
     my $arg = shift;
     $arg = uncstring($arg);
     error "bad string argument: $arg" unless defined($arg);
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 5b00e2fd6f..da9f7ddd1b 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -13,7 +13,7 @@ use Exporter ();
 
 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
 	 class cstring cchar svref_2object compile_stats comppadlist hash
-	 threadsv_names main_cv );
+	 threadsv_names main_cv init_av);
 use B::Asmdata qw(@specialsv_name);
 
 use FileHandle;
@@ -44,7 +44,7 @@ my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
     $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
     $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
     $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
-    $xrvsect, $xpvbmsect, $xpviosect);
+    $xrvsect, $xpvbmsect, $xpviosect, $bootstrap);
 
 sub walk_and_save_optree;
 my $saveoptree_callback = \&walk_and_save_optree;
@@ -696,7 +696,7 @@ sub B::GV::save {
 	}
 	my $gvfilegv = $gv->FILEGV;
 	if ($$gvfilegv) {
-	    $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv));
+	    $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
 #	    warn "GV::save GvFILEGV(*$name)\n"; # debug
 	    $gvfilegv->save;
 	}
@@ -852,6 +852,7 @@ sub output_all {
 		    $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
 		    $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
 		    $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
+    $bootstrap->output(\*STDOUT, "/* bootstrap %s */\n");
     $symsect->output(\*STDOUT, "#define %s\n");
     print "\n";
     output_declarations();
@@ -1051,25 +1052,37 @@ sub save_object {
     foreach $sv (@_) {
 	svref_2object($sv)->save;
     }
-}
+}                    
 
 sub B::GV::savecv {
     my $gv = shift;
     my $cv = $gv->CV;
     my $name = $gv->NAME;
-    if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
+    if ($$cv && !objsym($cv)) {
+	if ($name eq "bootstrap" && $cv->XSUB) {
+	    my $file = $cv->FILEGV->SV->PV;
+	    $bootstrap->add($file);
+	    return;
+	}
 	if ($debug_cv) {
 	    warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
 			 $gv->STASH->NAME, $name, $$cv, $$gv);
 	}
       my $package=$gv->STASH->NAME;
-      if ( ! grep(/^$package$/,@unused_sub_packages)){
+      # This seems to undo all the ->isa and prefix stuff we do below
+      # so disable again for now
+      if (0 && ! grep(/^$package$/,@unused_sub_packages)){
           warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME) 
               if $debug_cv;
           return ;
       }
 	$gv->save;
     }
+    elsif ($name eq 'ISA')
+     {
+      $gv->save;
+     }
+
 }
 
 sub save_unused_subs {
@@ -1080,6 +1093,7 @@ sub save_unused_subs {
     walksymtable(\%{"main::"}, "savecv", sub {
 	my $package = shift;
 	$package =~ s/::$//;
+	return 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
 	#warn "Considering $package\n";#debug
 	return 1 if exists $search_pack{$package};
       #sub try for a partial match
@@ -1095,8 +1109,18 @@ sub save_unused_subs {
 	    || $package eq "SelectSaver") {
 	    return 0;
 	}
-	my $m;
-	foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
+	foreach my $u (keys %search_pack) {
+	    if ($package =~ /^${u}::/) {
+		warn "$package starts with $u\n";
+		return 1
+	    }
+	    if ($package->isa($u)) {
+		warn "$package isa $u\n";
+		return 1
+	    }
+	    return 1 if $package->isa($u);
+	}
+	foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
 	    if (defined(&{$package."::$m"})) {
 		warn "$package has method $m: -u$package assumed\n";#debug
               push @unused_sub_package, $package;
@@ -1110,6 +1134,7 @@ sub save_unused_subs {
 sub save_main {
     my $curpad_nam = (comppadlist->ARRAY)[0]->save;
     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+    my $init_av    = init_av->save;
     walkoptree(main_root, "save");
     warn "done main optree, walking symtable for extras\n" if $debug_cv;
     save_unused_subs(@unused_sub_packages);
@@ -1117,9 +1142,10 @@ sub save_main {
     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
 	       sprintf("PL_main_start = s\\_%x;", ${main_start()}),
 	       "PL_curpad = AvARRAY($curpad_sym);",
+	       "PL_initav = $init_av;",
                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
-
+    warn "Writing output\n";
     output_boilerplate();
     print "\n";
     output_all("perl_init");
@@ -1139,7 +1165,7 @@ sub init_sections {
 		    xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
 		    xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
 		    xrv => \$xrvsect, xpvbm => \$xpvbmsect,
-		    xpvio => \$xpviosect);
+		    xpvio => \$xpviosect, bootstrap => \$bootstrap);
     my ($name, $sectref);
     while (($name, $sectref) = splice(@sections, 0, 2)) {
 	$$sectref = new B::Section $name, \%symtable, 0;
diff --git a/ext/B/B/Disassembler.pm b/ext/B/B/Disassembler.pm
index f26441d2d0..4a008a3750 100644
--- a/ext/B/B/Disassembler.pm
+++ b/ext/B/B/Disassembler.pm
@@ -77,7 +77,7 @@ sub GET_PV {
     }
 }
 
-sub GET_comment {
+sub GET_comment_t {
     my $fh = shift;
     my ($str, $c);
     while (defined($c = $fh->getc) && $c ne "\n") {
diff --git a/ext/Devel/Peek/Changes b/ext/Devel/Peek/Changes
new file mode 100644
index 0000000000..e143f878cf
--- /dev/null
+++ b/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/ext/Devel/Peek/Makefile.PL b/ext/Devel/Peek/Makefile.PL
new file mode 100644
index 0000000000..3563ef2e84
--- /dev/null
+++ b/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/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm
new file mode 100644
index 0000000000..026c97651a
--- /dev/null
+++ b/ext/Devel/Peek/Peek.pm
@@ -0,0 +1,430 @@
+# Devel::Peek - A data debugging tool for the XS programmer
+# The documentation is after the __END__
+
+package Devel::Peek;
+
+$VERSION = $VERSION = 0.95;
+
+require Exporter;
+require DynaLoader;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg);
+@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec);
+%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]);
+
+bootstrap 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.
+
+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 'Dump';
+        $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 'Dump';
+        $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 'Dump';
+        $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 'Dump';
+        $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 'Dump';
+        $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 'Dump';
+        $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 'Dump';
+        $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"
+	  FILEGV = 0x1fab74     "_<(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).
+
+=over
+
+=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/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs
new file mode 100644
index 0000000000..d193e312dd
--- /dev/null
+++ b/ext/Devel/Peek/Peek.xs
@@ -0,0 +1,202 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef PURIFY
+#define DeadCode() NULL
+#else
+SV *
+DeadCode()
+{
+    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(PerlIO_stderr(), "  no root?!\n"); */
+		    continue;		/* autoloading stub. */
+		}
+		do_gvgv_dump(0, PerlIO_stderr(), "GVGV::GV", CvGV(sv));
+		if (CvDEPTH(cv)) {
+		    PerlIO_printf(PerlIO_stderr(), "  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(PerlIO_stderr(), "    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(PerlIO_stderr(), "     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, PerlIO_stderr(), 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, PerlIO_stderr(), 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(PerlIO_stderr(), "    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, PerlIO_stderr(), (SV*)cv, 0, 2, 0, 0);
+		}
+		if (AvFILL(padlist) > 1) {
+		    PerlIO_printf(PerlIO_stderr(), "  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(PerlIO_stderr(), "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)
+#   define mstat(str) dump_mstats(str)
+#else
+#   define mstat(str) \
+	PerlIO_printf(PerlIO_stderr(), "%s: perl not compiled with DEBUGGING_MSTATS\n",str);
+#endif
+
+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, PerlIO_stderr(), sv, 0, 4, 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(PerlIO_stderr(), "Elt No. %ld  0x%lx\n", i - 1, ST(i));
+	do_sv_dump(0, PerlIO_stderr(), 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()