#        ZincDebug Perl Module :
#
#        For debugging/analysing a Zinc application. Only one instance
#        of zinc can be managed.
#
#        Author : Daniel Etienne <etienne@cena.fr>
#
# $Id$
#---------------------------------------------------------------------------
package ZincDebug;

use strict 'vars';
use vars qw(@ISA @EXPORT @EXPORT_OK $WARNING);
use Carp;
use English;
require Exporter;
use File::Basename;
use Tk;
use Tk::Zinc;
use Tk::LabFrame;
use Tk::Pane;
use Tk::Dialog;
use Tk::Tree;
use Tk::ItemStyle;

@ISA = qw(Exporter);
@EXPORT = qw(finditems snapshot tree);
@EXPORT_OK = qw(finditems snapshot tree);

my ($help_tl0, $help_tl, $result_tl, $result_fm, $search_tl,
    $searchtree_tl, $showitemflag);
my $coords_tl;
my $devicecoords_tl;
my ($text_id, $rectangle_id);
my ($x0, $y0);
my ($help_print, $imagecounter, $saving) = (0,0);
my $searchEntryValue;
my $searchTreeEntryValue;
my $tree_tl;
my $zinc;
my $enclosedModBtn;
my $overlapModBtn;
my $treeModBtn;
my $searchKey;
my $snapKey;
my $treeKey;
my $tree;
my @keys;
my @seq;
my $helptree_tl;
my $wwidth;
my $wheight;


# Hack to capture $zinc symbols.
# Usefull to load ZincDebug by running your perl script in this way :
#   perl -MZincdebug yourscript.pl
# or
#   perl -MZincDebug=tree,finditems yourscript.pl
#
# Needs that zinc instance appears in the symbols table of main package,
# i.e. zinc instance is defined in you script as global (not lexical)
# variable
#
sub import {
    my ($module, @args) = @_;
    # export_to_level really export symbols
    ZincDebug->export_to_level(1, @_);
    my %args;
    my $noargs = 1 unless @args > 0;
    for (@args) {
        $args{$_} = 1;
    }
    Tk::after(3000, sub {
        my $found = 0;
	# return if $zinc is alrealdy defined, by invocation of ZincDebug
	# functions tree(), finditems()... in main
	return if $zinc;
        for my $name (keys %{'main::'}) {
            if (ref(${$main::{$name}}) eq 'Tk::Zinc') {
                &tree(${$main::{$name}}) if $args{tree} or $noargs;
                &finditems(${$main::{$name}}) if $args{finditems} or $noargs;
                &snapshot(${$main::{$name}}) if $args{snapshot} or $noargs;
                $found++;
                # return  when first instance of Zinc is found
                return;
            }
        }
        if ($found == 0) {
            print "in ZincDebug module, no zinc instance has been detected at ".
                  "runtime.\n";
        }
    });
    
} # end import


sub tree {

    &setwidget(shift);
    return unless $zinc;
    # styles definition
    $zinc->ItemStyle('text', -stylename => "item", -foreground => 'black');
    $zinc->ItemStyle('text', -stylename => "group", -foreground => 'black');
    # options 
    my %options = @_;
    for my $opt (keys(%options)) {
	carp "in ZincDebug module, tree() function, unknown option $opt\n"
	    unless ($opt eq '-itemModBtn' or $opt eq '-key' or
		    $opt eq '-optionsToDisplay' or $opt eq '-optionsFormat');
    }
    $treeKey = ($options{-key}) ? $options{-key} : 'Control-t';
    $treeModBtn = ($options{-itemModBtn}) ? $options{-itemModBtn} : ['Control', 2];
    return unless &compatseq($treeModBtn);
    return unless &compatkey($treeKey);
    $options{-optionsFormat} = 'column' unless $options{-optionsFormat};
    if ($options{-optionsFormat} ne 'row' and $options{-optionsFormat} ne 'column') {
	carp "in ZincDebug module, tree() function, expected values for ".
	    "-optionsFormat are 'row' or 'column'. Option is set to 'column'\n";
	$options{-optionsFormat} = 'column';
    }
    #
    # binding for help screen
    #
    $zinc->toplevel->Tk::bind('<Key-Escape>', \&showgeneralhelp);
    #
    # binding for building tree
    #
    $zinc->toplevel->Tk::bind('<'.$treeKey.'>',
			      [\&showtree, $options{-optionsToDisplay},
			       $options{-optionsFormat}]);
    #
    # binding for displaying item in tree
    #
    my $tkb = $treeModBtn;
    $zinc->Tk::bind('<'.$tkb->[0]."-".$tkb->[1].'>',
		    [\&findintree, $options{-optionsToDisplay},
			       $options{-optionsFormat}]);
    
} # end tree


sub finditems {
    
    &setwidget(shift);
    return unless $zinc;
    # options 
    my %options = @_;
    for my $opt (keys(%options)) {
	carp "in ZincDebug module, finditems() function, unknown option $opt\n"
	    unless ($opt eq '-color' or $opt eq '-enclosedModBtn' or
		    $opt eq '-overlapModBtn' or $opt eq '-searchKey');
    }
    my $color = ($options{-color}) ? $options{-color} : 'sienna';
    $enclosedModBtn = ($options{-enclosedModBtn}) ? $options{-enclosedModBtn} :
	['Control', 3];
    $overlapModBtn = ($options{-overlapModBtn}) ? $options{-overlapModBtn} :
	['Shift', 3];
    $searchKey = ($options{-searchKey}) ? $options{-searchKey} : 'Control-f';
    return unless &compatseq($enclosedModBtn, $overlapModBtn);
    return unless &compatkey($searchKey);
    #
    # binding for help screen
    #
    $zinc->toplevel->Tk::bind('<Key-Escape>', \&showgeneralhelp);
    #
    # bindings for Enclosed search
    #
    my $ekb = $enclosedModBtn;
    $zinc->Tk::bind('all', "<".$ekb->[0]."-".$ekb->[1].">",
		    [\&startrectangle, 'simple', 'Enclosed', $color]);
    $zinc->Tk::bind('all', "<".$ekb->[0]."-B".$ekb->[1]."-Motion>", \&resizerectangle);
    $zinc->Tk::bind('all', "<".$ekb->[0]."-B".$ekb->[1]."-ButtonRelease>",
		    [\&stoprectangle, 'enclosed', 'Enclosed search']);
    #
    # bindings for Overlap search
    #
    my $okb = $overlapModBtn;
    $zinc->Tk::bind('all', "<".$okb->[0]."-".$okb->[1].">",
		    [\&startrectangle, 'mixed', 'Overlap', $color]);
    $zinc->Tk::bind('all', "<".$okb->[0]."-B".$okb->[1]."-Motion>", \&resizerectangle);
    $zinc->Tk::bind('all', "<".$okb->[0]."-B".$okb->[1]."-ButtonRelease>",
		    [\&stoprectangle, 'overlapping', 'Overlap search']);
    #
    # binding for search entry
    #
    $zinc->toplevel->Tk::bind('<'.$searchKey.'>', \&searchentry);

    
} # end finditems



