r29646 - in /trunk/libdata-dump-perl: Changes META.yml debian/changelog lib/Data/Dump.pm lib/Data/Dump/Trace.pm

ansgar-guest at users.alioth.debian.org ansgar-guest at users.alioth.debian.org
Tue Jan 13 17:16:55 UTC 2009


Author: ansgar-guest
Date: Tue Jan 13 17:16:52 2009
New Revision: 29646

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=29646
Log:
New upstream release.

Modified:
    trunk/libdata-dump-perl/Changes
    trunk/libdata-dump-perl/META.yml
    trunk/libdata-dump-perl/debian/changelog
    trunk/libdata-dump-perl/lib/Data/Dump.pm
    trunk/libdata-dump-perl/lib/Data/Dump/Trace.pm

Modified: trunk/libdata-dump-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/Changes?rev=29646&op=diff
==============================================================================
--- trunk/libdata-dump-perl/Changes (original)
+++ trunk/libdata-dump-perl/Changes Tue Jan 13 17:16:52 2009
@@ -1,3 +1,13 @@
+2009-01-12  Gisle Aas <gisle at ActiveState.com>
+
+   Release 1.14
+
+   Data::Dump::Trace enhancements:
+      - trace() function
+      - prototypes
+
+
+
 2009-01-02  Gisle Aas <gisle at ActiveState.com>
 
    Release 1.13

Modified: trunk/libdata-dump-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/META.yml?rev=29646&op=diff
==============================================================================
--- trunk/libdata-dump-perl/META.yml (original)
+++ trunk/libdata-dump-perl/META.yml Tue Jan 13 17:16:52 2009
@@ -1,12 +1,18 @@
 --- #YAML:1.0
-name:                Data-Dump
-version:             1.13
-abstract:            ~
-license:             ~
-author:              ~
-generated_by:        ExtUtils::MakeMaker version 6.42_01
-distribution_type:   module
-requires:     
+name:               Data-Dump
+version:            1.14
+abstract:           ~
+author:  []
+license:            unknown
+distribution_type:  module
+configure_requires:
+    ExtUtils::MakeMaker:  0
+requires:  {}
+no_index:
+    directory:
+        - t
+        - inc
+generated_by:       ExtUtils::MakeMaker version 6.4801
 meta-spec:
-    url:     http://module-build.sourceforge.net/META-spec-v1.3.html
-    version: 1.3
+    url:      http://module-build.sourceforge.net/META-spec-v1.4.html
+    version:  1.4

Modified: trunk/libdata-dump-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/debian/changelog?rev=29646&op=diff
==============================================================================
--- trunk/libdata-dump-perl/debian/changelog (original)
+++ trunk/libdata-dump-perl/debian/changelog Tue Jan 13 17:16:52 2009
@@ -1,3 +1,9 @@
+libdata-dump-perl (1.14-1) unstable; urgency=low
+
+  * New upstream release.
+
+ -- Ansgar Burchardt <ansgar at 43-1.org>  Tue, 13 Jan 2009 18:16:38 +0100
+
 libdata-dump-perl (1.13-1) unstable; urgency=low
 
   [ gregor herrmann ]

Modified: trunk/libdata-dump-perl/lib/Data/Dump.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/lib/Data/Dump.pm?rev=29646&op=diff
==============================================================================
--- trunk/libdata-dump-perl/lib/Data/Dump.pm (original)
+++ trunk/libdata-dump-perl/lib/Data/Dump.pm Tue Jan 13 17:16:52 2009
@@ -9,7 +9,7 @@
 @EXPORT = qw(dd ddx);
 @EXPORT_OK = qw(dump pp quote);
 
-$VERSION = "1.13";
+$VERSION = "1.14";
 $DEBUG = 0;
 
 use overload ();

Modified: trunk/libdata-dump-perl/lib/Data/Dump/Trace.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libdata-dump-perl/lib/Data/Dump/Trace.pm?rev=29646&op=diff
==============================================================================
--- trunk/libdata-dump-perl/lib/Data/Dump/Trace.pm (original)
+++ trunk/libdata-dump-perl/lib/Data/Dump/Trace.pm Tue Jan 13 17:16:52 2009
@@ -1,27 +1,22 @@
 package Data::Dump::Trace;
 
