This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
patch to provide more informative names for evals and anonymous
authorGurusamy Sarathy <gsar@cpan.org>
Fri, 4 Feb 2000 05:51:14 +0000 (05:51 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Fri, 4 Feb 2000 05:51:14 +0000 (05:51 +0000)
subroutines (from Ilya Zakharevich)

p4raw-id: //depot/perl@4975

ext/Devel/Peek/Peek.pm
ext/Devel/Peek/Peek.xs
lib/Dumpvalue.pm
lib/dumpvar.pl
lib/perl5db.pl
op.c
perl.h
pod/perldebug.pod
pod/perlvar.pod
pp_ctl.c

index 38251c6..080251b 100644 (file)
@@ -4,14 +4,14 @@
 package Devel::Peek;
 
 # Underscore to allow older Perls to access older version from CPAN
-$VERSION = '1.00_00';
+$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);
+@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV);
 %EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]);
 
 XSLoader::load 'Devel::Peek';
index d2f66c4..8af8847 100644 (file)
@@ -125,6 +125,10 @@ DeadCode(pTHX)
        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)      \
+        ? (SV*)CvGV((CV*)SvRV(cv)) : &PL_sv_undef)
+
 MODULE = Devel::Peek           PACKAGE = Devel::Peek
 
 void
@@ -206,3 +210,9 @@ CODE:
     RETVAL = DeadCode(aTHX);
 OUTPUT:
     RETVAL
+
+MODULE = Devel::Peek           PACKAGE = Devel::Peek   PREFIX = _
+
+SV *
+_CvGV(cv)
+    SV *cv
index 33f6793..94b6aa6 100644 (file)
@@ -347,16 +347,30 @@ sub dumpglob {
   }
 }
 
+sub CvGV_name {
+  my $self = shift;
+  my $in = shift;
+  return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
+  $in = \&$in;                 # Hard reference...
+  eval {require Devel::Peek; 1} or return;
+  my $gv = Devel::Peek::CvGV($in) or return;
+  *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
 sub dumpsub {
   my $self = shift;
   my ($off,$sub) = @_;
+  my $ini = $sub;
+  my $s;
   $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
-  my $subref = \&$sub;
-  my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
-    || ($self->{subdump} && ($sub = $self->findsubs("$subref"))
-       && $DB::sub{$sub});
+  my $subref = defined $1 ? \&$sub : \&$ini;
+  my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+    || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
+    || ($self->{subdump} && ($s = $self->findsubs("$subref"))
+       && $DB::sub{$s});
+  $s = $sub unless defined $s;
   $place = '???' unless defined $place;
-  print( (' ' x $off) .  "&$sub in $place\n" );
+  print( (' ' x $off) .  "&$s in $place\n" );
 }
 
 sub findsubs {
index f473c45..c727818 100644 (file)
@@ -312,14 +312,27 @@ sub dumpglob {
     }
 }
 
+sub CvGV_name_or_bust {
+  my $in = shift;
+  return if $skipCvGV;         # Backdoor to avoid problems if XS broken...
+  $in = \&$in;                 # Hard reference...
+  eval {require Devel::Peek; 1} or return;
+  my $gv = Devel::Peek::CvGV($in) or return;
+  *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
 sub dumpsub {
     my ($off,$sub) = @_;
+    my $ini = $sub;
+    my $s;
     $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
-    my $subref = \&$sub;
-    my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
-      || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
+    my $subref = defined $1 ? \&$sub : \&$ini;
+    my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
+      || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s})
+      || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s});
     $place = '???' unless defined $place;
-    print( (' ' x $off) .  "&$sub in $place\n" );
+    $s = $sub unless defined $s;
+    print( (' ' x $off) .  "&$s in $place\n" );
 }
 
 sub findsubs {
index aff5c68..de75bd7 100644 (file)
@@ -2,7 +2,7 @@ package DB;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
 
-$VERSION = 1.04041;
+$VERSION = 1.05;
 $header = "perl5db.pl version $VERSION";
 
 # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
@@ -597,13 +597,21 @@ EOP
                          }
                      };
                    $cmd =~ s/^l\s+-\s*$/-/;