sub snapshot {
    
    &setwidget(shift);
    return unless $zinc;
    # options 
    my %options = @_;
    for my $opt (keys(%options)) {
	carp "in ZincDebug module, snapshot() function, unknown option $opt\n"
	    unless ($opt eq '-key' or
		    $opt eq '-verbosity' or $opt eq '-basename');
    }
    $snapKey = ($options{-key}) ? $options{-key} : 'Control-s';
    my $snapshotVerbosity = (defined $options{-verbosity}) ? $options{-verbosity} : 1;
    my $snapshotBasename = ($options{-basename}) ? $options{-basename} : "zincsnapshot";
    return unless &compatkey($snapKey);
    #
    # binding for help screen
    #
    $zinc->toplevel->Tk::bind('<Key-Escape>', \&showgeneralhelp);
    #
    # binding for printing a full zinc window
    #
      $zinc->toplevel->Tk::bind("<".$snapKey.">",
  		    [\&printWindow , $snapshotBasename, $snapshotVerbosity]);

} # end snapshot


#---------------------------------------------------------------------------
#
# TREE PRIVATE FUNCTIONS
#
#---------------------------------------------------------------------------
sub findintree {
    my $optionstodisplay = $_[1];
    my $optionsFormat = $_[2];
    if (not Tk::Exists($tree_tl)) {
	&showtree(undef, $optionstodisplay, $optionsFormat);
    }
    my $ev = $zinc->XEvent;
    ($x0, $y0) = ($ev->x, $ev->y);
    my @atomicgroups = &unsetAtomicity;
    my $item = $zinc->find('closest', $x0, $y0);
    &restoreAtomicity(@atomicgroups);
    return unless $item > 1;
    my @ancestors = reverse($zinc->find('ancestors', $item));
    my $path = join('.', @ancestors).".".$item;
    $tree->see($path);
    $tree->selectionClear;
    $tree->anchorSet($path);
    $tree->selectionSet($path);
    &surrounditem($zinc, $item);
    $tree->focus;

} # end findintree



sub showtree {
    my $optionstodisplay = $_[1];
    my $optionsFormat = $_[2];
    $WARNING = 0;
    my @optionstodisplay = split(/,/, $optionstodisplay);
    $WARNING = 1;
    $tree_tl->destroy if $tree_tl and Tk::Exists($search_tl);
    $tree_tl = $zinc->Toplevel;
    $tree_tl->minsize(280, 200);
    $tree_tl->title("Zinc Items Tree");
    $tree = $tree_tl->Scrolled('Tree',
			       -scrollbars => 'se',
			       -height => 40,
			       -width => 50,
			       -itemtype => 'text',
			       -selectmode => 'single',
			       -separator => '.',
			       -drawbranch => 1,
			       -indent => 30,
			       -command => sub {
				   my $path = shift;
				   my $item = (split(/\./, $path))[-1];
				   $zinc->remove("zincdebug");
				   &showresult("", $zinc, $item);
			       },
			       );
    $tree->bind('<1>', [sub {
	my $path = $tree->nearest($_[1]);
	my $item = (split(/\./, $path))[-1];
	&highlightitem($tree, $zinc, $item, 0);
		       
    }, Ev('y')]);
    
    $tree->bind('<2>', [sub {
	my $path = $tree->nearest($_[1]);
	$tree->selectionClear;
	$tree->selectionSet($path);
	$tree->anchorSet($path);
	my $item = (split(/\./, $path))[-1];
	&highlightitem($tree, $zinc, $item, 1);
		       
    }, Ev('y')]);

    $tree->bind('<3>', [sub {
	my $path = $tree->nearest($_[1]);
	$tree->selectionClear;
	$tree->selectionSet($path);
	$tree->anchorSet($path);
	my $item = (split(/\./, $path))[-1];
	&highlightitem($tree, $zinc, $item, 2);
		       
    }, Ev('y')]);
    
    $tree->add("1", -text => "Group(1)", -state => 'disabled');
    &scangroup($tree, 1, "1", $optionsFormat, @optionstodisplay);
    $tree->autosetmode;
    # control buttons frame
    my $tree_butt_fm = $tree_tl->Frame(-height => 40)->pack(-side => 'bottom',
							    -fill => 'y');
    $tree_butt_fm->Button(-text => 'Help',
			  -command => \&showHelpAboutTree,
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 30, -fill => 'both');
    
    $tree_butt_fm->Button(-text => 'Search',
			  -command => \&searchInTree,
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 30, -fill => 'both');

    $tree_butt_fm->Button(-text => 'Close',
			  -command => sub {$zinc->remove("zincdebug");
					   $tree_tl->destroy},
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 30, -fill => 'both');
    # pack tree
    $tree->pack(-padx => 10, -pady => 10,
		-ipadx => 10,
		-side => 'top',
		-fill => 'both',
		-expand => 1,
		);


} # end showtree

sub searchInTree {
    $searchtree_tl->destroy if $searchtree_tl and Tk::Exists($searchtree_tl);
    $searchtree_tl = $zinc->Toplevel;
    $searchtree_tl->title("Find in tree");
    my $fm = $searchtree_tl->Frame->pack(-side => 'top');
    $fm->Label(-text => "Find : ",
	       )->pack(-side => 'left', -padx => 10, -pady => 10);
    my $entry = $fm->Entry(-width => 20)->pack(-side => 'left',
					       -padx => 10, -pady => 10);
    my $status = $searchtree_tl->Label(-foreground => 'sienna',
				   )->pack(-side => 'top');
    my $ep = 1;
    my $searchfunc =  sub {
	my $side = shift;
	my $found = 0;
        #print "ep=$ep side=$side\n";
	$status->configure(-text => "");
	$status->update;
	$searchTreeEntryValue = $entry->get();
	$searchTreeEntryValue = quotemeta($searchTreeEntryValue);
	my $text;
	while ($ep) {
 	    $ep = $tree->info($side, $ep);
	    unless ($ep) {
		$ep = 1;
		$found = 1;
		last;
	    }
	    $text = $tree->entrycget($ep, -text);
	    if ($text =~ /$searchTreeEntryValue/) {
		$tree->see($ep);
		$tree->selectionClear;
		$tree->anchorSet($ep);
		$tree->selectionSet($ep);
		$found = 1;
		last;
	    }
	}
	$status->configure(-text => "Search string not found") unless $found;
    };

    my $fm2 = $searchtree_tl->Frame->pack(-side => 'top');
    $fm2->Button(-text => 'Prev',
		 -command => sub {&$searchfunc('prev');},
		 )->pack(-side => 'left', -pady => 10);
    $fm2->Button(-text => 'Next',
		 -command => sub {&$searchfunc('next');},
		 )->pack(-side => 'left', -pady => 10);
    $fm2->Button(-text => 'Close',
		 -command => sub {$searchtree_tl->destroy},
		 )->pack(-side => 'right', -pady => 10);
    $entry->focus;
    $entry->delete(0, 'end');
    $entry->insert(0, $searchTreeEntryValue) if $searchTreeEntryValue;
    $entry->bind('<Key-Return>', sub {&$searchfunc('next');});
    
} # end searchInTree