-$VERSION = "0.01";
+$VERSION = "0.02";
 
 # Todo:
 #   - prototypes
-#     in/out parameters
-#     key/value style parameters or return values
-#     globals affected ($!)
+#     in/out parameters key/value style
 #   - exception
 #   - wrap class
-#   - autowrap in list return
-#   - don't dump return values
 #   - configurable colors
 #   - show call depth using indentation
+#   - show nested calls sensibly
 #   - time calls
 
 use strict;
 
 use base 'Exporter';
-our @EXPORT_OK = qw(call mcall wrap autowrap);
-
-use Data::Dump qw(dump);
-use Term::ANSIColor qw(YELLOW CYAN RESET);
+our @EXPORT_OK = qw(call mcall wrap autowrap trace);
+
 use Carp qw(croak);
 use overload ();
 
@@ -29,28 +24,19 @@
 my %autowrap_class;
 my %name_count;
 
-sub dumpav {
-    return "(" . dump(@_) . ")" if @_ == 1;
-    return dump(@_);
-}
-
-sub dumpkv {
-    return dumpav(@_) if @_ % 2;
-    my %h = @_;
-    my $str = dump(\%h);
-    $str =~ s/^\{/(/ && $str =~ s/\}\z/)/;
-    return $str;
-}
-
 sub autowrap {
     while (@_) {
         my $class = shift;
-        my $name = shift;
-        unless ($name) {
-            $name = lc($class);
-            $name =~ s/.*:://;
-        }
-        $autowrap_class{$class} = $name;
+        my $info = shift;
+        $info = { prefix => $info } unless ref($info);
+        for ($info->{prefix}) {
+            unless ($_) {
+                $_ = lc($class);
+                s/.*:://;
+            }
+            $_ = '$' . $_ unless /^\$/;
+        }
+        $autowrap_class{$class} = $info;
     }
 }
 
@@ -58,9 +44,10 @@
     my %arg = @_;
     my $name = $arg{name} || "func";
     my $func = $arg{func};
+    my $proto = $arg{proto};
 
     return sub {
-        call($name, $func, undef, @_);
+        call($name, $func, $proto, @_);
     } if $func;
 
     if (my $obj = $arg{obj}) {
@@ -69,26 +56,34 @@
         return bless {
             name => $name,
             obj => $obj,
+            proto => $arg{proto},
         }, "Data::Dump::Trace::Wrapper";
     }
 
     croak("Either the 'func' or 'obj' option must be given");
+}
+
+sub trace {
+    my($symbol, $prototype) = @_;
+    no strict 'refs';
+    no warnings 'redefine';
+    *{$symbol} = wrap(name => $symbol, func => \&{$symbol}, proto => $prototype);
 }
 
 sub call {
     my $name = shift;
     my $func = shift;
     my $proto = shift;
-    print YELLOW, $name, dumpav(@_), RESET;
+    my $fmt = Data::Dump::Trace::Call->new($name, $proto, \@_);
     if (!defined wantarray) {
-        print "\n";
         $func->(@_);
+        return $fmt->return_void(\@_);
     }
     elsif (wantarray) {
-        return _ret_list($func->(@_));
-    }
-    else {
-        return _ret_scalar($func->(@_));
+        return $fmt->return_list(\@_, $func->(@_));
+    }
+    else {
+        return $fmt->return_scalar(\@_, scalar $func->(@_));
     }
 }
 
@@ -96,36 +91,19 @@
     my $o = shift;
     my $method = shift;
     my $proto = shift;
+    return if $method eq "DESTROY" && !$o->can("DESTROY");
     my $oname = ref($o) ? $obj_name{overload::StrVal($o)} || "\$o" : $o;
-    print YELLOW, $oname, "->", $method, @_ ? dumpav(@_) : "", RESET;
+    my $fmt = Data::Dump::Trace::Call->new("$oname->$method", $proto, \@_);
     if (!defined wantarray) {
-        print "\n";
         $o->$method(@_);
+        return $fmt->return_void(\@_);
     }
     elsif (wantarray) {
-        return _ret_list($o->$method(@_));
-    }
-    else {
-        return _ret_scalar($o->$method(@_));
-    }
-}
-
-sub _ret_list {
-    print " ==> ", CYAN, dumpav(@_), RESET, "\n";
-    return @_;
-}
-
-sub _ret_scalar {
-    my $s = shift;
-    if (my $name = $autowrap_class{ref($s)}) {
-        $name .= $name_count{$name} if $name_count{$name}++;
-        print " ==> ", CYAN, $name, RESET, "\n";
-        $s = wrap(name => $name, obj => $s);
-    }
-    else {
-        print " ==> ", CYAN, dump($s), RESET, "\n";
-    }
-    return $s;
+        return $fmt->return_list(\@_, $o->$method(@_));
+    }
+    else {
+        return $fmt->return_scalar(\@_, scalar $o->$method(@_));
+    }
 }
 
 package Data::Dump::Trace::Wrapper;
@@ -134,7 +112,161 @@
     my $self = shift;
     our $AUTOLOAD;
     my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
-    Data::Dump::Trace::mcall($self->{obj}, $method, undef, @_);
+    Data::Dump::Trace::mcall($self->{obj}, $method, $self->{proto}{$method}, @_);
+}
+
+package Data::Dump::Trace::Call;
+
+use Term::ANSIColor ();
+use Data::Dump ();
+
+*_dump = \&Data::Dump::dump;
+
+our %COLOR = (
+    name => "yellow",
+    output => "cyan",
+    error => "red",
+    debug => "red",
+);
+
+%COLOR = () unless -t STDOUT;
+
+sub _dumpav {
+    return "(" . _dump(@_) . ")" if @_ == 1;
+    return _dump(@_);
+}
+
+sub _dumpkv {
+    return _dumpav(@_) if @_ % 2;
+    my %h = @_;
+    my $str = _dump(\%h);
+    $str =~ s/^\{/(/ && $str =~ s/\}\z/)/;
+    return $str;
+}
+
+sub new {
+    my($class, $name, $proto, $input_args) = @_;
+    my $self = bless {
+        name => $name,
+        proto => $proto,
+    }, $class;
+    my $proto_arg = $self->proto_arg;
+    if ($proto_arg =~ /o/) {
+        for (@$input_args) {
+            push(@{$self->{input_av}}, _dump($_));
+        }
+    }
+    else {
+        $self->{input} = $proto_arg eq "%" ? _dumpkv(@$input_args) : _dumpav(@$input_args);
+    }
+    return $self;
+}
+
+sub proto_arg {
+    my $self = shift;
+    my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
+    $arg ||= '@';
+    return $arg;
+}
+
+sub proto_ret {
+    my $self = shift;
+    my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
+    $ret ||= '@';
+    return $ret;
+}
+
+sub color {
+    my($self, $category, $text) = @_;
+    return $text unless $COLOR{$category};
+    return Term::ANSIColor::colored($text, $COLOR{$category});
+}
+
+sub print_call {
+    my $self = shift;
+    my $outarg = shift;
+    print $self->color("name", "$self->{name}");
+    if (my $input = $self->{input}) {
+        $input = "" if $input eq "()" && $self->{name} =~ /->/;
+        print $self->color("input", $input);
+    }
+    else {
+        my $proto_arg = $self->proto_arg;
+        print "(";
+        my $i = 0;
+        for (@{$self->{input_av}}) {
+            print ", " if $i;
+            my $proto = substr($proto_arg, 0, 1, "");
+            if ($proto ne "o") {
+                print $self->color("input", $_);
+            }
+            if ($proto eq "o" || $proto eq "O") {
+                print " = " if $proto eq "O";
+                print $self->color("output", _dump($outarg->[$i]));
+            }
+        }
+        continue {
+            $i++;
+        }
+        print ")";
+    }
+}
+
+sub return_void {
+    my $self = shift;
+    my $arg = shift;
+    $self->print_call($arg);
+    print "\n";
+    return;
+}
+
+sub return_scalar {
+    my $self = shift;
+    my $arg = shift;
+    $self->print_call($arg);
+    my $s = shift;
+    my $name;
+    my $proto_ret = $self->proto_ret;
+    my $wrap = $autowrap_class{ref($s)};
+    if ($proto_ret =~ /^\$\w+\z/ && ref($s) && ref($s) !~ /^(?:ARRAY|HASH|CODE|GLOB)\z/) {
+        $name = $proto_ret;
+    }
+    else {
+        $name = $wrap->{prefix} if $wrap;
+    }
+    if ($name) {
+        $name .= $name_count{$name} if $name_count{$name}++;
+        print " = ", $self->color("output", $name), "\n";
+        $s = Data::Dump::Trace::wrap(name => $name, obj => $s, proto => $wrap->{proto});
+    }
+    else {
+        print " = ", $self->color("output", _dump($s));
+        if (!$s && $proto_ret =~ /!/ && $!) {
+            print " ", $self->color("error", errno($!));
+        }
+        print "\n";
+    }
+    return $s;
+}
+
+sub return_list {
+    my $self = shift;
+    my $arg = shift;
+    $self->print_call($arg);
+    print " = ", $self->color("output", $self->proto_ret eq "%" ? _dumpkv(@_) : _dumpav(@_)), "\n";
+    return @_;
+}
+
+sub errno {
+    my $t = "";
+    for (keys %!) {
+        if ($!{$_}) {
+            $t = $_;
+            last;
+        }
+    }
+    my $n = int($!);
+    return "$t($n) $!";
 }
 
 1;
@@ -167,25 +299,43 @@
 
 =item autowrap( $class1 => $prefix1,  $class2 => $prefix2, ... )
 
+=item autowrap( $class1 => \%info1, $class2 => \%info2, ... )
+
 Register classes whose objects are are automatically wrapped when
 returned by one of the call functions below.  If $prefix is provided
 it will be used as to name the objects.
 
-=item wrap( name => $str, func => \&func )
-
-=item wrap( name => $str, obj => $obj )
+Alternative is to pass an %info hash for each class.  The recognized keys are:
+
+=over
+
+=item prefix => $string
+
+The prefix string used to name objects of this type.
+
+=item proto => \%hash
+
+A hash of prototypes to use for the methods when an object is wrapped.
+
+=back
+
+=item wrap( name => $str, func => \&func, proto => $proto )
+
+=item wrap( name => $str, obj => $obj, proto => \%hash )
 
 Returns a wrapped function or object.  When a wrapped function is
-invoked then a trace is printed as the underlying function is invoked.
+invoked then a trace is printed after the underlying function has returned.
 When a method on a wrapped object is invoked then a trace is printed
-as methods on the underlying objects are invoked.
+after the methods on the underlying objects has returned.
+
+See L</"Prototypes"> for description of the C<proto> argument.
 
 =item call( $name, \&func, $proto, @ARGS )
 
 Calls the given function with the given arguments.  The trace will use
 $name as the name of the function.
 
-The $proto argument is reserved for future extensions.
+See L</"Prototypes"> for description of the $proto argument.
 
 =item mcall( $class, $method, $proto, @ARGS )
 
@@ -193,9 +343,59 @@
 
 Calls the given method with the given arguments.
 
-The $proto argument is reserved for future extensions.
+See L</"Prototypes"> for description of the $proto argument.
+
+=item trace( $symbol, $prototype )
+
+Replaces the function given by $symbol with a wrapped function.
 
 =back
+
+=head2 Prototypes
+
+B<Note: The prototype string syntax described here is experimental and
+likely to change in revisions of this interface>.
+
+The $proto argument to call() and mcall() can optionally provide a
+prototype for the function call.  This give the tracer hints about how
+to best format the argument lists and if there are I<in/out> or I<out>
+arguments.  The general form for the prototype string is:
+
+   <arguments> = <return_value>
+
+The default prototype is "@ = @"; list of values as input and list of
+values as output.
+
+The value '%' can be used for both arguments and return value to say
+that key/value pair style lists are used.
+
+Alternatively, individual positional arguments can be listed each
+represented by a letter:
+
+=over
+
+=item C<i>
+
+input argument
+
+=item C<o>
+
+output argument
+
+=item C<O>
+
+both input and output argument
+
+=back
+
+If the return value prototype has C<!> appended, then it signals that
+this function sets errno ($!) when it returns a false value.  The
+trace will display the current value of errno in that case.
+
+If the return value prototype looks like a variable name (with C<$>
+prefix), and the function returns a blessed object, then the variable
+name will be used as prefix and the returned object automatically
+traced.
 
 =head1 SEE ALSO
 




More information about the Pkg-perl-cvs-commits mailing list