-                   $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
+                   $cmd =~ /^([lb])\b\s*(\$.*)/s && do {
+                       $evalarg = $2;
+                       my ($s) = &eval;
+                       print($OUT "Error: $@\n"), next CMD if $@;
+                       $s = CvGV_name($s);
+                       print($OUT "Interpreted as: $1 $s\n");
+                       $cmd = "$1 $s";
+                   };
+                   $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do {
                        $subname = $1;
                        $subname =~ s/\'/::/;
                        $subname = $package."::".$subname 
                          unless $subname =~ /::/;
                        $subname = "main".$subname if substr($subname,0,2) eq "::";
-                       @pieces = split(/:/,find_sub($subname));
+                       @pieces = split(/:/,find_sub($subname) || $sub{$subname});
                        $subrange = pop @pieces;
                        $file = join(':', @pieces);
                        if ($file ne $filename) {
@@ -784,7 +792,7 @@ EOP
                        $postponed{$subname} = $break 
                          ? "break +0 if $cond" : "compile";
                        next CMD; };
-                   $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
+                   $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
                        $subname = $1;
                        $cond = $2 || '1';
                        $subname =~ s/\'/::/;
@@ -1813,6 +1821,7 @@ B<l> I<min>B<+>I<incr>    List I<incr>+1 lines starting at I<min>.
 B<l> I<min>B<->I<max>  List lines I<min> through I<max>.
 B<l> I<line>           List single I<line>.
 B<l> I<subname>        List first window of lines from subroutine.
+B<l> I<$var>   List first window of lines from subroutine referenced by I<$var>.
 B<l>           List next window of lines.
 B<->           List previous window of lines.
 B<w> [I<line>] List window around I<line>.
@@ -1835,6 +1844,7 @@ B<b> [I<line>] [I<condition>]
                I<condition> breaks if it evaluates to true, defaults to '1'.
 B<b> I<subname> [I<condition>]
                Set breakpoint at first line of subroutine.
+B<b> I<$var>   Set breakpoint at first line of subroutine referenced by I<$var>.
 B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
 B<b> B<postpone> I<subname> [I<condition>]
                Set breakpoint at first line of subroutine after 
@@ -2063,10 +2073,31 @@ sub signalLevel {
   $signalLevel;
 }
 
+sub CvGV_name {
+  my $in = shift;
+  my $name = CvGV_name_or_bust($in);
+  defined $name ? $name : $in;
+}
+
+sub CvGV_name_or_bust {
+  my $in = shift;
+  return if $skipCvGV;         # Backdoor to avoid problems if XS broken...
+  $in = \&$in;                 # Hard reference...
+  eval {require Devel::Peek; 1} or return;
+  my $gv = Devel::Peek::CvGV($in) or return;
+  *$gv{PACKAGE} . '::' . *$gv{NAME};
+}
+
 sub find_sub {
   my $subr = shift;
-  return unless defined &$subr;
   $sub{$subr} or do {
+    return unless defined &$subr;
+    my $name = CvGV_name_or_bust($subr);
+    my $data;
+    $data = $sub{$name} if defined $name;
+    return $data if defined $data;
+
+    # Old stupid way...
     $subr = \&$subr;           # Hard reference
     my $s;
     for (keys %sub) {
diff --git a/op.c b/op.c
index 456d786..fb696a7 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4305,14 +4305,26 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 {
     dTHR;
     STRLEN n_a;
-    char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
-    GV *gv = gv_fetchpv(name ? name : "__ANON__",
-                       GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
-                       SVt_PVCV);
+    char *name;
+    char *aname;
+    GV *gv;
     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
     register CV *cv=0;
     I32 ix;
 
+    name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+    if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
+       SV *sv = sv_newmortal();
+       Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
+                      CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+       aname = SvPVX(sv);
+    }
+    else
+       aname = Nullch;
+    gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
+                   GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+                   SVt_PVCV);
+
     if (o)
        SAVEFREEOP(o);
     if (proto)
@@ -4364,7 +4376,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                                        && !(CvGV(cv) && GvSTASH(CvGV(cv))
                                        && HvNAME(GvSTASH(CvGV(cv)))
                                        && strEQ(HvNAME(GvSTASH(CvGV(cv))),
-                                                "autouse"))) {
+                                                "autouse")))
+           {
                line_t oldline = CopLINE(PL_curcop);
                CopLINE_set(PL_curcop, PL_copline);
                Perl_warner(aTHX_ WARN_REDEFINE,
@@ -4519,15 +4532,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
     }
 
-    if (name) {
+    if (name || aname) {
        char *s;
+       char *tname = (name ? name : aname);
 
        if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
            SV *sv = NEWSV(0,0);
            SV *tmpstr = sv_newmortal();
            GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
-           CV *cv;
+           CV *pcv;
            HV *hv;
+           char *t;
 
            Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
                           CopFILE(PL_curcop),
@@ -4536,19 +4551,20 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
            hv = GvHVn(db_postponed);
            if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
-                 && (cv = GvCV(db_postponed))) {
+               && (pcv = GvCV(db_postponed)))
+           {
                dSP;
                PUSHMARK(SP);
                XPUSHs(tmpstr);
                PUTBACK;
-               call_sv((SV*)cv, G_DISCARD);
+               call_sv((SV*)pcv, G_DISCARD);
            }
        }
 
-       if ((s = strrchr(name,':')))
+       if ((s = strrchr(tname,':')))
            s++;
        else
-           s = name;
+           s = tname;
 
        if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
            goto done;
diff --git a/perl.h b/perl.h
index d89f3a8..5b5bb2f 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2952,16 +2952,22 @@ typedef struct am_table_short AMTS;
 #   endif
 #endif /* _FASTMATH */
 
-#define PERLDB_ALL     0x3f            /* No _NONAME, _GOTO */
-#define PERLDBf_SUB    0x01            /* Debug sub enter/exit. */
-#define PERLDBf_LINE   0x02            /* Keep line #. */
-#define PERLDBf_NOOPT  0x04            /* Switch off optimizations. */
-#define PERLDBf_INTER  0x08            /* Preserve more data for
-                                          later inspections.  */
-#define PERLDBf_SUBLINE        0x10            /* Keep subr source lines. */
-#define PERLDBf_SINGLE 0x20            /* Start with single-step on. */
-#define PERLDBf_NONAME 0x40            /* For _SUB: no name of the subr. */
-#define PERLDBf_GOTO   0x80            /* Report goto: call DB::goto. */
+#define PERLDB_ALL             (PERLDBf_SUB    | PERLDBf_LINE  |       \
+                                PERLDBf_NOOPT  | PERLDBf_INTER |       \
+                                PERLDBf_SUBLINE| PERLDBf_SINGLE|       \
+                                PERLDBf_NAMEEVAL| PERLDBf_NAMEANON)
+                                       /* No _NONAME, _GOTO */
+#define PERLDBf_SUB            0x01    /* Debug sub enter/exit */
+#define PERLDBf_LINE           0x02    /* Keep line # */
+#define PERLDBf_NOOPT          0x04    /* Switch off optimizations */
+#define PERLDBf_INTER          0x08    /* Preserve more data for
+                                          later inspections  */
+#define PERLDBf_SUBLINE                0x10    /* Keep subr source lines */
+#define PERLDBf_SINGLE         0x20    /* Start with single-step on */
+#define PERLDBf_NONAME         0x40    /* For _SUB: no name of the subr */
+#define PERLDBf_GOTO           0x80    /* Report goto: call DB::goto */
+#define PERLDBf_NAMEEVAL       0x100   /* Informative names for evals */
+#define PERLDBf_NAMEANON       0x200   /* Informative names for anon subs */
 
 #define PERLDB_SUB     (PL_perldb && (PL_perldb & PERLDBf_SUB))
 #define PERLDB_LINE    (PL_perldb && (PL_perldb & PERLDBf_LINE))
