path: root/Perl/Zinc/Debug.pm

#        ZincDebug Perl Module :
#
#        For debugging/analysing a Zinc application
#
#        Author : Daniel Etienne <etienne@cena.fr>
#
# $Id$
#---------------------------------------------------------------------------
package ZincDebug;


use strict 'vars';
use vars qw(@ISA @EXPORT);
use Carp;
require Exporter;
use File::Basename;
use Tk::Zinc;
use Tk::LabFrame;
use Tk::Pane;
use Tk::Dialog;

@ISA = qw(Exporter);
@EXPORT = qw(finditems);

my ($help_tl0, $help_tl, $result_tl, $result_fm, $showitemflag);
my ($text_id, $rectangle_id);
my ($x0, $y0);
my $zinc;

sub finditems {
    $zinc = shift;
    # 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' );
    }
    my $color = ($options{-color}) ? $options{-color} : 'sienna';
    my $ekb = ($options{-enclosedModBtn}) ? $options{-enclosedModBtn} :	['Control', 3];
    my $okb = ($options{-overlapModBtn}) ? $options{-overlapModBtn} : ['Shift', 3];
    carp "in ZincDebug module, finditems function, enclosed search won't work because ".
	"both search process use the same sequence [$ekb->[0], $ekb->[1]]\n" if
	    $ekb->[0] eq $okb->[0] and $ekb->[1] eq $okb->[1];
    #
    # binding for help screen
    #
    $zinc->toplevel->Tk::bind('<Key-Escape>', [\&showhelp, $ekb, $okb]);
    #
    # bindings for Enclosed search
    #
    $zinc->Tk::bind("<".$ekb->[0]."-".$ekb->[1].">",
		    [\&startrectangle, 'simple', 'Enclosed', $color]);
    $zinc->Tk::bind("<".$ekb->[0]."-B".$ekb->[1]."-Motion>", \&resizerectangle);
    $zinc->Tk::bind("<".$ekb->[0]."-B".$ekb->[1]."-ButtonRelease>",
		    [\&stoprectangle, 'enclosed', 'Enclosed search']);    
    #
    # bindings for Overlap search
    #
    $zinc->Tk::bind("<".$okb->[0]."-".$okb->[1].">",
		    [\&startrectangle, 'mixed', 'Overlap', $color]);
    $zinc->Tk::bind("<".$okb->[0]."-B".$okb->[1]."-Motion>", \&resizerectangle);
    $zinc->Tk::bind("<".$okb->[0]."-B".$okb->[1]."-ButtonRelease>",
		    [\&stoprectangle, 'overlapping', 'Overlap search']);
}

#------------------------------------------------------------------------------------
# display in a toplevel the result of search
sub showresult {
    my ($label, $zinc, @items) = @_;
    $result_fm->destroy if Tk::Exists($result_fm);
    $result_fm = $result_tl->Scrolled('Pane',
				      -scrollbars => 'se',
				      -width => scalar $result_tl->screenwidth,
				      -height => 500,
				      );

    $result_fm->pack(-padx => 10, -pady => 10,
		     -ipadx => 10,
		     -fill => 'both',
		     -expand => 1,
		     );
    &showattributes($result_fm, \@items);
    $result_tl->deiconify;
    $result_tl->update;
}


# display in a toplevel the value of other options
sub showotheroptions {
    my ($zinc, $item) = @_;
    my $tl = MainWindow->new()->toplevel;
    my $title = "Other options of item $item";
    $tl->title($title);
    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, $value) = (@$elem)[0,4];
	next if ($option eq '-visible' or $option eq '-sensitive' or
		 $option eq '-tags' or $option eq '-position' or
		 $option eq '-priority');
	$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;    

}

sub showgroupattributes {
    my ($zinc, $item) = @_;
    my $tl = MainWindow->new()->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;
    # 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);
    $fm->Button(-text => $gr,
		-command => [\&showgroupattributes, $zinc, $gr])
	->grid(-row => $r++, -col => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    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)";
    } 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)";
    }
    $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)";
    } 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)";
    }
    $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 eq '-tags') {
	    $value = join("\n", @$value);
	} elsif ($option eq '-clip' 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;    

}


# display in a toplevel the content of a group item
sub showgroupcontent {
    my ($zinc, $group) = @_;
    my $tl = MainWindow->new()->toplevel;
    my $title = "Content of group $group";
    $tl->title($title);
    my $fm = $tl->LabFrame(-labelside => 'acrosstop',
			   -label => $title,
			   )->pack(-padx => 10, -pady => 10,
				   -ipadx => 10,
				   -fill => 'both');
    my @items = $zinc->find('all', $group);
    &showattributes($fm, \@items);
    $tl->Button(-text => 'Close',
		-command => sub {$tl->destroy})->pack;    
}

