diff options
Diffstat (limited to 'Perl')
| -rw-r--r-- | Perl/Zinc/Debug.pm | 132 |
1 files changed, 112 insertions, 20 deletions
diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm index 57f5923..66738da 100644 --- a/Perl/Zinc/Debug.pm +++ b/Perl/Zinc/Debug.pm @@ -30,7 +30,8 @@ use Tk::Balloon; my ($itemstyle, $groupstyle, $step); my (%result_tl, $result_fm, $search_tl, $helptree_tl, %coords_tl, %transfo_tl, - $helpcoords_tl, $searchtree_tl, $tree_tl, %alloptions_tl, $tree); + $helpcoords_tl, $searchtree_tl, $tree_tl, %alloptions_tl, $tree, + $cursorxy_tl, $cursorxy); my $showitemflag; my ($x0, $y0); my ($help_print, $imagecounter, $saving) = (0, 0, 0); @@ -132,7 +133,7 @@ sub init { my $fm2 = $control_tl->Frame()->pack(-side => 'left', -padx => 20); my $fm3 = $control_tl->Frame()->pack(-side => 'left', -padx => 0); - for (qw(zn findenclosed findoverlap tree item id snapshot)) { + for (qw(zn findenclosed findoverlap tree item id snapshot cursorxy)) { $button{$_} = $fm1->Checkbutton(-image => $bitmaps->{$_}, -indicatoron => 0, -foreground => 'gray20')->pack(-side => 'left'); @@ -168,7 +169,7 @@ sub init { # findenclosed mode $on_command{findenclosed} = sub { - &savebindings($selectedzinc); + &saveDragAndDropBindings($selectedzinc); $button{findenclosed}->{Value} = 1; $selectedzinc->Tk::bind("<ButtonPress-1>", [\&startrectangle, 'simple', 'Enclosed', @@ -180,12 +181,12 @@ sub init { }; $off_command{findenclosed} = sub { $button{findenclosed}->{Value} = 0; - &restorebindings($selectedzinc); + &restoreDragAndDropBindings($selectedzinc); $selectedzinc->remove("zincdebugrectangle", "zincdebuglabel"); }; # findoverlap mode $on_command{findoverlap} = sub { - &savebindings($selectedzinc); + &saveDragAndDropBindings($selectedzinc); $button{findoverlap}->{Value} = 1; $selectedzinc->Tk::bind("<ButtonPress-1>", [\&startrectangle, 'mixed', 'Overlap', 'sienna']); @@ -196,22 +197,35 @@ sub init { }; $off_command{findoverlap} = sub { $button{findoverlap}->{Value} = 0; - &restorebindings($selectedzinc); + &restoreDragAndDropBindings($selectedzinc); $selectedzinc->remove("zincdebugrectangle", "zincdebuglabel"); }; # item mode $on_command{item} = sub { - &savebindings($selectedzinc); + &saveDragAndDropBindings($selectedzinc); $button{item}->{Value} = 1; $selectedzinc->Tk::bind("<ButtonPress-1>", [\&findintree]); }; $off_command{item} = sub { $button{item}->{Value} = 0; - &restorebindings($selectedzinc); + &restoreDragAndDropBindings($selectedzinc); }; + # cursor device position mode + $on_command{cursorxy} = sub { + &saveMotionBinding($selectedzinc); + $button{cursorxy}->{Value} = 1; + &cursorxyOpen; + $selectedzinc->Tk::bind("<Motion>", [\&cursorxy]); + }; + $off_command{cursorxy} = sub { + $button{cursorxy}->{Value} = 0; + &cursorxyClose; + &restoreMotionBinding($selectedzinc); + }; + # move mode $on_command{move} = sub { - &savebindings($selectedzinc); + &saveDragAndDropBindings($selectedzinc); $button{move}->{Value} = 1; my ($x0, $y0); $selectedzinc->Tk::bind('<ButtonPress-1>', sub { @@ -227,14 +241,14 @@ sub init { }; $off_command{move} = sub { $button{move}->{Value} = 0; - &restorebindings($selectedzinc); + &restoreDragAndDropBindings($selectedzinc); }; # zn mode $on_command{zn} = sub { $button{zn}->{Value} = 1; for my $zinc (&instances) { $zinc->remove("zincdebugrectangle", "zincdebuglabel"); - &savebindings($zinc); + &saveDragAndDropBindings($zinc); my $r; $zinc->Tk::bind("<ButtonPress-1>", sub { $zinc->update; @@ -255,11 +269,11 @@ sub init { $off_command{zn} = sub { $button{zn}->{Value} = 0; for my $zinc (&instances) { - &restorebindings($zinc); + &restoreDragAndDropBindings($zinc); } }; - my @but = qw(findenclosed findoverlap item move zn); + my @but = qw(findenclosed findoverlap item move zn cursorxy); for my $name (@but) { $button{$name}->configure(-command => sub { if ($button{$name}->{Value} == 1) { @@ -313,7 +327,7 @@ sub init { $button{close}->configure(-command => sub { $button{close}->update; &Tk::Zinc::Debug::iconify; - &restorebindings($selectedzinc); + &restoreDragAndDropBindings($selectedzinc); for my $name (@but) { &{$off_command{$name}}; } @@ -356,6 +370,41 @@ sub snapshot { #--------------------------------------------------------------------------- # +# Functions related to cursor position +# +#--------------------------------------------------------------------------- +sub cursorxy { + + my $ev = shift->XEvent; + $cursorxy = $ev->x.", ".$ev->y; + +} # end cursorxy + + +sub cursorxyOpen { + + if (Tk::Exists($cursorxy_tl)) { + $cursorxy_tl->raise; + return; + } + $cursorxy_tl = $control_tl->Toplevel; + $cursorxy_tl->Label(-text => "Cursor device position")->pack; + $cursorxy_tl->Label(-textvariable => \$cursorxy)->pack; + $cursorxy_tl->minsize(150, 40); + $cursorxy_tl->raise; + +} # end cursorxyOpen + + +sub cursorxyClose { + + $cursorxy_tl->destroy if Tk::Exists($cursorxy_tl); + +} # end cursorxyClose + + +#--------------------------------------------------------------------------- +# # Functions related to items tree # #--------------------------------------------------------------------------- @@ -2517,6 +2566,22 @@ static unsigned char balloon_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; EOF + $bitmaps->{cursorxy} = $zinc->toplevel->Bitmap(-data => <<EOF); +#define balloon_width 29 +#define balloon_height 29 +static unsigned char balloon_bits[] = { + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, + 0x00, 0x06, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0x7c, 0x00, 0x00, + 0x00, 0x1c, 0x00, 0x00, 0x00, 0x28, 0x00, 0x00, 0x00, 0x48, 0x00, 0x00, + 0x00, 0x80, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x02, 0x00, + 0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x30, 0x06, 0x8c, 0x01, 0x70, 0x07, 0x8c, 0x01, 0x60, 0x03, 0x8c, 0x01, + 0xc0, 0x01, 0xd8, 0x00, 0xc0, 0x01, 0xd8, 0x00, 0x60, 0xe3, 0xd8, 0x00, + 0x70, 0x66, 0x70, 0x00, 0x30, 0x66, 0x70, 0x00, 0x00, 0x30, 0x60, 0x00, + 0x00, 0x30, 0x30, 0x00, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, }; +EOF + return $bitmaps; } # end createBitmaps @@ -2615,31 +2680,56 @@ sub instances { } # end instances -sub savebindings { +sub saveMotionBinding { + + my ($zinc) = @_; + for my $seq ('Motion') { + $userbindings{$zinc}->{$seq} = $zinc->Tk::bind('<'.$seq.'>') + unless defined $userbindings{$zinc}->{$seq}; + $userbindings{$zinc}->{$seq} = "" unless defined $userbindings{$zinc}->{$seq}; + $zinc->Tk::bind('<'.$seq.'>', ""); + } + +} # end saveMotionBinding + + +sub restoreMotionBinding { + + my ($zinc) = @_; + for my $seq ('Motion') { + next unless defined $userbindings{$zinc}->{$seq}; + $zinc->Tk::bind('<'.$seq.'>', $userbindings{$zinc}->{$seq}); + delete $userbindings{$zinc}->{$seq}; + } + +} # end restoreMotionBinding + + +sub saveDragAndDropBindings { my ($zinc) = @_; for my $seq ('ButtonPress-1', 'B1-Motion', 'ButtonRelease-1') { $userbindings{$zinc}->{$seq} = $zinc->Tk::bind('<'.$seq.'>') unless defined $userbindings{$zinc}->{$seq}; $userbindings{$zinc}->{$seq} = "" unless defined $userbindings{$zinc}->{$seq}; - #print "savebindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n"; + #print "saveDragAndDropBindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n"; $zinc->Tk::bind('<'.$seq.'>', ""); } -} # end savebindings +} # end saveDragAndDropBindings -sub restorebindings { +sub restoreDragAndDropBindings { my ($zinc) = @_; for my $seq ('ButtonPress-1', 'B1-Motion', 'ButtonRelease-1') { next unless defined $userbindings{$zinc}->{$seq}; $zinc->Tk::bind('<'.$seq.'>', $userbindings{$zinc}->{$seq}); - #print "restorebindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n"; + #print "restoreDragAndDropBindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n"; delete $userbindings{$zinc}->{$seq}; } -} # end restorebindings +} # end restoreDragAndDropBindings sub newinstance { @@ -2671,6 +2761,7 @@ sub deiconify { $tree_tl->deiconify if Tk::Exists($tree_tl); $search_tl->deiconify if Tk::Exists($search_tl); $searchtree_tl->deiconify if Tk::Exists($searchtree_tl); + $cursorxy_tl->deiconify if Tk::Exists($cursorxy_tl); $control_tl->raise(); } # end deiconify @@ -2690,6 +2781,7 @@ sub iconify { $tree_tl->withdraw if Tk::Exists($tree_tl); $search_tl->withdraw if Tk::Exists($search_tl); $searchtree_tl->withdraw if Tk::Exists($searchtree_tl); + $cursorxy_tl->withdraw if Tk::Exists($cursorxy_tl); $control_tl->withdraw(); } # end iconify |