sub extractinfo {
    my $item = shift;
    my $format = shift;
    my $option = shift;
    my $titleflag = shift;
    $option =~ s/^\s+//;
    $option =~ s/\s+$//;
    #print "option=[$option]\n";
    my @info;
    $WARNING = 0;
    eval {@info = $zinc->itemcget($item, $option)};
    #print "eval $option = (@info) $@\n";
    return if $@;
    return if @info == 0;
    my $info;
    my $sep = ($format eq 'column') ? "\n  " : ", ";
    if ($titleflag) {
	$info = $sep."[$option] ".$info[0];
    } else {
	$info = $sep.$info[0];
    }
    if (@info > 1) {
	shift(@info);
	for (@info) {
	    if ($format eq 'column') {
		if (length($info." ".$_) > 40) {
		    if ($titleflag) {
			$info .= $sep."[$option] ".$_;
		    } else {
			$info .= $sep.$_;
		    }
		} else {
		    $info .= ", $_";
		}
	    } else {
		$info .= $sep.$_;
	    }
	}
    }
    $WARNING = 1;
    return $info;
}

sub scangroup {
    my ($tree, $group, $path, $format, @optionstodisplay) = @_;
    my @items = $zinc->find('withtag', "$group.");
    for my $item (@items) {
	my $type = ucfirst($zinc->type($item));
	my $info = " ";
	if (@optionstodisplay == 1) {
	    $info .= &extractinfo($item, $format, $optionstodisplay[0]);
	} elsif (@optionstodisplay > 1) {
	    for my $opt (@optionstodisplay) {
		$info .= &extractinfo($item, $format, $opt, 1);
	    }
	}
	if ($type eq "Group") {
	    $tree->add($path.".".$item,
		       -text => "$type($item)$info",
		       -style => 'group');
	    &scangroup($tree, $item, $path.".".$item, $format, @optionstodisplay);
	} else {
	    $tree->add($path.".".$item,
		       -text => "$type($item)$info",
		       -style => 'item');
	}
    }

} # end scangroup

#---------------------------------------------------------------------------
#
# FIND PRIVATE FUNCTIONS
#
#---------------------------------------------------------------------------
# begin to draw rectangular area for search
sub startrectangle {
    my ($widget, $style, $text, $color) = @_;
    $zinc->remove($rectangle_id, $text_id);
    my $ev = $zinc->XEvent;
    ($x0, $y0) = ($ev->x, $ev->y);
    $rectangle_id = $zinc->add('rectangle', 1, [$x0, $y0, $x0, $y0],
			       -linecolor => $color,
			       -linewidth => 2,
			       -linestyle => $style,
			       );
    $text_id = $zinc->add('text', 1,
			  -color => $color,
			  -font => '7x13',
			  -position => [$x0+5, $y0-15],
			  -text => $text,
			  );
  
} # end startrectangle


# resize the rectangular area for search
sub resizerectangle {
    my $ev = $zinc->XEvent;
    my ($x, $y) = ($ev->x, $ev->y);
    return unless ($zinc->find('withtag', $rectangle_id));

    $zinc->coords($rectangle_id, 1, 1, [$x, $y]);
    if ($x < $x0) {
	if ($y < $y0) {
	    $zinc->coords($text_id, [$x+5, $y-15]);
	} else {
	    $zinc->coords($text_id, [$x+5, $y0-15]);
	}
    } else {
	if ($y < $y0) {
	    $zinc->coords($text_id, [$x0+5, $y-15]);
	} else {
	    $zinc->coords($text_id, [$x0+5, $y0-15]);
	}
    }
    $zinc->raise($rectangle_id);
    $zinc->raise($text_id);

} # end resizerectangle



# stop drawing rectangular area for search
sub stoprectangle {
    my ($widget, $searchtype, $text) = @_;
    return unless ($zinc->find('withtag', $rectangle_id));

    my @atomicgroups = &unsetAtomicity;
    my @coords = $zinc->coords0($rectangle_id);
    my @items;
    for my $item ($zinc->find($searchtype, @coords, 1, 1)) {
	push (@items, $item) if $item != $rectangle_id and
	    $item != $text_id;
    }
    &restoreAtomicity(@atomicgroups);
    if (@items) {
	&showresult($text, $zinc, @items);
    } else {
	$zinc->remove($rectangle_id, $text_id);
    }

} # end stoprectangle



# in order to avoid find problems with group atomicity, we set all -atomic
# attributes to 0
sub unsetAtomicity {
    my @groups = $zinc->find('withtype', 'group');
    my @atomicgroups;
    for my $group (@groups) {
	if ($zinc->itemcget($group, -atomic)) {
	    push(@atomicgroups, $group);
	    $zinc->itemconfigure($group, -atomic => 0);
	}
    }
    return @atomicgroups;
    
} # end unsetAtomicity



sub restoreAtomicity {
    my @atomicgroups = @_;
    for my $group (@atomicgroups) {
	$zinc->itemconfigure($group, -atomic => 1);
    }

} # end restoreAtomicity



# display search entry field
sub searchentry {
    $search_tl->destroy if $search_tl and Tk::Exists($search_tl);
    $search_tl = $zinc->Toplevel;
    $search_tl->title("Specific search");
    my $fm = $search_tl->Frame->pack(-side => 'top');
    $fm->Label(-text => "Item TagOrId : ",
	       )->pack(-side => 'left', -padx => 10, -pady => 10);
    my $entry = $fm->Entry(-width => 20)->pack(-side => 'left',
					       -padx => 10, -pady => 10);
    my $status = $search_tl->Label(-foreground => 'sienna',
				   )->pack(-side => 'top');
    $search_tl->Button(-text => 'Close',
		       -command => sub {$search_tl->destroy},
		       )->pack(-side => 'top', -pady => 10);
    $entry->focus;
    $entry->delete(0, 'end');
    $entry->insert(0, $searchEntryValue) if $searchEntryValue;
    $entry->bind('<Key-Return>', [sub {
	$status->configure(-text => "");
	$status->update;
	$searchEntryValue = $entry->get();
	my @items = $zinc->find('withtag', $searchEntryValue);
	if (@items) {
	    &showresult("Search with TagOrId $searchEntryValue", $zinc, @items);
	} else {
	    $status->configure(-text => "No such TagOrId ($searchEntryValue)");
	}
    }]);
    
} # end searchentry


# test and set $zinc variable
sub setwidget {
    my $widget = shift;
    if ($zinc) {
	if ($zinc ne $widget) {
	    carp "In ZincDebug module, widget value already exists. ".
		"New value is ignored\n";
	}
    } elsif (not $widget) {
	carp "In ZincDebug module, widget must be specified\n";
    } else {
	$zinc = $widget;
    }
    $zinc->update;
    my $geom = $zinc->geometry =~ /(\d+)x(\d+)+/=~ /(\d+)x(\d+)+/;
    ($wwidth, $wheight) = ($1, $2);
	    
} # end setwidget