# highlight an item (by hiding other found items)
sub highlightitem {
    my ($zinc, $item) = @_;
    return if $showitemflag;
    $showitemflag = 1;
    my @visibility;

    my @itemstohide;
    for ($zinc->find('overlap', $zinc->coords($rectangle_id))) {
	push (@itemstohide, $_) unless $_ == $rectangle_id or $_ == $text_id;
    }
    for (@itemstohide) {
	push(@visibility, scalar $zinc->itemcget($_, -visible));
	$zinc->itemconfigure($_, -visible => 0);
    }
    my @coords = $zinc->coords($item);
    my $clone = $zinc->clone($item, -visible => 1);
    $zinc->chggroup($clone, 1);
    $zinc->coords($clone, [$zinc->transform(scalar $zinc->group($item), 1, [@coords])]);
    $zinc->raise($clone);

    $zinc->after(500, sub {
	for (my $i=0; $i < @itemstohide; $i++) {
	    $zinc->itemconfigure($itemstohide[$i], -visible => $visibility[$i]);
	}
	$zinc->remove($clone);
	$showitemflag = 0;
    });
}

# highlight an item (by hiding other found items)
# here, item's option -visible is set to 1 and others items are
# hidden; but, if item belongs to a invisible group, we can't
# see it!
sub highlightitem_old {
    my ($zinc, $item, $items) = @_;
    return if $showitemflag;
    $showitemflag = 1;
    my @visibility;
    for (@$items) {
	push(@visibility, scalar $zinc->itemcget($_, -visible));
	$zinc->itemconfigure($_, -visible => 0);
    }
    $zinc->itemconfigure($item, -visible => 1);

    $zinc->after(500, sub {
	for (my $i=0; $i < @$items; $i++) {
	    $zinc->itemconfigure($items->[$i], -visible => $visibility[$i]);
	}
	$showitemflag = 0;
    });
}

# display complete help screen
sub showhelp {
    my ($w, $ekb, $okb) = @_;
    my $eseq = $ekb->[0]."-Button".$ekb->[1];
    my $oseq = $okb->[0]."-Button".$okb->[1];
    $help_tl->destroy if $help_tl and Tk::Exists($help_tl);
    $help_tl = $zinc->Dialog(-title => 'Zinc Debug info',
			     -text =>
			     "With <".$oseq."> sequence, create ".
			     "a rectangular area to search items ".
			     "which overlap it.\n\n".
			     "With <".$eseq."> sequence, create ".
			     "a rectangular area to search items ".
			     "which are enclosed in it.\n\n".
			     "Strike <Escape> key to display this help ".
			     "message again.",
			     -bitmap => 'info',
			     );
    $help_tl->after(300, sub {$help_tl->grabRelease});
    $help_tl->Show();
}

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);
     
}

# 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) {
	# id
	$fm->Button(-text => $item,
		    -foreground => 'red',
		    -command => [\&highlightitem, $zinc, $item])
	    ->grid(-row => $i, -col => 1, -sticky => 'nswe', -ipadx => 5);
	# type
	my $type = $zinc->type($item);
	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 (@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)";
	}
	$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)";
	}
	$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);
    }
}

# begin to draw rectangular area for search
sub startrectangle {
    my ($widget, $style, $text, $color) = @_;
    if (not $result_tl or not Tk::Exists($result_tl)) {
	$result_tl = MainWindow->new()->toplevel();
	$result_tl->title("Zinc Debug");
	$result_tl->Button(-text => 'Close',
			   -command => sub {
			       $result_tl->destroy;
			       $zinc->remove($rectangle_id, $text_id);
			       })->pack(-side => 'bottom');
    }
    $zinc->remove($rectangle_id, $text_id);
    $result_tl->iconify;
    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,
			  );
  
}

# resize the rectangular area for search
sub resizerectangle {
    my $ev = $zinc->XEvent;
    my ($x, $y) = ($ev->x, $ev->y);
    $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);
}

# stop drawing rectangular area for search
sub stoprectangle {
    my ($widget, $searchtype, $text) = @_;
    my @coords = $zinc->coords($rectangle_id);
    my @items;
    for my $item ($zinc->find($searchtype, @coords)) {
	push (@items, $item) if $item != $rectangle_id and
	    $item != $text_id;
    }
    &showresult($text, $zinc, @items);

}

1;

__END__


=head1 NAME

ZincDebug - a perl module for analysing a Zinc application. 


=head1 SYNOPSIS

 use ZincDebug;
 my $zinc = MainWindow->new()->Zinc()->pack;
 finditems($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, 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.

    
=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].


=back

=back
    
=head1 AUTEURS

Daniel Etienne <etienne@cena.fr>