1package 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 15use strict; 16 17use base 'Exporter'; 18our @EXPORT_OK = qw(call mcall wrap autowrap trace); 19 20use Carp qw(croak); 21use overload (); 22 23my %obj_name; 24my %autowrap_class; 25my %name_count; 26 27sub 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 43sub 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 66sub trace { 67 my($symbol, $prototype) = @_; 68 no strict 'refs'; 69 no warnings 'redefine'; 70 *{$symbol} = wrap(name => $symbol, func => \&{$symbol}, proto => $prototype); 71} 72 73sub 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 90sub 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 109package Data::Dump::Trace::Wrapper; 110 111sub 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 118package Data::Dump::Trace::Call; 119 120use Term::ANSIColor (); 121use Data::Dump (); 122 123*_dump = \&Data::Dump::dump; 124 125our %COLOR = ( 126 name => "yellow", 127 output => "cyan", 128 error => "red", 129 debug => "red", 130); 131 132%COLOR = () unless -t STDOUT; 133 134sub _dumpav { 135 return "(" . _dump(@_) . ")" if @_ == 1; 136 return _dump(@_); 137} 138 139sub _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 147sub 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 165sub proto_arg { 166 my $self = shift; 167 my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || ""); 168 $arg ||= '@'; 169 return $arg; 170} 171 172sub proto_ret { 173 my $self = shift; 174 my($arg, $ret) = split(/\s*=\s*/, $self->{proto} || ""); 175 $ret ||= '@'; 176 return $ret; 177} 178 179sub color { 180 my($self, $category, $text) = @_; 181 return $text unless $COLOR{$category}; 182 return Term::ANSIColor::colored($text, $COLOR{$category}); 183} 184 185sub 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 215sub return_void { 216 my $self = shift; 217 my $arg = shift; 218 $self->print_call($arg); 219 print "\n"; 220 return; 221} 222 223sub 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 252sub 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 260sub 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 2721; 273 274__END__ 275 276=head1 NAME 277 278Data::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 292The 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 304Register classes whose objects are are automatically wrapped when 305returned by one of the call functions below. If $prefix is provided 306it will be used as to name the objects. 307 308Alternative is to pass an %info hash for each class. The recognized keys are: 309 310=over 311 312=item prefix => $string 313 314The prefix string used to name objects of this type. 315 316=item proto => \%hash 317 318A 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 326Returns a wrapped function or object. When a wrapped function is 327invoked then a trace is printed after the underlying function has returned. 328When a method on a wrapped object is invoked then a trace is printed 329after the methods on the underlying objects has returned. 330 331See L</"Prototypes"> for description of the C<proto> argument. 332 333=item call( $name, \&func, $proto, @ARGS ) 334 335Calls the given function with the given arguments. The trace will use 336$name as the name of the function. 337 338See 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 344Calls the given method with the given arguments. 345 346See L</"Prototypes"> for description of the $proto argument. 347 348=item trace( $symbol, $prototype ) 349 350Replaces the function given by $symbol with a wrapped function. 351 352=back 353 354=head2 Prototypes 355 356B<Note: The prototype string syntax described here is experimental and 357likely to change in revisions of this interface>. 358 359The $proto argument to call() and mcall() can optionally provide a 360prototype for the function call. This give the tracer hints about how 361to best format the argument lists and if there are I<in/out> or I<out> 362arguments. The general form for the prototype string is: 363 364 <arguments> = <return_value> 365 366The default prototype is "@ = @"; list of values as input and list of 367values as output. 368 369The value '%' can be used for both arguments and return value to say 370that key/value pair style lists are used. 371 372Alternatively, individual positional arguments can be listed each 373represented by a letter: 374 375=over 376 377=item C<i> 378 379input argument 380 381=item C<o> 382 383output argument 384 385=item C<O> 386 387both input and output argument 388 389=back 390 391If the return value prototype has C<!> appended, then it signals that 392this function sets errno ($!) when it returns a false value. The 393trace will display the current value of errno in that case. 394 395If the return value prototype looks like a variable name (with C<$> 396prefix), and the function returns a blessed object, then the variable 397name will be used as prefix and the returned object automatically 398traced. 399 400=head1 SEE ALSO 401 402L<Data::Dump> 403 404=head1 AUTHOR 405 406Copyright 2009 Gisle Aas. 407 408This library is free software; you can redistribute it and/or 409modify it under the same terms as Perl itself. 410 411=cut 412