Initial Commit

database/perl/lib/Data/Dump/FilterContext.pm

@@ -0,0 +1,94 @@
+package Data::Dump::FilterContext;
+
+sub new {
+    my($class, $obj, $oclass, $type, $ref, $pclass, $pidx, $idx) = @_;
+    return bless {
+	object => $obj,
+	class => $ref && $oclass,
+	reftype => $type,
+	is_ref => $ref,
+	pclass => $pclass,
+	pidx => $pidx,
+	idx => $idx,
+    }, $class;
+}
+
+sub object_ref {
+    my $self = shift;
+    return $self->{object};
+}
+
+sub class {
+    my $self = shift;
+    return $self->{class} || "";
+}
+
+*is_blessed = \&class;
+
+sub reftype {
+    my $self = shift;
+    return $self->{reftype};
+}
+
+sub is_scalar {
+    my $self = shift;
+    return $self->{reftype} eq "SCALAR";
+}
+
+sub is_array {
+    my $self = shift;
+    return $self->{reftype} eq "ARRAY";
+}
+
+sub is_hash {
+    my $self = shift;
+    return $self->{reftype} eq "HASH";
+}
+
+sub is_code {
+    my $self = shift;
+    return $self->{reftype} eq "CODE";
+}
+
+sub is_ref {
+    my $self = shift;
+    return $self->{is_ref};
+}
+
+sub container_class {
+    my $self = shift;
+    return $self->{pclass} || "";
+}
+
+sub container_self {
+    my $self = shift;
+    return "" unless $self->{pclass};
+    my $idx = $self->{idx};
+    my $pidx = $self->{pidx};
+    return Data::Dump::fullname("self", [@$idx[$pidx..(@$idx - 1)]]);
+}
+
+sub expr {
+    my $self = shift;
+    my $top = shift || "var";
+    $top =~ s/^\$//; # it's always added by fullname()
+    my $idx = $self->{idx};
+    return Data::Dump::fullname($top, $idx);
+}
+
+sub object_isa {
+    my($self, $class) = @_;
+    return $self->{class} && $self->{class}->isa($class);
+}
+
+sub container_isa {
+    my($self, $class) = @_;
+    return $self->{pclass} && $self->{pclass}->isa($class);
+}
+
+sub depth {
+    my $self = shift;
+    return scalar @{$self->{idx}};
+}
+
+1;

database/perl/lib/Data/Dump/Filtered.pm

@@ -0,0 +1,208 @@
+package Data::Dump::Filtered;
+
+use Data::Dump ();
+use Carp ();
+
+use base 'Exporter';
+our @EXPORT_OK = qw(add_dump_filter remove_dump_filter dump_filtered);
+
+sub add_dump_filter {
+    my $filter = shift;
+    unless (ref($filter) eq "CODE") {
+	Carp::croak("add_dump_filter argument must be a code reference");
+    }
+    push(@Data::Dump::FILTERS, $filter);
+    return $filter;
+}
+
+sub remove_dump_filter {
+    my $filter = shift;
+    @Data::Dump::FILTERS = grep $_ ne $filter, @Data::Dump::FILTERS;
+}
+
+sub dump_filtered {
+    my $filter = pop;
+    if (defined($filter) && ref($filter) ne "CODE") {
+	Carp::croak("Last argument to dump_filtered must be undef or a code reference");
+    }
+    local @Data::Dump::FILTERS = ($filter ? $filter : ());
+    return &Data::Dump::dump;
+}
+
+1;
+
+=head1 NAME
+
+Data::Dump::Filtered - Pretty printing with filtering
+
+=head1 DESCRIPTION
+
+The following functions are provided:
+
+=over
+
+=item add_dump_filter( \&filter )
+
+This registers a filter function to be used by the regular Data::Dump::dump()
+function.  By default no filters are active.
+
+Since registering filters has a global effect is might be more appropriate
+to use the dump_filtered() function instead.
+
+=item remove_dump_filter( \&filter )
+
+Unregister the given callback function as filter callback.
+This undoes the effect of L<add_filter>.
+
+=item dump_filtered(..., \&filter )
+
+Works like Data::Dump::dump(), but the last argument should
+be a filter callback function.  As objects are visited the
+filter callback is invoked at it might influence how objects are dumped.
+
+Any filters registered with L<add_filter()> are ignored when
+this interface is invoked.  Actually, passing C<undef> as \&filter
+is allowed and C<< dump_filtered(..., undef) >> is the official way to
+force unfiltered dumps.
+
+=back
+
+=head2 Filter callback
+
+A filter callback is a function that will be invoked with 2 arguments;
+a context object and reference to the object currently visited.  The return
+value should either be a hash reference or C<undef>.
+
+    sub filter_callback {
+        my($ctx, $object_ref) = @_;
+	...
+	return { ... }
+    }
+
+If the filter callback returns C<undef> (or nothing) then normal
+processing and formatting of the visited object happens.
+If the filter callback returns a hash it might replace
+or annotate the representation of the current object.
+
+=head2 Filter context
+
+The context object provide methods that can be used to determine what kind of
+object is currently visited and where it's located.  The context object has the
+following interface:
+
+=over
+
+=item $ctx->object_ref
+
+Alternative way to obtain a reference to the current object
+
+=item $ctx->class
+
+If the object is blessed this return the class.  Returns ""
+for objects not blessed.
+
+=item $ctx->reftype
+
+Returns what kind of object this is.  It's a string like "SCALAR",
+"ARRAY", "HASH", "CODE",...
+
+=item $ctx->is_ref
+
+Returns true if a reference was provided.
+
+=item $ctx->is_blessed
+
+Returns true if the object is blessed.  Actually, this is just an alias
+for C<< $ctx->class >>.
+
+=item $ctx->is_array
+
+Returns true if the object is an array
+
+=item $ctx->is_hash
+
+Returns true if the object is a hash
+
+=item $ctx->is_scalar
+
+Returns true if the object is a scalar (a string or a number)
+
+=item $ctx->is_code
+
+Returns true if the object is a function (aka subroutine)
+
+=item $ctx->container_class
+
+Returns the class of the innermost container that contains this object.
+Returns "" if there is no blessed container.
+
+=item $ctx->container_self
+
+Returns an textual expression relative to the container object that names this
+object.  The variable C<$self> in this expression is the container itself.
+
+=item $ctx->object_isa( $class )
+
+Returns TRUE if the current object is of the given class or is of a subclass.
+
+=item $ctx->container_isa( $class )
+
+Returns TRUE if the innermost container is of the given class or is of a
+subclass.
+
+=item $ctx->depth
+
+Returns how many levels deep have we recursed into the structure (from the
+original dump_filtered() arguments).
+
+=item $ctx->expr
+
+=item $ctx->expr( $top_level_name )
+
+Returns an textual expression that denotes the current object.  In the
+expression C<$var> is used as the name of the top level object dumped.  This
+can be overridden by providing a different name as argument.
+
+=back
+
+=head2 Filter return hash
+
+The following elements has significance in the returned hash:
+
+=over
+
+=item dump => $string
+
+incorporate the given string as the representation for the
+current value
+
+=item object => $value
+
+dump the given value instead of the one visited and passed in as $object.
+Basically the same as specifying C<< dump => Data::Dump::dump($value) >>.
+
+=item comment => $comment
+
+prefix the value with the given comment string
+
+=item bless => $class
+
+make it look as if the current object is of the given $class
+instead of the class it really has (if any).  The internals of the object
+is dumped in the regular way.  The $class can be the empty string
+to make Data::Dump pretend the object wasn't blessed at all.
+
+=item hide_keys => ['key1', 'key2',...]
+
+=item hide_keys => \&code
+
+If the $object is a hash dump is as normal but pretend that the
+listed keys did not exist.  If the argument is a function then
+the function is called to determine if the given key should be
+hidden.
+
+=back
+
+=head1 SEE ALSO
+
+L<Data::Dump>

