diff options
| -rw-r--r-- | Perl/Zinc/Trace.pm | 155 |
1 files changed, 148 insertions, 7 deletions
diff --git a/Perl/Zinc/Trace.pm b/Perl/Zinc/Trace.pm index fcd595f..ad219e6 100644 --- a/Perl/Zinc/Trace.pm +++ b/Perl/Zinc/Trace.pm @@ -29,19 +29,28 @@ package Tk::Zinc::Trace; use vars qw( $VERSION ); ($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); +use vars qw( $ForReplay ); + use Tk; use strict; use Tk::Zinc::TraceUtils; my $WidgetMethodfunction; +my %moduleOptions; + + BEGIN { - if ($ZincTraceErrors::on == 1) { + if (defined $ZincTraceErrors::on && $ZincTraceErrors::on == 1) { print STDERR "Tk::Zinc::Trace: incompatible package Tk::Zinc::TraceErrors is already ". "loaded (exit 1)\n"; exit 1; } - print "Tk::Zinc::Trace is ON\n"; + print "## Tk::Zinc::Trace ON\n"; $ZincTrace::on = 1; + require Getopt::Long; + Getopt::Long::Configure('pass_through'); + Getopt::Long::GetOptions(\%moduleOptions, 'code'); + $ForReplay=1 if defined $moduleOptions{code} ; select STDOUT; $|=1; ## for flushing the trace output # save current Tk::Zinc::InitObject function; it will be invoked in # overloaded one (see below) @@ -51,25 +60,63 @@ BEGIN { } +print "## following trace should be very close to a replay-script code\n" if $ForReplay; + +my $ZincCounter= ""; +my %ZincHash; + +#sub Tk::Zinc { +# print "CREATING Zinc : @_"; +# &$ZincCreationMethodfunction; +#} + sub Tk::Zinc::WidgetMethod { my ($zinc, $name, @args) = @_; my ($package, $filename, $line) = caller(1); $package="" unless defined $package; $filename="" unless defined $filename; $line="" unless defined $line; - print "TRACE: $filename line $line $name"; + my $widget; + if (defined $ZincHash{$zinc}) { + $widget = $ZincHash{$zinc}; + } elsif ($ZincCounter) { + $ZincHash{$zinc} = '$zinc'.$ZincCounter; + $widget = '$zinc'.$ZincCounter; + $ZincCounter++; + } else { + $ZincHash{$zinc} = '$zinc'; + $widget = '$zinc'; + $ZincCounter=1; # for the next zinc + } + + if ($ForReplay) { + print "$widget->$name"; + } else { + print "TRACE: $filename line $line $name"; + } + &printList(@args); # invoke function possibly overloaded in other modules if (wantarray()) { my @res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - print " RETURNS "; - &printList (@res); print "\n"; + if ($ForReplay) { + print ";\n"; + } else { + print " RETURNS "; + &printList (@res); + print "\n"; + } $zinc->update; return @res; } else { my $res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - print " RETURNS "; - &printItem ($res); print "\n"; + if ($ForReplay) { + print ";\n"; + } else { + print " RETURNS "; + &printItem ($res); + print "\n"; + } $zinc->update; return $res; } @@ -78,4 +125,98 @@ sub Tk::Zinc::WidgetMethod { 1; +__END__ + +=head1 NAME + +Tk::Zinc::Trace - A module to trace all Tk::Zinc method calls + +=head1 SYNOPSIS + +use Tk::Zinc::Trace; +$Tk::Zinc::Trace:ForReplay = 1; + +or + +perl -MTk::Zinc::Trace YourZincBasedScript.pl [--code] + +=head1 DESCRIPTION + +When loaded, this module overloads a Tk mechanism so that every +Tk::Zinc method call will be traced. Every call will also be followed by a +$zinc->update() so that the method call will be effectively treated. + +This module can be very effective for debugging when Tk::Zinc +core dumps and you have no clue which method call can be responsible for. If +you just want to trace Tk::Zinc errors when calling a method you +should rather use the Tk::Zinc::TraceErrors module + +If the global variable $Tk::Zinc::Trace:ForReplay is set or if the --code +option is set in the second form, the printout will be very close to re-executable +code, like this: + + ## following trace should be very close to a replay-script code + $zinc->configure(-relief => 'sunken', -borderwidth => 3, + -width => 700, -font => 10x20, -height => 600); + $zinc->add('rectangle', 1, [10, 10, 100, 50], + -fillcolor => 'green', -filled => 1, -linewidth => 10, + -relief => 'roundridge', -linecolor => 'darkgreen'); + $zinc->add('text', 1, -font => -adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-* => + -text => 'A filled rectangle with a "roundridge" relief border of 10 pixels.', + -anchor => 'nw', -position => [120, 20]); + $zinc->add('track', 1, 6, + -labelformat => 'x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1 a0a0^0>2', + -position => [20, 120], -speedvector => [40, -10], -speedvectormark => 1, -speedvectorticks => 1); + $zinc->coords(4, [20, 120]); + + +If not (the default), the printout will be more informtative, giving +the following information: + +=over 6 + +=item * the source filename where the method has been invoked + +=item * the line number in the source file + +=item * the TkZinc method name + +=item * the list of arguments in a human-readable form + +=item * the returned value + +=back + +The trace will look like: + + ## Tk::Zinc::Trace ON + TRACE: /usr/lib/perl5/Tk/Widget.pm line 196 configure(-relief => 'sunken', -borderwidth => 3, -width => 700, -font => 10x20, -height => 600) RETURNS undef + TRACE: Perl/demos/demos/zinc_lib/items.pl line 21 add('rectangle', 1, [10, 10, 100, 50], -fillcolor => 'green', -filled => 1, -linewidth => 10, -relief => 'roundridge', -linecolor => 'darkgreen') RETURNS 2 + TRACE: Perl/demos/demos/zinc_lib/items.pl line 25 add('text', 1, -font => -adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-* => -text => 'A filled rectangle with a "roundridge" relief border of 10 pixels.', -anchor => 'nw', -position => [120, 20]) RETURNS 3 + TRACE: Perl/demos/demos/zinc_lib/items.pl line 36 add('track', 1, 6, -labelformat => 'x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1 a0a0^0>2', -position => [20, 120], -speedvector => [40, -10], -speedvectormark => 1, -speedvectorticks => 1) RETURNS 4 + +=head1 AUTHOR + +C.Mertz <mertz@cena.fr> and D.Etienne <etienne@cena.fr> + +=head1 CAVEATS and BUGS + +This module cannot be used when Tk::Zinc::TraceErrors is already in use. + +As every Tk::Zinc method call is followed by an ->update call, this may +dramatically slowdown an application. The trade-off is between application +run-time and developper debug-time. + +When using an output "code-like" they are still part of the output which is +not executable code. However, the ouptut could be easily and manually +edited to be executable perl code. + +=head1 COPYRIGHT + +See Tk::Zinc copyright; LGPL + +=head1 SEE ALSO + +L<Tk::Zinc(3pm)>, L<Tk::Zinc::TraceErrors(3pm)>. L<Tk::Zinc::Debug(3pm)>. +=cut |