@@ -2971,6 +2977,8 @@ typedef struct am_table_short AMTS;
 #define PERLDB_SINGLE  (PL_perldb && (PL_perldb & PERLDBf_SINGLE))
 #define PERLDB_SUB_NN  (PL_perldb && (PL_perldb & (PERLDBf_NONAME)))
 #define PERLDB_GOTO    (PL_perldb && (PL_perldb & PERLDBf_GOTO))
+#define PERLDB_NAMEEVAL        (PL_perldb && (PL_perldb & PERLDBf_NAMEEVAL))
+#define PERLDB_NAMEANON        (PL_perldb && (PL_perldb & PERLDBf_NAMEANON))
 
 
 #ifdef USE_LOCALE_NUMERIC
index 65a07e2..1c94f5f 100644 (file)
@@ -153,7 +153,8 @@ List a single line.
 
 =item l subname
 
-List first window of lines from subroutine.
+List first window of lines from subroutine.  I<subname> may
+be a variable which contains a code reference.
 
 =item -
 
@@ -251,7 +252,9 @@ that begin an executable statement.  Conditions don't use B<if>:
 
 =item b subname [condition]
 
-Set a breakpoint at the first line of the named subroutine.
+Set a breakpoint at the first line of the named subroutine.  I<subname> may
+be a variable which contains a code reference (in this case I<condition>
+is not supported).
 
 =item b postpone subname [condition]
 
index 3393fd9..dca9cc0 100644 (file)
@@ -832,6 +832,23 @@ Keep info about source lines on which a subroutine is defined.
 
 Start with single-step on.
 
+=item 0x40
+
+Use subroutine address instead of name when reporting.
+
+=item 0x80
+
+Report C<goto &subroutine> as well.
+
+=item 0x100
+
+Provide informative "file" names for evals based on the place they were compiled.
+
+=item 0x200
+
+Provide informative names to anonymous subroutines based on the place they
+were compiled.
+
 =back
 
 Some bits may be relevant at compile-time only, some at
index 716be5e..8eb02b7 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2570,7 +2570,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     I32 optype;
     OP dummy;
     OP *oop = PL_op, *rop;
-    char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
+    char tbuf[TYPE_DIGITS(long) + 12 + 10];
+    char *tmpbuf = tbuf;
     char *safestr;
 
     ENTER;
@@ -2584,7 +2585,15 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     }
     SAVECOPFILE(&PL_compiling);
     SAVECOPLINE(&PL_compiling);
-    sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
+    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
+       SV *sv = sv_newmortal();
+       Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
+                      code, (unsigned long)++PL_evalseq,
+                      CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+       tmpbuf = SvPVX(sv);
+    }
+    else
+       sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     CopLINE_set(&PL_compiling, 1);
     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
@@ -3155,7 +3164,8 @@ PP(pp_entereval)
     register PERL_CONTEXT *cx;
     dPOPss;
     I32 gimme = GIMME_V, was = PL_sub_generation;
-    char tmpbuf[TYPE_DIGITS(long) + 12];
+    char tbuf[TYPE_DIGITS(long) + 12];
+    char *tmpbuf = tbuf;
     char *safestr;
     STRLEN len;
     OP *ret;
@@ -3171,7 +3181,15 @@ PP(pp_entereval)
     /* switch to eval mode */
 
     SAVECOPFILE(&PL_compiling);
-    sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+    if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
+       SV *sv = sv_newmortal();
+       Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
+                      (unsigned long)++PL_evalseq,
+                      CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+       tmpbuf = SvPVX(sv);
+    }
+    else
+       sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
     CopFILE_set(&PL_compiling, tmpbuf+2);
     CopLINE_set(&PL_compiling, 1);
     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up