database/perl/lib/Data/Dump/Trace.pm

@@ -0,0 +1,411 @@
+package Data::Dump::Trace;
+
+$VERSION = "0.02";
+
+# Todo:
+#   - prototypes
+#     in/out parameters key/value style
+#   - exception
+#   - wrap class
+#   - 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 trace);
+
+use Carp qw(croak);
+use overload ();
+
+my %obj_name;
+my %autowrap_class;
+my %name_count;
+
+sub autowrap {
+    while (@_) {
+        my $class = shift;
+        my $info = shift;
+        $info = { prefix => $info } unless ref($info);
+        for ($info->{prefix}) {
+            unless ($_) {
+                $_ = lc($class);
+                s/.*:://;
+            }
+            $_ = '$' . $_ unless /^\$/;
+        }
+        $autowrap_class{$class} = $info;
+    }
+}
+
+sub wrap {
+    my %arg = @_;
+    my $name = $arg{name} || "func";
+    my $func = $arg{func};
+    my $proto = $arg{proto};
+
+    return sub {
+        call($name, $func, $proto, @_);
+    } if $func;
+
+    if (my $obj = $arg{obj}) {
+        $name = '$' . $name unless $name =~ /^\$/;
+        $obj_name{overload::StrVal($obj)} = $name;
+        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;
+    my $fmt = Data::Dump::Trace::Call->new($name, $proto, \@_);
+    if (!defined wantarray) {
+        $func->(@_);
+        return $fmt->return_void(\@_);
+    }
+    elsif (wantarray) {
+        return $fmt->return_list(\@_, $func->(@_));
+    }
+    else {
+        return $fmt->return_scalar(\@_, scalar $func->(@_));
+    }
+}
+
+sub mcall {
+    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;
+    my $fmt = Data::Dump::Trace::Call->new("$oname->$method", $proto, \@_);
+    if (!defined wantarray) {
+        $o->$method(@_);
+        return $fmt->return_void(\@_);
+    }
+    elsif (wantarray) {
+        return $fmt->return_list(\@_, $o->$method(@_));
+    }
+    else {
+        return $fmt->return_scalar(\@_, scalar $o->$method(@_));
+    }
+}
+
+package Data::Dump::Trace::Wrapper;
+
+sub AUTOLOAD {
+    my $self = shift;
+    our $AUTOLOAD;
+    my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+    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;
+
+__END__
+
+=head1 NAME
+
+Data::Dump::Trace - Helpers to trace function and method calls
+
+=head1 SYNOPSIS
+
+  use Data::Dump::Trace qw(autowrap mcall);
+
+  autowrap("LWP::UserAgent" => "ua", "HTTP::Response" => "res");
+
+  use LWP::UserAgent;
+  $ua = mcall(LWP::UserAgent => "new");      # instead of LWP::UserAgent->new;
+  $ua->get("http://www.example.com")->dump;
+
+=head1 DESCRIPTION
+
+The following functions are provided:
+
+=over
+
+=item autowrap( $class )
+
+=item autowrap( $class => $prefix )
+
+=item autowrap( $class1 => $prefix1,  $class2 => $prefix2, ... )
+
+=item autowrap( $class1 => \%info1, $class2 => \%info2, ... )
+
+Register classes whose objects 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.
+
+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 after the underlying function has returned.
+When a method on a wrapped object is invoked then a trace is printed
+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.
+
+See L</"Prototypes"> for description of the $proto argument.
+
+=item mcall( $class, $method, $proto, @ARGS )
+
+=item mcall( $object, $method, $proto, @ARGS )
+
+Calls the given method with the given arguments.
+
+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
+
+L<Data::Dump>
+
+=head1 AUTHOR
+
+Copyright 2009 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut