document Git_Data

[perl5.git] / lib / CPAN / Debug.pm

diff --git a/lib/CPAN/Debug.pm b/lib/CPAN/Debug.pm
index a560630..926b0d7 100644 (file)
--- a/lib/CPAN/Debug.pm
+++ b/lib/CPAN/Debug.pm
@@ -1,8 +1,9 @@
+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
 package CPAN::Debug;
 use strict;
 use vars qw($VERSION);
 
-$VERSION = sprintf "%.2f", substr(q$Rev: 299 $,4)/100;
+$VERSION = "5.5";
 # module is internal to CPAN.pm
 
 %CPAN::DEBUG = qw[
@@ -22,6 +23,7 @@ $VERSION = sprintf "%.2f", substr(q$Rev: 299 $,4)/100;
                   Tarzip         8192
                   Version       16384
                   Queue         32768
+                  FirstTime     65536
 ];
 
 $CPAN::DEBUG ||= 0;
@@ -29,15 +31,24 @@ $CPAN::DEBUG ||= 0;
 #-> sub CPAN::Debug::debug ;
 sub debug {
     my($self,$arg) = @_;
-    my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
-                                               # Complete, caller(1)
-                                               # eg readline
-    ($caller) = caller(0);
-    $caller =~ s/.*:://;
-    $arg = "" unless defined $arg;
-    pop @rest while @rest > 5;
-    my $rest = join ",", map { defined $_ ? $_ : "UNDEF" } @rest;
-    if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
+
+    my @caller;
+    my $i = 0;
+    while () {
+        my(@c) = (caller($i))[0 .. ($i ? 3 : 2)];
+        last unless defined $c[0];
+        push @caller, \@c;
+        for (0,3) {
+            last if $_ > $#c;
+            $c[$_] =~ s/.*:://;
+        }
+        for (1) {
+            $c[$_] =~ s|.*/||;
+        }
+        last if ++$i>=3;
+    }
+    pop @caller;
+    if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) {
         if ($arg and ref $arg) {
             eval { require Data::Dumper };
             if ($@) {
@@ -46,9 +57,23 @@ sub debug {
                 $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
             }
         } else {
-            $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
+            my $outer = "";
+            local $" = ",";
+            if (@caller>1) {
+                $outer = ",[@{$caller[1]}]";
+            }
+            $CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
         }
     }
 }
 
 1;
+
+__END__
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut