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