Tk::Zinc::Trace - A module to trace all Tk::Zinc method calls

 ## 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]);

    

 ## 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

#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself, subject
# to additional disclaimer in Tk/license.terms due to partial
# derivation from Tk8.0 sources.
#
# Copyright (c) 2002 CENA, C.Mertz <mert@cena.fr> to trace all
# Tk::Zinc methods calls as well as the args in a human readable
# form. Updated by D.Etienne.
#
# This package overloads the Tk::Methods function in order to trace
# every Tk::Zinc method call in your application.
#
# This may be very usefull when your application segfaults and
# when you have no idea where this happens in your code.
#
# $Id: Trace.pm,v 1.13 2005/05/16 07:22:20 lecoanet Exp $
#
# To trap Tk::Zinc errors, use rather the Tk::Zinc::TraceErrors package.
#
# for using this file do some thing like :
# perl -MTk::Zinc::Trace myappli.pl

package Tk::Zinc::Trace;

use vars qw( $VERSION );
($VERSION) = sprintf("%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/);

use vars qw( $ForReplay );

use Tk;
use strict;
use Tk::Zinc::TraceUtils;

my $WidgetMethodfunction;
my %moduleOptions;


BEGIN {
    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 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)
    use Tk;
    use Tk::Zinc;
    $WidgetMethodfunction = Tk::Zinc->can('WidgetMethod');
    
}

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) = @_;
    if (defined $Tk::Zinc::Trace::off and $Tk::Zinc::Trace::off > 0) {
	return &$WidgetMethodfunction(@_) if $WidgetMethodfunction;
    }
    my ($package, $filename, $line) = caller(1);
    $package="" unless defined $package;
    $filename="" unless defined $filename;
    $line="" unless defined $line;
    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;
	if ($ForReplay) {
	    print ";\n";
	} else {
	    print "  RETURNS ";
	    &printList (@res);
	    print "\n";
	}
	$zinc->update;
	return @res;
    } else {
	my $res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;
	if ($ForReplay) {
	    print ";\n";
	} else {
	    print "  RETURNS ";
	    &printItem ($res);
	    print "\n";
	}
	$zinc->update;
	return $res;
    }
}
    
1;


__END__