# test input keys compatibility
sub compatkey {
    push(@keys, @_);
    my %keys;
    for (@keys) {
	if ($keys{$_}) {
	    carp "In ZincDebug module, several bindings on <$_> key exist. ".
		"Only the last created will work\n";
	    return 0;
	}
	$keys{$_} = 1;
    }
    return 1;

} # end compatkey



# test input sequences compatibility
sub compatseq {
    push(@seq, @_);
    my %seq;
    for (@seq) {
	my $key = $_->[0].'-'.$_->[1];
	if ($seq{$key}) {
	    carp "In ZincDebug module, several bindings on <$key> sequence exit. ".
		"Only the last created will work\n";
	    return 0;
	}
	$seq{$key} = 1;
    }
    return 1;


} # end compatkey



# display in a toplevel the result of search ; a new toplevel destroyes the
# previous one
sub showresult {
    my ($label, $zinc, @items) = @_;
    # toplevel (re-)creation
    $result_tl->destroy if Tk::Exists($result_tl);
    $result_tl = $zinc->Toplevel();
    my $title = "Zinc Debug";
    $title .= " - $label" if $label;
    $result_tl->title($title);
    $result_tl->geometry('+10+20');
    my $fm = $result_tl->Frame()->pack(-side => 'bottom',
				       );
    $fm->Button(-text => 'Help',
		-command => [\&showHelpAboutAttributes, $result_tl]
		)->pack(-side => 'left', -padx => 40, -pady => 10);
    $fm->Button(-text => 'Close',
		-command => sub {
		    $result_tl->destroy;
		    $zinc->remove($rectangle_id, $text_id);
		})->pack(-side => 'left', -padx => 40, -pady => 10);
    
    # scrolled pane creation
    my $heightmax = 500;
    my $height = 100 + 50*@items;
    my $width = $result_tl->screenwidth;
    $width = 1200 if $width > 1200;
    $height = $heightmax if $height > $heightmax;
    $result_fm = $result_tl->Scrolled('Pane',
				      -scrollbars => 'soeo',
				      -gridded => 'xy',
				      -width => $width,
				      -height => $height,
				      );
    $result_fm->pack(-padx => 10, -pady => 10,
		     -ipadx => 10,
		     -fill => 'both',
		     -expand => 1,
		     );
    # attributes display
    &showattributes($result_fm, \@items);


} # end showresult


