local-lib5/lib/perl5/Data/Dump/Trace.pm

   1 package Data::Dump::Trace;
   2
   3 $VERSION = "0.02";
   4
   5 # Todo:
   6 #   - prototypes
   7 #     in/out parameters key/value style
   8 #   - exception
   9 #   - wrap class
  10 #   - configurable colors
  11 #   - show call depth using indentation
  12 #   - show nested calls sensibly
  13 #   - time calls
  14
  15 use strict;
  16
  17 use base 'Exporter';
  18 our @EXPORT_OK = qw(call mcall wrap autowrap trace);
  19
  20 use Carp qw(croak);
  21 use overload ();
  22
  23 my %obj_name;
  24 my %autowrap_class;
  25 my %name_count;
  26
  27 sub autowrap {
  28     while (@_) {
  29         my $class = shift;
  30         my $info = shift;
  31         $info = { prefix => $info } unless ref($info);
  32         for ($info->{prefix}) {
  33             unless ($_) {
  34                 $_ = lc($class);
  35                 s/.*:://;
  36             }
  37             $_ = '$' . $_ unless /^\$/;
  38         }
  39         $autowrap_class{$class} = $info;
  40     }
  41 }
  42
  43 sub wrap {
  44     my %arg = @_;
  45     my $name = $arg{name} || "func";
  46     my $func = $arg{func};
  47     my $proto = $arg{proto};
  48
  49     return sub {
  50         call($name, $func, $proto, @_);
  51     } if $func;
  52
  53     if (my $obj = $arg{obj}) {
  54         $name = '$' . $name unless $name =~ /^\$/;
  55         $obj_name{overload::StrVal($obj)} = $name;
  56         return bless {
  57             name => $name,
  58             obj => $obj,
  59             proto => $arg{proto},
  60         }, "Data::Dump::Trace::Wrapper";
  61     }
  62
  63     croak("Either the 'func' or 'obj' option must be given");
  64 }
  65
  66 sub trace {
  67     my($symbol, $prototype) = @_;
  68     no strict 'refs';
  69     no warnings 'redefine';
  70     *{$symbol} = wrap(name => $symbol, func => \&{$symbol}, proto => $prototype);
  71 }
  72
  73 sub call {
  74     my $name = shift;
  75     my $func = shift;
  76     my $proto = shift;
  77     my $fmt = Data::Dump::Trace::Call->new($name, $proto, \@_);
  78     if (!defined wantarray) {
  79         $func->(@_);
  80         return $fmt->return_void(\@_);
  81     }
  82     elsif (wantarray) {
  83         return $fmt->return_list(\@_, $func->(@_));
  84     }
  85     else {
  86         return $fmt->return_scalar(\@_, scalar $func->(@_));
  87     }
  88 }
  89
  90 sub mcall {
  91     my $o = shift;
  92     my $method = shift;
  93     my $proto = shift;
  94     return if $method eq "DESTROY" && !$o->can("DESTROY");
  95     my $oname = ref($o) ? $obj_name{overload::StrVal($o)} || "\$o" : $o;
  96     my $fmt = Data::Dump::Trace::Call->new("$oname->$method", $proto, \@_);
  97     if (!defined wantarray) {
  98         $o->$method(@_);
  99         return $fmt->return_void(\@_);
 100     }
 101     elsif (wantarray) {
 102         return $fmt->return_list(\@_, $o->$method(@_));
 103     }
 104     else {
 105         return $fmt->return_scalar(\@_, scalar $o->$method(@_));
 106     }
 107 }
 108
 109 package Data::Dump::Trace::Wrapper;
 110
 111 sub AUTOLOAD {
 112     my $self = shift;
 113     our $AUTOLOAD;
 114     my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
 115     Data::Dump::Trace::mcall($self->{obj}, $method, $self->{proto}{$method}, @_);
 116 }
 117
 118 package Data::Dump::Trace::Call;
 119
 120 use Term::ANSIColor ();
 121 use Data::Dump ();
 122
 123 *_dump = \&Data::Dump::dump;
 124
 125 our %COLOR = (
 126     name => "yellow",
 127     output => "cyan",
 128     error => "red",
 129     debug => "red",
 130 );
 131
 132 %COLOR = () unless -t STDOUT;
 133
 134 sub _dumpav {
 135     return "(" . _dump(@_) . ")" if @_ == 1;
 136     return _dump(@_);
 137 }
 138
 139 sub _dumpkv {
 140     return _dumpav(@_) if @_ % 2;
 141     my %h = @_;
 142     my $str = _dump(\%h);
 143     $str =~ s/^\{/(/ && $str =~ s/\}\z/)/;
 144     return $str;
 145 }
 146
 147 sub new {
 148     my($class, $name, $proto, $input_args) = @_;
 149     my $self = bless {
 150         name => $name,
 151         proto => $proto,
 152     }, $class;
 153     my $proto_arg = $self->proto_arg;
 154     if ($proto_arg =~ /o/) {
 155         for (@$input_args) {
 156             push(@{$self->{input_av}}, _dump($_));
 157         }
 158     }
 159     else {
 160         $self->{input} = $proto_arg eq "%" ? _dumpkv(@$input_args) : _dumpav(@$input_args);
 161     }
 162     return $self;
 163 }
 164
 165 sub proto_arg {
 166     my $self = shift;
 167     my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
 168     $arg ||= '@';
 169     return $arg;
 170 }
 171
 172 sub proto_ret {
 173     my $self = shift;
 174     my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || "");
 175     $ret ||= '@';
 176     return $ret;
 177 }
 178
 179 sub color {
 180     my($self, $category, $text) = @_;
 181     return $text unless $COLOR{$category};
 182     return Term::ANSIColor::colored($text, $COLOR{$category});
 183 }
 184
 185 sub print_call {
 186     my $self = shift;
 187     my $outarg = shift;
 188     print $self->color("name", "$self->{name}");
 189     if (my $input = $self->{input}) {
 190         $input = "" if $input eq "()" && $self->{name} =~ /->/;
 191         print $self->color("input", $input);
 192     }
 193     else {
 194         my $proto_arg = $self->proto_arg;
 195         print "(";
 196         my $i = 0;
 197         for (@{$self->{input_av}}) {
 198             print ", " if $i;
 199             my $proto = substr($proto_arg, 0, 1, "");
 200             if ($proto ne "o") {
 201                 print $self->color("input", $_);
 202             }
 203             if ($proto eq "o" || $proto eq "O") {
 204                 print " = " if $proto eq "O";
 205                 print $self->color("output", _dump($outarg->[$i]));
 206             }
 207         }
 208         continue {
 209             $i++;
 210         }
 211         print ")";
 212     }
 213 }
 214
 215 sub return_void {
 216     my $self = shift;
 217     my $arg = shift;
 218     $self->print_call($arg);
 219     print "\n";
 220     return;
 221 }
 222
 223 sub return_scalar {
 224     my $self = shift;
 225     my $arg = shift;
 226     $self->print_call($arg);
 227     my $s = shift;
 228     my $name;
 229     my $proto_ret = $self->proto_ret;
 230     my $wrap = $autowrap_class{ref($s)};
 231     if ($proto_ret =~ /^\$\w+\z/ && ref($s) && ref($s) !~ /^(?:ARRAY|HASH|CODE|GLOB)\z/) {
 232         $name = $proto_ret;
 233     }
 234     else {
 235         $name = $wrap->{prefix} if $wrap;
 236     }
 237     if ($name) {
 238         $name .= $name_count{$name} if $name_count{$name}++;
 239         print " = ", $self->color("output", $name), "\n";
 240         $s = Data::Dump::Trace::wrap(name => $name, obj => $s, proto => $wrap->{proto});
 241     }
 242     else {
 243         print " = ", $self->color("output", _dump($s));
 244         if (!$s && $proto_ret =~ /!/ && $!) {
 245             print " ", $self->color("error", errno($!));
 246         }
 247         print "\n";
 248     }
 249     return $s;
 250 }
 251
 252 sub return_list {
 253     my $self = shift;
 254     my $arg = shift;
 255     $self->print_call($arg);
 256     print " = ", $self->color("output", $self->proto_ret eq "%" ? _dumpkv(@_) : _dumpav(@_)), "\n";
 257     return @_;
 258 }
 259
 260 sub errno {
 261     my $t = "";
 262     for (keys %!) {
 263         if ($!{$_}) {
 264             $t = $_;
 265             last;
 266         }
 267     }
 268     my $n = int($!);
 269     return "$t($n) $!";
 270 }
 271
 272 1;
 273
 274 __END__
 275
 276 =head1 NAME
 277
 278 Data::Dump::Trace - Helpers to trace function and method calls
 279
 280 =head1 SYNOPSIS
 281
 282   use Data::Dump::Trace qw(autowrap mcall);
 283
 284   autowrap("LWP::UserAgent" => "ua", "HTTP::Response" => "res");
 285
 286   use LWP::UserAgent;
 287   $ua = mcall(LWP::UserAgent => "new");      # instead of LWP::UserAgent->new;
 288   $ua->get("http://www.example.com")->dump;
 289
 290 =head1 DESCRIPTION
 291
 292 The following functions are provided:
 293
 294 =over
 295
 296 =item autowrap( $class )
 297
 298 =item autowrap( $class => $prefix )
 299
 300 =item autowrap( $class1 => $prefix1,  $class2 => $prefix2, ... )
 301
 302 =item autowrap( $class1 => \%info1, $class2 => \%info2, ... )
 303
 304 Register classes whose objects are are automatically wrapped when
 305 returned by one of the call functions below.  If $prefix is provided
 306 it will be used as to name the objects.
 307
 308 Alternative is to pass an %info hash for each class.  The recognized keys are:
 309
 310 =over
 311
 312 =item prefix => $string
 313
 314 The prefix string used to name objects of this type.
 315
 316 =item proto => \%hash
 317
 318 A hash of prototypes to use for the methods when an object is wrapped.
 319
 320 =back
 321
 322 =item wrap( name => $str, func => \&func, proto => $proto )
 323
 324 =item wrap( name => $str, obj => $obj, proto => \%hash )
 325
 326 Returns a wrapped function or object.  When a wrapped function is
 327 invoked then a trace is printed after the underlying function has returned.
 328 When a method on a wrapped object is invoked then a trace is printed
 329 after the methods on the underlying objects has returned.
 330
 331 See L</"Prototypes"> for description of the C<proto> argument.
 332
 333 =item call( $name, \&func, $proto, @ARGS )
 334
 335 Calls the given function with the given arguments.  The trace will use
 336 $name as the name of the function.
 337
 338 See L</"Prototypes"> for description of the $proto argument.
 339
 340 =item mcall( $class, $method, $proto, @ARGS )
 341
 342 =item mcall( $object, $method, $proto, @ARGS )
 343
 344 Calls the given method with the given arguments.
 345
 346 See L</"Prototypes"> for description of the $proto argument.
 347
 348 =item trace( $symbol, $prototype )
 349
 350 Replaces the function given by $symbol with a wrapped function.
 351
 352 =back
 353
 354 =head2 Prototypes
 355
 356 B<Note: The prototype string syntax described here is experimental and
 357 likely to change in revisions of this interface>.
 358
 359 The $proto argument to call() and mcall() can optionally provide a
 360 prototype for the function call.  This give the tracer hints about how
 361 to best format the argument lists and if there are I<in/out> or I<out>
 362 arguments.  The general form for the prototype string is:
 363
 364    <arguments> = <return_value>
 365
 366 The default prototype is "@ = @"; list of values as input and list of
 367 values as output.
 368
 369 The value '%' can be used for both arguments and return value to say
 370 that key/value pair style lists are used.
 371
 372 Alternatively, individual positional arguments can be listed each
 373 represented by a letter:
 374
 375 =over
 376
 377 =item C<i>
 378
 379 input argument
 380
 381 =item C<o>
 382
 383 output argument
 384
 385 =item C<O>
 386
 387 both input and output argument
 388
 389 =back
 390
 391 If the return value prototype has C<!> appended, then it signals that
 392 this function sets errno ($!) when it returns a false value.  The
 393 trace will display the current value of errno in that case.
 394
 395 If the return value prototype looks like a variable name (with C<$>
 396 prefix), and the function returns a blessed object, then the variable
 397 name will be used as prefix and the returned object automatically
 398 traced.
 399
 400 =head1 SEE ALSO
 401
 402 L<Data::Dump>
 403
 404 =head1 AUTHOR
 405
 406 Copyright 2009 Gisle Aas.
 407
 408 This library is free software; you can redistribute it and/or
 409 modify it under the same terms as Perl itself.
 410
 411 =cut