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