# display in a toplevel the values of other options
sub showotheroptions {
    my ($zinc, $item) = @_;
    my $tl = $zinc->Toplevel;
    my $title = "Other options of item $item";
    $tl->title($title);
    my $background = $tl->cget(-background);
    my $fm = $tl->LabFrame(-labelside => 'acrosstop',
			   -label => $title,
			   )->pack(-padx => 10, -pady => 10,
				   -ipadx => 10,
				   -fill => 'both');
    my $bgcolor = 'ivory';
    $fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => 1, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Value', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => 1, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');

    my @options = $zinc->itemconfigure($item);
    my $i = 2;
    for my $elem (@options) {
	my ($option, $type, $value) = (@$elem)[0,1,4];
	#print "option=$option type=$type\n";
	next if ($option eq '-visible' or $option eq '-sensitive' or
		 $option eq '-tags' or $option eq '-position' or
		 $option eq '-priority');
	if ($type eq 'gradient') {
	    my ($gradient) = $zinc->gname($value);
	    #print "value=$value gradient=$gradient\n";
	}
	$fm->Label(-text => $option, -relief => 'ridge')
	    ->grid(-row => $i, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
	$fm->Label(-text => $value, -relief => 'ridge')
	    ->grid(-row => $i, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
	$i++;
    }
    $tl->Button(-text => 'Close',
		-command => sub {$tl->destroy})->pack;

} # end showotheroptions


sub showdevicecoords {
    my ($zinc, $item) = @_;
    &showcoords($zinc, $item, 1);

}


sub showcoords {
    my ($zinc, $item, $deviceflag) = @_;
    my $bgcolor = 'ivory';
    $coords_tl->destroy if Tk::Exists($coords_tl);
    $coords_tl = $zinc->Toplevel();
    my $title = "Zinc Debug";
    if ($deviceflag) {
	$title .= " - Coords of item $item";
    } else {
	$title .= " - Device coords of item $item";
    }
    $coords_tl->title($title);
    $coords_tl->geometry('+10+20');
    $coords_tl->Button(-text => 'Close',
		       -command => sub {
			   $coords_tl->destroy;
		       })->pack(-side => 'bottom');
    # scrolled pane creation
    my $heightmax = 500;
    my $height = 100 + 50;
    $height = $heightmax if $height > $heightmax;
    my $coords_fm = $coords_tl->Scrolled('Pane',
				      -scrollbars => 'se',
				      -width => scalar $coords_tl->screenwidth,
				      -height => $height,
				      );
    $coords_fm->pack(-padx => 10, -pady => 10,
		     -ipadx => 10,
		     -fill => 'both',
		     -expand => 1,
		     );
    my @contour;
    my $contournum = $zinc->contour($item);
    for (my $i=0; $i < $contournum; $i++) {
	my @coords = $zinc->coords($item, $i);
	if (!ref $coords[0]) {
	    ## The first item of the list is not a reference, so the
	    ## list is guarranted to be a flat list (x, y, ...)
	    ## normaly of only one pair of (x y)
	    @coords = $zinc->transform(scalar $zinc->group($item), 1, [@coords])
		if $deviceflag;
	    for (my $j=0; $j < @coords; $j += 2) {
		push(@{$contour[$i]}, [$coords[$j], $coords[$j+1]]);
	    }
	}
	else {
	    ## the first element is an array reference, as every
	    ## other elements of the list
	    for (my $j=0; $j < @coords; $j ++) {
		my ($x,$y,$type) = @{$coords[$j]};
		($x,$y) = $zinc->transform(scalar $zinc->group($item), 1, [$x, $y])
		    if $deviceflag;
		push(@{$contour[$i]}, [ $x , $y, $type]);
	    }
	}
    }
    my $row = 1;
    my $col = 1;
    for (my $i=0; $i < @contour; $i++) {
	$col = 1;
	$coords_fm->Label(-text => "Contour $i",
			  -background => $bgcolor,
			  -relief => 'ridge')->grid(-row => $row,
						    -col => $col++,
						    -ipadx => 5,
						    -ipady => 5,
						    -sticky => 'nswe');
	for my $coords (@{$contour[$i]}) {
	    if ($col > 10) {
		$col = 2;
		$row++;
	    }
	    $coords->[0] =~ s/\.(\d\d).*/\.$1/;
	    $coords->[1] =~ s/\.(\d\d).*/\.$1/;
	    my $pointtype = (defined $coords->[2]) ? " ".$coords->[2] : "";
	    $coords_fm->Label(-text => sprintf('%s, %s%s', $coords->[0], $coords->[1],$pointtype),
			      -width => 15,
			      -relief => 'ridge')->grid(-row => $row,
							-ipadx => 5,
							-ipady => 5,
							-col => $col++,
							-sticky => 'nswe');
	}
	$row++;
    }

} # end showcoords


# display in a toplevel group's attributes
sub showgroupattributes {
    my ($zinc, $item) = @_;
    my $tl = $zinc->Toplevel;
    my $title = "About group $item";
    $tl->title($title);
    my $fm = $tl->LabFrame(-labelside => 'acrosstop',
			   -label => $title,
			   )->pack(-padx => 10, -pady => 10,
				   -ipadx => 10,
				   -fill => 'both');
    my $r = 1;
    # content
    $fm->Button(-command => [\&showgroupcontent, $zinc, $item],
		-text => 'Content',
		)->grid(-row => $r++, -col => 1, -columnspan => 2, -sticky => 'nswe');
    # parent group
    $fm->Label(-text => 'Parent group', -relief => 'ridge')
	->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    my $gr = $zinc->group($item);
    my $bpg = $fm->Button(-text => $gr,
			  -command => [\&showgroupattributes, $zinc, $gr])
	->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $bpg->configure(-disabledforeground => scalar $bpg->cget(-foreground),
		    -state => 'disabled') if $gr == $item;
    my $bgcolor = 'ivory';
    # coords
    $fm->Label(-text => 'Coordinates', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $r++, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe',
	       -columnspan => 2);	# coords
    $fm->Label(-text => 'Coords', -relief => 'ridge')
	->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    my @coords = $zinc->coords($item);
    my $coords;
    if (@coords == 2) {
	my $x0 = int($coords[0]);
	my $y0 = int($coords[1]);
	$coords = "($x0, $y0)";
    } elsif (@coords == 4) {
	my $x0 = int($coords[0]);
	my $y0 = int($coords[1]);
	my $x1 = int($coords[2]);
	my $y1 = int($coords[3]);
	$coords = "($x0, $y0, $x1, $y1)";
	print "we should not go through this case (1)!\n";
    } else {
	my $x0 = int($coords[0]);
	my $y0 = int($coords[1]);
	my $xn = int($coords[$#coords-1]);
	my $yn = int($coords[$#coords]);
	my $n = @coords/2 - 1;
	$coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)";
	print "we should not go through this case (2d)!\n";
    }
    $fm->Label(-text => $coords, -relief => 'ridge')
	->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    # device coords
    $fm->Label(-text => 'Device coords', -relief => 'ridge')
	->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    @coords = $zinc->transform(scalar $zinc->group($item), 1, [@coords]);
    if (@coords == 2) {
	my $x0 = int($coords[0]);
	my $y0 = int($coords[1]);
	$coords = "($x0, $y0)";
    } elsif (@coords == 4) {
	my $x0 = int($coords[0]);
	my $y0 = int($coords[1]);
	my $x1 = int($coords[2]);
	my $y1 = int($coords[3]);
	$coords = "($x0, $y0, $x1, $y1)";
	print "we should not go through this case (3)!\n";
    } else {
	my $x0 = int($coords[0]);
	my $y0 = int($coords[1]);
	my $xn = int($coords[$#coords-1]);
	my $yn = int($coords[$#coords]);
	my $n = @coords/2 - 1;
	$coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)";
	print "we should not go through this case (4)!\n";
    }
    $fm->Label(-text => $coords, -relief => 'ridge')
	->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');

    # options
    $fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Value', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');

    my @options = $zinc->itemconfigure($item);
    for my $elem (@options) {
	my ($option, $value) = (@$elem)[0,4];
	$fm->Label(-text => $option, -relief => 'ridge')
	    ->grid(-row => $r, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
	if ($option and $option eq '-tags') {
	    $value = join("\n", @$value);
	} elsif ($option and $option eq '-clip' and $value and $value > 0) {
	    $value .= " (". $zinc->type($value) .")";
	}
	$fm->Label(-text => $value, -relief => 'ridge')
	    ->grid(-row => $r, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
	$r++;
    }
    $tl->Button(-text => 'Close',
		-command => sub {$tl->destroy})->pack;    

} # end showgroupattributes


# display in a toplevel the content of a group item
sub showgroupcontent {
    my ($zinc, $group) = @_;
    my $tl = $zinc->Toplevel;
    my @items = $zinc->find('withtag', $group.".");
    my $heightmax = 500;
    my $height = 100 + 50*@items;
    $height = $heightmax if $height > $heightmax;    
    my $title = "Content of group $group";
    $tl->title($title);
    my $fm2 = $tl->Frame()->pack(-side => 'bottom',
				 );
    $fm2->Button(-text => 'Help',
		-command => [\&showHelpAboutAttributes, $tl]
		 )->pack(-side => 'left', -padx => 40, -pady => 10);
    $fm2->Button(-text => 'Close',
		-command => sub {
		    $tl->destroy;
		})->pack(-side => 'left', -padx => 40, -pady => 10);

    my $fm = $tl->Scrolled('Pane',
  			   -scrollbars => 'se',
  			   -width => scalar $result_tl->screenwidth,
  			   -height => $height,
  			   -label => $title,
  			   )->pack(-padx => 10, -pady => 10,
  				   -ipadx => 10,
				   -expand => 1,
  				   -fill => 'both');
    &showattributes($fm, \@items);

} # end showgroupcontent



# highlight an item (by cloning it and hiding other found items)
# why cloning? because we can't simply make visible an item which
# belongs to an invisible group.
sub highlightitem {
    my ($btn, $zinc, $item, $level) = @_;
    return if $showitemflag;
    $showitemflag = 1;
    
    &surrounditem($zinc, $item, $level);
    
    $btn->bind('<ButtonRelease>', [\&undohighlightitem]) if $btn;

} # end highlightitem

sub itemisoutside {
    my @bbox = @_;
    my $outflag;
    if ($bbox[2] < 0) {
	if ($bbox[1] >  $wheight) {
	    $outflag = 'left+bottom';
	} elsif ($bbox[3] < 0) {
	    $outflag = 'left+top';
	} else {
	    $outflag = 'left';
	} 
    } elsif ($bbox[0] > $wwidth) {
	if ($bbox[1] >  $wheight) {
	    $outflag = 'right+bottom';
	} elsif ($bbox[3] < 0) {
	    $outflag = 'right+top';
	} else {
	    $outflag = 'right';
	}
    } elsif ($bbox[3] < 0) {
	$outflag = 'top';
    } elsif ($bbox[1] > $wheight) {
	$outflag = 'bottom';
    }
    #print "outflag=$outflag bbox=@bbox\n";
    return 0 unless $outflag;
    my $g = $zinc->add('group', 1, -tags => ['zincdebug']);
    my $hw = 110;
    my $hh = 80;
    my $r = 5;
    $zinc->add('rectangle', $g, [-$hw, -$hh, $hw, $hh],
	       -filled => 1,
	       -linecolor => 'sienna',
	       -linewidth => 3,
	       -fillcolor => 'bisque',
	       -priority => 1,
	       );
    $zinc->add('text', $g,
	       -position => [0, 0],
	       -color => 'sienna',
	       -font => '-b&h-lucida-bold-i-normal-sans-34-240-*-*-p-*-iso8859-1',
	       -anchor => 'center',
	       -priority => 2,
	       -text => "Item is\noutside\nwindow\n");
    my ($x, $y);
    if ($outflag eq 'bottom') {
	$x = $bbox[0] + ($bbox[2]-$bbox[0])/2;
	$x = $hw + 10 if $x < $hw + 10;
	$x = $wwidth - $hw - 10 if $x > $wwidth - $hw - 10;
	$y = $wheight - $hh - 10;
    } elsif ($outflag eq 'top') {
	$x = $bbox[0] + ($bbox[2]-$bbox[0])/2;
	$x = $hw + 10 if $x < $hw + 10;
	$x = $wwidth - $hw - 10if $x > $wwidth - $hw - 10;
	$y = $hh + 10;
    } elsif ($outflag eq 'left') {
	$x = $hw + 10;
	$y = $bbox[1] + ($bbox[3]-$bbox[1])/2;
	$y = $hh + 10 if $y < $hh + 10;
	$y = $wheight - $hh - 10 if $y > $wheight - $hh - 10;
    } elsif ($outflag eq 'right') {
	$x = $wwidth - $hw - 10;
	$y = $bbox[1] + ($bbox[3]-$bbox[1])/2;
	$y = $hh + 10 if $y < $hh + 10;
	$y = $wheight - $hh - 10 if $y > $wheight - $hh - 10;
    } elsif ($outflag eq 'left+top') {
	$x = $hw + 10;
	$y = $hh + 10;
    } elsif ($outflag eq 'left+bottom') {
	$x = $hw + 10;
	$y = $wheight - $hh - 10;
    } elsif ($outflag eq 'right+top') {
	$x = $wwidth - $hw - 10;
	$y = $hh + 10;
    } elsif ($outflag eq 'right+bottom') {
	$x = $wwidth - $hw - 10;
	$y = $wheight - $hh - 10;
    }
    $zinc->coords($g, [$x, $y]);
    $zinc->raise('zincdebug');
    
} # end itemisoutside


# draw a rectangle arround the selected item
sub surrounditem {
    my ($zinc, $item, $level) = @_;
    $zinc->remove("zincdebug");
    # get item ancestors
    my @itemancestors = reverse($zinc->find('ancestors', $item));
    # skip group 1
    shift(@itemancestors);
    # create item's tree with good transformations
    my $topgroup = 1;
    for my $g (@itemancestors) {
	my $gc = $zinc->add('group', $topgroup, -tags => ['zincdebug']);
	$zinc->tsave($g, "mytrans");
	my @c = $zinc->coords($g);
	$zinc->trestore($gc, "mytrans");
	$zinc->coords($gc, [@c]);
	$zinc->tdelete("mytrans");
	$topgroup = $gc;
    }
    # cloning
    my $clone = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']);
    # move in topgroup  
    $zinc->chggroup($clone, $topgroup);
    # create a rectangle around 
    my @bbox0  = $zinc->bbox($clone);
    if (scalar @bbox0 == 4) {
	my @bbox = $zinc->transform(1, $topgroup, [@bbox0]);
	# If item is visible, rectangle is drawm surround it.
	# Else, a warning is displayed.
	unless (&itemisoutside(@bbox0)) {
	    if ($level > 0) {
		my $r = $zinc->add('Rectangle', $topgroup,
				   [$bbox[0] - 10, $bbox[1] - 10,
				    $bbox[2] + 10, $bbox[3] + 10],
				   -filled => 1,
				   -tags => ['zincdebug'],
				   -fillcolor => "gray20");
		$zinc->itemconfigure($r, -fillcolor => "gray80") if $level == 1;
	    } 
	    my $i = 0;
	    for ('white', 'red', 'white') {
		$zinc->add('rectangle', $topgroup,
			   [$bbox[0] - 5 - 2*$i, $bbox[1] - 5 - 2*$i,
			    $bbox[2] + 5 + 2*$i, $bbox[3] + 5 + 2*$i],
			   -linecolor => $_,
			   -linewidth => 1,
			   -tags => ['zincdebug']);
		$i++;
	    }
	}
    }
    # raise
    $zinc->raise('zincdebug');
    $zinc->raise($clone);
   
} # end surrounditem


sub undohighlightitem {
    my ($btn) = @_;
    $btn->bind('ReleaseButton', '');
    $zinc->remove('zincdebug');
    $showitemflag = 0;

} # end undohighlightitem



sub showbanner {
    my $fm = shift;
    my $i = shift;
    my $bgcolor = 'ivory';
    $fm->Label(-text => 'Id', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Type', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Group', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 3, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Priority', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 4, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Sensitive', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 5, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Visible', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 6, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Coords', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 7, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Device coords', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 8, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Bounding box', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 9, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Tags', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -col => 10, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label()->grid(-row => 1, -col => 11, -pady => 10);
     
} # end showbanner


# display in a grid the values of most important attributes 
sub showattributes {
    my ($fm, $items) = @_;
    my $bgcolor = 'ivory';
    my $i = 1;
    &showbanner($fm, $i++);
    for my $item (@$items) {
	my $type = $zinc->type($item);
	# id
	my $idbtn =
	    $fm->Button(-text => $item,
			-foreground => 'red'
			)->grid(-row => $i, -col => 1, -sticky => 'nswe',
				-ipadx => 5);
	$idbtn->bind('<1>', [\&highlightitem, $zinc, $item, 0]);
	$idbtn->bind('<2>', [\&highlightitem, $zinc, $item, 1]);
	$idbtn->bind('<3>', [\&highlightitem, $zinc, $item, 2]);
	# type
	if ($type eq 'group') {
	    $fm->Button(-text => $type, 
			-command => [\&showgroupcontent, $zinc, $item])
		->grid(-row => $i, -col => 2, -sticky => 'nswe', -ipadx => 5);
	} else {
	    $fm->Label(-text => $type, -relief => 'ridge')
		->grid(-row => $i, -col => 2, -sticky => 'nswe', -ipadx => 5);
	}
	# group
	my $group = $zinc->group($item);
	$fm->Button(-text => $group,
		    -command => [\&showgroupattributes, $zinc, $group])
	    ->grid(-row => $i, -col => 3, -sticky => 'nswe', -ipadx => 5);
	# priority
	$fm->Label(-text => scalar $zinc->itemcget($item, -priority),
		   -relief => 'ridge')
	    ->grid(-row => $i, -col => 4, -sticky => 'nswe', -ipadx => 5);
	# sensitiveness
	$fm->Label(-text => scalar $zinc->itemcget($item, -sensitive),
		   -relief => 'ridge')
	    ->grid(-row => $i, -col => 5, -sticky => 'nswe', -ipadx => 5);
	# visibility
	$fm->Label(-text => scalar $zinc->itemcget($item, -visible),
		   -relief => 'ridge')
	    ->grid(-row => $i, -col => 6, -sticky => 'nswe', -ipadx => 5);
	# coords
	my @coords = $zinc->coords($item);
	my $coords;
	if (!ref $coords[0]) {
	    my $x0 = int($coords[0]);
	    my $y0 = int($coords[1]);
	    $coords = "($x0, $y0)";
	} else {
	    my @points0 = @{$coords[0]};
	    my $n = $#coords;
	    my @pointsN = @{$coords[$n]};
	    my $x0 = int($points0[0]);
	    my $y0 = int($points0[1]);
	    my $xn = int($pointsN[0]);
	    my $yn = int($pointsN[1]);
	    if ($n == 1) { ## a couple of points
		$coords = "($x0, $y0, $xn, $yn)";
	    } else {
		$coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)";
	    }
	}
	if ($type eq 'curve' and @coords > 4) {
	    $fm->Button(-text => $coords,
			-command => [\&showcoords, $zinc, $item])
		->grid(-row => $i, -col => 7, -sticky => 'nswe', -ipadx => 5);
	} else {
	    $fm->Label(-text => $coords, -relief => 'ridge')
		->grid(-row => $i, -col => 7, -sticky => 'nswe', -ipadx => 5);
	}
	# device coords
	@coords = $zinc->transform(scalar $zinc->group($item), 1, [@coords]);
	if (@coords == 2) {
	    my $x0 = int($coords[0]);
	    my $y0 = int($coords[1]);
	    $coords = "($x0, $y0)";
	} elsif (@coords == 4) {
	    my $x0 = int($coords[0]);
	    my $y0 = int($coords[1]);
	    my $x1 = int($coords[2]);
	    my $y1 = int($coords[3]);
	    $coords = "($x0, $y0, $x1, $y1)";
	} else {
	    my $x0 = int($coords[0]);
	    my $y0 = int($coords[1]);
	    my $xn = int($coords[$#coords-1]);
	    my $yn = int($coords[$#coords]);
	    my $n = @coords/2 - 1;
	    $coords = "C0=($x0, $y0), ..., C".$n."=($xn, $yn)";
	}
	if ($type eq 'curve' and @coords > 4) {
	    $fm->Button(-text => $coords,
			-command => [\&showdevicecoords, $zinc, $item])
		->grid(-row => $i, -col => 8, -sticky => 'nswe', -ipadx => 5);
	} else {
	    $fm->Label(-text => $coords, -relief => 'ridge')
		->grid(-row => $i, -col => 8, -sticky => 'nswe', -ipadx => 5);
	}
	# bounding box
	my @bbox = $zinc->bbox($item);
	$fm->Label(-text => "($bbox[0], $bbox[1]), ($bbox[2], $bbox[3])",
		   -relief => 'ridge')
	    ->grid(-row => $i, -col => 9, -sticky => 'nswe', -ipadx => 5);
	# tags
  	my @tags = $zinc->gettags($item);
	$fm->Label(-text => join("\n", @tags),
		   -relief => 'ridge')
	    ->grid(-row => $i, -col => 10, -sticky => 'nswe', -ipadx => 5);
	$fm->Button(-text => 'Other options',
		    -command => [\&showotheroptions, $zinc, $item])
	    ->grid(-row => $i, -col => 11, -sticky => 'nswe', -ipadx => 5);
	$i++;
	&showbanner($fm, $i++) if ($i % 15 == 0);
    }
    $fm->update;
    return ($fm->width, $fm->height);
    
} # end showattributes

#---------------------------------------------------------------------------
#
# SNAPSHOT FUNCTIONS
#
#---------------------------------------------------------------------------

# print a zinc window in png format
sub printWindow {
    exit if $saving;
    $saving = 1;
    my ($zinc,$basename,$verbosity) = @_;
    my $id = $zinc->id;
    my $filename = $basename . $imagecounter . ".png";
    $imagecounter++;
    my $original_cursor = ($zinc->configure(-cursor))[3];
    $zinc->configure(-cursor => 'watch');
    $zinc->update;
    my $res = system("import", -window, $id, $filename);
    $zinc->configure(-cursor => $original_cursor);
    
    $saving = 0;
    if ($res) {
	&showErrorWhilePrinting($res)
	}
    else {
	my $dir = `pwd`; chomp ($dir);
	print "ZincDebug: Zinc window snapshot saved in $dir". "/$filename\n"
	    if $verbosity;
    }

} # end printWindow


# display complete help screen
sub showErrorWhilePrinting {
    my ($res) = @_;
    my $dir = `pwd`; chomp ($dir);
    $help_print->destroy if $help_print and Tk::Exists($help_print);
    $help_print = $zinc->Dialog(-title => 'Zinc Print info',
				-text =>
				"To acquire a TkZinc window snapshot, you must " .
				"have access to the import command, which is ".
				"part of imageMagic package\n\n".
				"You must also have the rights to write ".
				"in the current dir : $dir",
				-bitmap => 'warning',
				);
    $help_print->after(300, sub {$help_print->grabRelease});
    $help_print->Show();

} # end showErrorWhilePrinting

#---------------------------------------------------------------------------
#
# HELP FUNCTION
#
#---------------------------------------------------------------------------
# display complete help screen
sub showgeneralhelp {
    my $text;
    if ($enclosedModBtn) {
	my $eseq = $enclosedModBtn->[0]."-Button".$enclosedModBtn->[1];
	my $oseq = $overlapModBtn->[0]."-Button".$overlapModBtn->[1];
	$text .= "With <".$oseq."> sequence, create ".
	         "a rectangular area to search items ".
		 "which overlap it.\n".
		 "With <".$eseq."> sequence, create ".
		 "a rectangular area to search items ".
	         "which are enclosed in it.\n".
		 "With <".$searchKey."> sequence, search a specific ".
		 "item id using an entry field.\n\n";
    }
    if ($treeKey) {
	my $tseq = $treeModBtn->[0]."-Button".$treeModBtn->[1];
	$text .= "With <".$treeKey."> sequence, you build and display ".
	         "the items tree.\n".
		 "With <".$tseq."> sequence, select a particular item ".
		 "in the application window and see its position in the".
	         "tree.\n\n";
    }
    if ($snapKey) {
	$text .= "With <".$snapKey."> sequence you can acquire " .
	         "a snapshot of the full zinc window. ".
		 "It will be saved in the current directory ".
		 "with the name zincsnapshot<n>.png ".
		 "The ImageMagic package must be installed.\n\n";
    }
    $text .= "Strike <Escape> key to display this help message again.";
    
    $help_tl->destroy if $help_tl and Tk::Exists($help_tl);
    $help_tl = $zinc->Dialog(-title => 'Zinc Debug info',
			     -text => $text,
			     -bitmap => 'info',
			     );
    $help_tl->after(300, sub {$help_tl->grabRelease});
    $help_tl->Show();

} # end showgeneralhelp


# display help about tree
sub showHelpAboutTree {
    $helptree_tl->destroy if $helptree_tl and Tk::Exists($helptree_tl);
    $helptree_tl = $tree_tl->Toplevel;
    $helptree_tl->title("Help about Tree");

    my $text = $helptree_tl->Text(-font => scalar $zinc->cget(-font),
				  -wrap => 'word',
				  -foreground => 'gray10',
				  );
    $text->tagConfigure('keyword', -foreground => 'darkblue');
    $text->insert('end', "\nNAVIGATION IN TREE\n\n");
    $text->insert('end', "<Up>", "keyword");
    $text->insert('end', " arrow key moves the anchor point to the item right on ".
		  "top of the current anchor item. ");
    $text->insert('end', "<Down>", "keyword");
    $text->insert('end', " arrow key moves the anchor point to the item right below ".
		  "the current anchor item. ");
    $text->insert('end', "<Left>", "keyword");
    $text->insert('end', " arrow key moves the anchor to the parent item of the ".
		  "current anchor item. ");
    $text->insert('end', "<Right>", "keyword");
    $text->insert('end', " moves the anchor to the first child of the current anchor ".
		  "item. If the current anchor item does not have any children, moves ".
		  "the anchor to the item right below the current anchor item.\n\n");
    $text->insert('end', "\nHIGHLIGHTING ITEMS\n\n");
    $text->insert('end', "To display item's features, ");
    $text->insert('end', "double-click", "keyword");
    $text->insert('end', " on it or press ");
    $text->insert('end', "<Return>", "keyword");
    $text->insert('end', " key.\n\n");
    $text->insert('end', "To highlight item in the application, simply ");
    $text->insert('end', "click", "keyword");
    $text->insert('end', " on it. ");
    &infoAboutHighlighting($text);
    $text->configure(-state => 'disabled');
    
    $helptree_tl->Button(-command => sub {$helptree_tl->destroy},
			 -text => 'Close')->pack(-side => 'bottom',
						 -pady => 10);
    $text->pack->pack(-side => 'top', -pady => 10, -padx => 10);
} # end showHelpAboutTree



sub showHelpAboutAttributes {
    my $widget = shift;
    $helptree_tl->destroy if $helptree_tl and Tk::Exists($helptree_tl);
    $helptree_tl = $widget->Toplevel;
    $helptree_tl->title("Help about attributes");

    my $text = $helptree_tl->Text(-font => scalar $zinc->cget(-font),
				  -wrap => 'word',
				  -foreground => 'gray10',
				  );
    $text->tagConfigure('keyword', -foreground => 'darkblue');

    
    $text->insert('end',
		  "First column contains items identifiers buttons you can press to ".
		  "highlight corresponding items in the application.\n");
    &infoAboutHighlighting($text);
    $text->insert('end', "\n\nThird column contains groups identifiers buttons you can ".
		  "press to display groups content and attributes.");
    $text->configure(-state => 'disabled');
    
    $helptree_tl->Button(-command => sub {$helptree_tl->destroy},
			 -text => 'Close')->pack(-side => 'bottom',
						 -pady => 10);
    $text->pack->pack(-side => 'top', -pady => 10, -padx => 10);

} # end showHelpAboutAttributes



sub infoAboutHighlighting {
    my $text = shift;
    $text->insert('end', "By default, using ");
    $text->insert('end', "left mouse button", "keyword");
    $text->insert('end', ", highlighting is done by raising selected item and drawing ".
		  "a rectangle arround. ");
    $text->insert('end', "In order to improve visibility, ");
    $text->insert('end', "item will be light backgrounded if you use ");
    $text->insert('end', "center mouse button", "keyword");
    $text->insert('end', " and dark backgrounded if you use ");
    $text->insert('end', "right mouse button", "keyword");
    $text->insert('end', ". ");
    
} # end infoAboutHighlighting


1;

__END__


=head1 NAME

ZincDebug - a perl module for analysing a Zinc application. 


=head1 SYNOPSIS

 perl -MZincDebug zincapplication.pl

   or
    
 use ZincDebug;
 my $zinc = MainWindow->new()->Zinc()->pack;
 finditems($zinc);
 tree($zinc);
 snapshot($zinc);


=head1 DESCRIPTION

ZincDebug provides an interface to help developers to debug or analyse Zinc applications.

With B<finditems> function, you are able to scan all items which are enclosed in a rectangular area you have first drawn by drag & drop, or all items which overlap it. Result is a Tk table which presents details (options, coordinates, ...) about found items; you can also highlight a particular item, even if it's not visible, by clicking on its corresponding button in the table. You can also display particular item's features by entering this id in dedicated entry field

B<tree> function displays item's hierarchy. You can find a particular item's position in the tree and you can highlight items and see their features as described above.

With B<snapshot> function, you are able to snapshot the application window, in order to illustrate a graphical bug for example.
    
Press B<Escape> key in the main window of the application to have some help about available input sequences.

If you load ZincDebug using the -M perl option, nothing needs to be added to your code. In this mode, a process parse the main symbols table in order to detect zinc instance. So, it works only if zinc instance is stored in a global (not lexical) variable of the main package.


=head1 FUNCTIONS 


=over

=item B<finditems>($zinc, ?option => value, ...?)

This function creates required Tk bindings to permit items search. You can specify the following options :

=over

=item E<32>E<32>E<32>B<-color> => color

Defines color of search area contour. Default to 'sienna'.

=item E<32>E<32>E<32>B<-enclosedModBtn> => [Mod, Btn]

Defines input sequence used to process "enclosed" search. Default to ['Control', 3].

=item E<32>E<32>E<32>B<-overlapModBtn> => [Mod, Btn]

Defines input sequence used to process "overlap" search. Default to ['Shift', 3].

=item E<32>E<32>E<32>B<-searchKey> => key

Defines input key used to process particular search. Default to 'Control-f'.

=back

=item B<tree>($zinc, ?option => value, ...?)

This function creates required Tk bindings to build items tree. You can specify the following options :

=over

=item E<32>E<32>E<32>B<-key> => key

Defines input sequence used to build and display items tree. Default to 'Control-t'.

=item E<32>E<32>E<32>B<-itemModBtn> => [Mod, Btn]

Defines input sequence used to select an item in the application window in order to display its position in the item's tree. Default to ['Control', 2].

=item E<32>E<32>E<32>B<-optionsToDisplay> => opt1[,..,optN]

Used to display some option's values associated to items of tree. Expected argument is a string of commas separated options.


=item E<32>E<32>E<32>B<-optionsFormat> => row | column

Defines the display format of option's values. Default is 'column'.

=back

    
=item B<snapshot>($zinc, ?option => value, ...?)

This function creates required Tk binding to snapshot the application window. You can specify the following options :

=over

=item E<32>E<32>E<32>B<-key> => key

Defines input key used to process a snapshot of the zinc window. Default to ['Control-s'].

=item E<32>E<32>E<32>B<-verbosity> => boolean

Defines if snapshot should print a message on the terminal. Default to true.

=item E<32>E<32>E<32>B<-basename> => "a_string"

Defines the basename used for the file containing the snaphshot. The filename will be <currentdir>/basename<n>.png  Defaulted to zincsnapshot.


=back

=back
    
=head1 LIMITATIONS

ZincDebug is currently able to manage only one zinc instance.

=head1 AUTEURS

Daniel Etienne <etienne@cena.fr>

Christophe Mertz <mertz@cena.fr>