aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Perl/Zinc/Trace.pm155
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