#
# 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 or encounters
# errors such as "blabla...bla at /usr/lib/perl5/Tk.pm line 228" and
# when you have no idea where this happens in your code  
#
# for using this file do some thing like :
# perl -MZincTrace myappli.pl

BEGIN { print "ZincTrace is ON\n"; select STDOUT; $|=1 } ## for flushing the trace output
package ZincTrace;

use Tk;
use strict;
use Tk::Font;
use Tk::Photo;

use Carp;

my $asCode = 0;
#$asCode = 1;
my ($lastMethod, $package, $filename, $line);
sub Tk::Methods {
    my ($package) = caller;
    no strict 'refs';
    foreach my $meth (@_) {
	my $name = $meth;
	*{$package."::$meth"} = sub { $lastMethod=$package."::$meth";
				      ($package, $filename, $line) = caller;
				      $package="" unless defined $package;
				      $filename="" unless defined $filename;
				      $line="" unless defined $line;
				      my $obj = shift;
				      if ($asCode) {
					  print "$obj->$name";
					  &printList (@_);
					  print ";";
				      } elsif ($obj =~ /^Tk::Zinc/) {
					  print "TRACE: $filename line $line $name";
					  &printList (@_);
				      }
				      if (wantarray()) {
					  my @res = $obj->WidgetMethod($name,@_);
					  print "  RETURNS ";
					  &printList (@res); print "\n";
					  $obj->update;
					  return @res;
				      } else {
					  my $res = $obj->WidgetMethod($name,@_);
					  print "  RETURNS ";
					  &printItem ($res); print "\n";
					  $obj->update;
					  return $res;
				      }
				  }
    }
}

### to print something
sub printItem {
    my ($value) = @_;
    my $ref = ref($value);
#    print "VALUE=$value REF=$ref\n";
    if ($ref eq 'ARRAY') {
	printArray ( @{$value} );
    }
    elsif ($ref eq 'CODE') {
	print "{CODE}";
    }
    elsif ($ref eq 'Tk::Photo') {
#	print " **** $value ***** ";
	print "Tk::Photo(\"". scalar $value->cget('-file') . "\")";
    }
    elsif ($ref eq 'Tk::Font') {
	print "'$value'";
    }
    elsif ($ref eq '') {  # scalar 
	if (defined $value) {
	    if ($value eq '') {
		print  "''";
	    } elsif ($value =~ /\s/
		     or $value =~ /^[a-zA-Z]/
		     or $value =~ /^[\W]$/ ) {
		print "'$value'";
	    }  else {
		print $value;
	    }
	}
	else {
	    print "undef";
	}
    }
    else { # some  class instance
	return $value;
    }
} # end printitem

### to print a list of something
sub printArray {
    my (@values) = @_;
    if (! scalar @values) {
	print "[]";
    }
    else {  # the list is not empty
	my @res;
	print "[";
	while (@values) {
	    my $value = shift @values;
	    &printItem ($value);
	    print ", " if (@values);
	}
	print "]" ;
    }
} # end printarray

sub printList {
    print "(";
    while (@_) {
	my $v = shift @_;
	printItem $v;
	if ($v =~ /^-\w+/) {
	    print " => ";
	} elsif (@_) {
	    print ", ";
	}
    }
    print ")";
} # end printList


sub Tk::Error
{my $w = shift;
 my $error = shift;
 if (Exists($w))
  {
   my $grab = $w->grab('current');
   $grab->Unbusy if (defined $grab);
  }
 chomp($error);
 warn "Tk::Error: $error in $lastMethod at $filename line $line\n";#, join("\n ",@_)."\n";
# carp "Tk::Error:CM:: $error\n " . join("\n ",@_)."\n";
}

1;