# bind.pl

use vars qw/$TOP/;

sub bind {

    # Create a top-level window that illustrates how you can bind Perl
    # commands to regions of text in a text widget.

    my($demo) = @_;
    $TOP = $MW->WidgetDemo(
        -name     => $demo,
        -text     =>'',                      
        -title    => 'Text Demonstration - Tag Bindings',
        -iconname => 'bind',
    );

    my $t = $TOP->Scrolled(qw/Text -setgrid true -width 60 -height 24
               -scrollbars e -wrap word/, -font => $FONT);
    $t->pack(qw/-expand yes -fill both/);

    # Set up display styles

    my(@bold, @normal, $tag);
    if ($TOP->depth > 1) {
    @bold   = (-background => '#43ce80', qw/-relief raised -borderwidt
+h 1/);
    @normal = (-background => undef, qw/-relief flat/);
    } else {
    @bold   = (qw/-foreground white -background black/);
    @normal = (-foreground => undef, -background => undef);
    }

    $t->insert('0.0', "The same tag mechanism that controls display st
+yles in text widgets can also be used to associate Perl commands with
+ regions of text, so that mouse or keyboard actions on the text cause
+ particular Perl commands to be invoked.  For example, in the text be
+low the descriptions of the canvas demonstrations have been tagged.  
+When you move the mouse over a demo description the description light
+s up, and when you press button 1 over a description then that partic
+ular demonstration is invoked.\n\n");
    $t->insert('end','1. Samples of all the different types of items t
+hat can be created in canvas widgets.', 'd1');
    $t->insert('end', "\n\n");
    $t->insert('end', '2. A simple two-dimensional plot that allows yo
+u to adjust the positions of the data points.', 'd2');
    $t->insert('end', "\n\n");
    $t->insert('end', '3. Anchoring and justification modes for text i
+tems.', 'd3');
    $t->insert('end', "\n\n");
    $t->insert('end', '4. An editor for arrow-head shapes for line ite
+ms.', 'd4');
    $t->insert('end', "\n\n");
    $t->insert('end', '5. A ruler with facilities for editing tab stop
+s.', 'd5');
    $t->insert('end', "\n\n");
    $t->insert('end', '6. A grid that demonstrates how canvases can be
+ scrolled.', 'd6');

    foreach $tag (qw(d1 d2 d3 d4 d5 d6)) {
    $t->tag('bind', $tag, '<Any-Enter>' => 
            sub {shift->tag('configure', $tag, @bold)}
        );
    $t->tag('bind', $tag, '<Any-Leave>' =>
            sub {shift->tag('configure', $tag, @normal)}
        );
    }
    $t->tag(qw/bind d1 <1>/ => sub {&items('items')});
    $t->tag(qw/bind d2 <1>/ => sub {&plot('plot')});
    $t->tag(qw/bind d3 <1>/ => sub {&ctext('ctext')});
    $t->tag(qw/bind d4 <1>/ => sub {&arrows('arrows')});
    $t->tag(qw/bind d5 <1>/ => sub {&ruler('ruler')});
    $t->tag(qw/bind d6 <1>/ => sub {&cscroll('cscroll')});

    $t->mark(qw/set insert 0.0/);

} # end bind

1;
[download]

# items.pl

use subs qw/items_button_press items_drag items_enter items_leave item
+s_mark
        items_start_drag items_stroke items_under_area/;
use vars qw/$TOP/;

sub items {

    # Create a top-level window containing a canvas that displays the 
+various
    # item types and allows them to be selected and moved.

    my($demo) = @_;
    $TOP = $MW->WidgetDemo(
        -name     => $demo,
        -text     => ["This window contains a canvas widget with examp
+les of the various kinds of items supported by canvases.  The followi
+ng operations are supported:\n  Button-1 drag:\tmoves item under poin
+ter.\n  Button-2 drag:\trepositions view.\n  Button-3 drag:\tstrokes 
+out area.\n Ctrl+f:\t\tdisplays items under area.", qw/-wraplength 5i
+/],
        -title    => 'Canvas Item Demonstration',
        -iconname => 'items',
    );

    my $c = $TOP->Scrolled(qw/Canvas -width 15c -height 10c -relief su
+nken
               -borderwidth 2 -scrollbars se -scrollregion/ =>
               [qw/0c 0c 30c 24c/]);
    $c->pack(qw/-expand yes -fill both/);

    my %iinfo = ();        # item information hash
    $iinfo{areaX1} = 0;
    $iinfo{areaY1} = 0;
    $iinfo{areaX2} = 0;
    $iinfo{areaY2} = 0;
    $iinfo{restore_cmd} = '';
    
                         
    if ($Tk::VERSION cmp '800.015') {
    # Display a 3x3 rectangular grid (800.016 or greater).
    $c->createGrid(qw/0c  0c 10c 8c -width 2 -lines 1/);
    $c->createGrid(qw/0c  0c 5c  4c -lines 1 -dash ./);
    $c->createGrid(qw/0c  0c 10m 8m -width 1/);
    } else {
    # Display a 3x3 rectangular grid.
    $c->createRectangle(qw/ 0c  0c 30c 24c -width 2/);
    $c->createLine     (qw/ 0c  8c 30c  8c -width 2/);
    $c->createLine     (qw/ 0c 16c 30c 16c -width 2/);
    $c->createLine     (qw/10c  0c 10c 24c -width 2/);
    $c->createLine     (qw/20c  0c 20c 24c -width 2/);
    }

    my $font1 = '-*-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*';
    my $font2 = '-*-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*';
    my($blue, $red, $bisque, $green);
    if ($TOP->depth > 1) {
    $blue = 'DeepSkyBlue3';
    $red = 'red';
    $bisque = 'bisque3';
    $green = 'SeaGreen3';
    } else {
    $blue = 'black';
    $red = 'black';
    $bisque = 'black';
    $green = 'black';
    }

    # Set up demos within each of the areas of the grid.

    $c->createText(qw/5c .2c -text Lines -anchor n/);
    $c->createLine(qw/1c 1c 3c 1c 1c 4c 3c 4c -width 2m/, -fill => $bl
+ue,
           qw/-cap butt -join miter -tags item/);
    $c->createLine(qw/4.67c 1c 4.67c 4c -arrow last -activedash - -tag
+s item/);
    $c->createLine(qw/6.33c 1c 6.33c 4c -arrow both -activedash . -tag
+s item/);
    $c->createLine(qw/5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1
+.2c
                   8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c
               8.4c 4.4c -width 3 -tags item -fill/ => $red);
    $c->createLine(qw/1c 5c 7c 5c 7c 7c 9c 7c -width .5c/,
               -stipple => '@'.Tk->findINC('demos/images/grey.25'),
               qw/-arrow both -tags item -arrowshape/ => [15, 15, 7]);
    $c->createLine(qw/1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width
+ .5c
               -cap round -join round -tags item/);

    $c->createText(qw/15c .2c -anchor n -text/ => 'Curves (smoothed li
+nes)');
    $c->createLine(qw/11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on/,
               -fill =>$blue, qw/-tags item/);
    $c->createLine(qw/15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth 
+on
               -arrow both -width 3 -tags item/);
    $c->createLine(qw/12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 1
+3.5c
               7.5c 12c 6c -smooth on -width 3m -cap round -tags item/
+,
               -stipple => '@'.Tk->findINC('demos/images/grey.25'),
               -fill => $red);

    $c->createText(qw/25c .2c -text Polygons -anchor n/);
    $c->createPolygon(qw/21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c 24c
+ 4.0c
                      22.5c 3.25c 21c 4.0c 21.75c 2.5c -tags item/,
                  -fill => $green);
    $c->createPolygon(qw/25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c
+ 1c
                  29c 4c 29c 4c -smooth on -tags item/, -fill => $red)
+;
    $c->createPolygon(qw/22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.2
+5c 24c
                  5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c -tags item/,
                  -stipple => '@'.Tk->findINC('demos/images/grey.25'))
+;

    $c->createText(qw/5c 8.2c -text Rectangles -anchor n/);
    $c->createRectangle(qw/1c 9.5c 4c 12.5c/, -outline => $red,
                    qw/-width 3m -tags item/);
    $c->createRectangle(qw/0.5c 13.5c 4.5c 15.5c/, -fill => $green,
                    qw/-tags item/);
    $c->createRectangle(qw/6c 10c 9c 15c -tags item/, -outline => unde
+f,
                    -stipple => '@'.Tk->findINC('demos/images/grey.25'
+),
                    -fill => $blue);

    $c->createText(qw/15c 8.2c -text Ovals -anchor n/);
    $c->createOval(qw/11c 9.5c 14c 12.5c/, -outline => $red,
               qw/-width 3m -tags item/);
    $c->createOval(qw/10.5c 13.5c 14.5c 15.5c/, -fill => $green,
               qw/-tags item/);
    $c->createOval(qw/16c 10c 19c 15c -tags item/, -outline => undef,
               -stipple => '@'.Tk->findINC('demos/images/grey.25'),
               -fill => $blue);

    $c->createText(qw/25c 8.2c -text Text -anchor n/);
    $c->createRectangle(qw/22.4c 8.9c 22.6c 9.1c/);
    $c->createText(qw/22.5c 9c -anchor n -width 4c/, -font => $font1,
               -text => 'A short string of text, word-wrapped, justifi
+ed left, and anchored north (at the top).  The rectangles show the an
+chor points for each piece of text.', qw/-tags item/);
    $c->createRectangle(qw/25.4c 10.9c 25.6c 11.1c/);
    $c->createText(qw/25.5c 11c -anchor w/, -font => $font1, -fill => 
+$blue,
               -text => "Several lines,\n each centered\n" .
               "individually,\nand all anchored\nat the left edge.",
               qw/-justify center -tags item/);
    $c->createRectangle(qw/24.9c 13.9c 25.1c 14.1c/);
    $c->createText(qw/25c 14c -anchor c/, -font => $font2, -fill => $r
+ed,
               -stipple => 'gray50',
               -text => 'Stippled characters', qw/-tags item/);

    $c->createText(qw/5c 16.2c -text Arcs -anchor n/);
    $c->createArc(qw/0.5c 17c 7c 20c/, -fill => $green, qw/-outline bl
+ack/,
              -stipple => '@'.Tk->findINC('demos/images/grey.25'),
              qw/-start 45 -extent 270 -style pieslice -tags item/);
    $c->createArc(qw/6.5c 17c 9.5c 20c -width 4m -style arc/, -fill =>
+ $blue,
              qw/-start -135 -extent 270 -tags item/);
    $c->createArc(qw/0.5c 20c 9.5c 24c -width 4m -style pieslice/,
              -fill => undef, -outline => $red,
              qw/-start 225 -extent -90 -tags item/);
    $c->createArc(qw/5.5c 20.5c 9.5c 23.5c -width 4m -style chord/,
              -fill => $blue, -outline => undef,
              qw/-start 45 -extent 270  -tags item/);

    $c->createText(qw/15c 16.2c -text Bitmaps -anchor n/);
    $c->createBitmap(qw/13c 20c -bitmap/ =>
                     '@'.Tk->findINC('demos/images/face'), qw/-tags it
+em/);
    $c->createBitmap(qw/17c 18.5c/,
                 -bitmap => '@'.Tk->findINC('demos/images/noletters'),
                 qw/-tags item/);
    $c->createBitmap(qw/17c 21.5c/,
                 -bitmap => '@'.Tk->findINC('demos/images/letters'),
                 qw/-tags item/);

    $c->createText(qw/25c 16.2c -text Windows -anchor n/);
    my $c_button = $c->Button(-text => 'Press Me',
        -command => [\&items_button_press, $c, $red],
    );
    $c->createWindow(qw/21c 18c/, -window => $c_button,
                 qw/-anchor nw -tags item/);
    my $c_entry = $c->Entry(-width => '20', -relief => 'sunken',
                            -validate => 'all',
                            -validatecommand => sub {$n++ ? 1 : 0},
                            -invalidcommand => sub {$TOP->bell});
    $c_entry->insert('end' => 'Edit this text');
    $c->createWindow(qw/21c 21c/, -window => $c_entry,
                 qw/-anchor nw -tags item/);
    my $c_scale = $c->Scale(qw/-from 0 -to 100 -length 6c -sliderlengt
+h .4c
                -width .5c -tickinterval 0/);
    $c->createWindow(qw/28.5c 17.5c/, -window => $c_scale,
                 qw/-anchor n -tags item/);
    $c->createText(qw/21c 17.9c -text Button: -anchor sw/);
    $c->createText(qw/21c 20.9c -text Entry: -anchor sw/);
    $c->createText(qw/28.5c 17.4c -text Scale: -anchor s/);

    # Set up event bindings for canvas.

    $c->bind('item', '<Any-Enter>' => [\&items_enter, \%iinfo]);
    $c->bind('item', '<Any-Leave>' => [\&items_leave, \%iinfo]);

    # Get real canvas widget reference to apply bind() commands to:  t
+he
    # Canvas widget is a subwidget of the Scrolled composite widget.  
+To
    # reference the X event structure, either use the XEvent() method 
+or
    # read the specially localized variable $Tk::event.  We'll use XEv
+ent
    # first, and the variable from then on.

    $c->CanvasBind('<<Copy>>',sub { print "Do Copy\n" });

    $c->CanvasBind('<1>' => sub {
    my($c) = @_;
        my $e = $c->XEvent;
    items_start_drag $c, $e->x, $e->y, \%iinfo;
    });
    $c->CanvasBind('<B1-Motion>' =>
        sub {items_drag shift, $Tk::event->x, $Tk::event->y, \%iinfo})
+;
    $c->CanvasBind('<2>' => 
        sub {shift->scan('mark', $Tk::event->x, $Tk::event->y)});
    $c->CanvasBind('<B2-Motion>' =>
         sub {shift->scan('dragto', $Tk::event->x, $Tk::event->y)});
    $c->CanvasBind('<3>' => 
         sub {items_mark shift, $Tk::event->x, $Tk::event->y, \%iinfo}
+);
    $c->CanvasBind('<B3-Motion>' =>
         sub {items_stroke shift, $Tk::event->x, $Tk::event->y, \%iinf
+o});
    $c->CanvasBind('<Control-f>' => [sub {
    my($c, $iinfo) = @_;
        my $e = $c->XEvent;
    items_under_area $c, $iinfo;
    }, \%iinfo]);
    $c->CanvasBind('<Any-Enter>' => sub {$_[0]->CanvasFocus});

} # end items

# Utility procedures for highlighting the item under the pointer:

sub items_button_press {

    # Procedure that's invoked when the button embedded in the canvas
    # is invoked.

    my($w, $color) = @_;

    my $i = $w->createText(qw/25c 18.1c -anchor n/, -text => 'Ouch!!',
               -fill => $color);
    $w->after(500, sub { $w->delete($i) });

} # end items_button_press

sub items_drag {

    my($c, $x, $y, $iinfo) = @_;

    $x = $c->canvasx($x);
    $y = $c->canvasy($y);
    $c->move('current', $x-$iinfo->{lastX}, $y-$iinfo->{lastY});
    $iinfo->{lastX} = $x;
    $iinfo->{lastY} = $y;

} # end items_drag

sub items_enter {

    my($c, $iinfo) = @_;

    $iinfo->{restore_cmd} = '';

    if ($TOP->depth == 1) {
    $iinfo->{restore_cmd} = '';
    return;
    }
    my $type = $c->type('current');
    if ($type eq 'window') {
    $iinfo->{restore_cmd} = '';
    return;
    }

    if ($type eq 'bitmap') {
    my $bg = ($c->itemconfigure(qw/current -background/))[4];
    if (defined $bg) {
        $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
                -background => '$bg');";
    } else {
        $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
                -background => undef);";
    }
    $c->itemconfigure(qw/current -background SteelBlue2/);
    return;
    }
    my $fill = ($c->itemconfigure(qw/current -fill/))[4];
    my $stipple = ($c->itemconfigure(qw/current -stipple/))[4];
    if (defined $stipple) {
    $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
            -stipple => '$stipple')";
    $c->itemconfigure(qw/current -stipple /,'');
    } elsif (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc
+')
        and not defined $fill) {
    my $outline = ($c->itemconfigure(qw/current -outline/))[4];
    $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
            -outline => '$outline')";
    $c->itemconfigure(qw/current -outline SteelBlue2/);
    } else {
    $iinfo->{restore_cmd} = "\$c->itemconfigure('current',
            -fill => '$fill')";
    $c->itemconfigure(qw/current -fill SteelBlue2/);
    }

} # end items_enter

sub items_leave {

    my($c, $iinfo) = @_;

    eval $iinfo->{restore_cmd};

} # end items_leave

sub items_mark {

    my($c, $x, $y, $iinfo) = @_;

    $iinfo->{areaX1} = $c->canvasx($x);
    $iinfo->{areaY1} = $c->canvasy($y);
    $c->delete('area');

} # end items_mark

sub items_start_drag {

    my($c, $x, $y, $iinfo) = @_;

    $iinfo->{lastX} = $c->canvasx($x);
    $iinfo->{lastY} = $c->canvasy($y);

} # end items_start_drag

sub items_stroke {

    my($c, $x, $y, $iinfo) = @_;

    $x = $c->canvasx($x);
    $y = $c->canvasy($y);
    if (($iinfo->{areaX1} != $x) and ($iinfo->{areaY1} != $y)) {
    $c->delete('area');
    $c->addtag('area', 'withtag', $c->create('rectangle',
        $iinfo->{areaX1}, $iinfo->{areaY1}, $x, $y, -outline => 'black
+'));
    $iinfo->{areaX2} = $x;
    $iinfo->{areaY2} = $y;
    }

} # end items_stroke

sub items_under_area {

    my($c, $iinfo) = @_;

    my $area = $c->find('withtag', 'area');
    my @items  = ();
    my $i;
    foreach $i ($c->find('enclosed', $iinfo->{areaX1},
            $iinfo->{areaY1}, $iinfo->{areaX2}, $iinfo->{areaY2})) {
    my @tags = $c->gettags($i); 
    if (defined($tags[0]) and grep $_ eq 'item', @tags) {
        push @items, $i;
    }
    }
    @items = 'None' unless @items;
    print STDOUT 'Items enclosed by area:  ', join(' ', @items), ".\n"
+;
    @items = ();
    foreach $i ($c->find('overlapping', $iinfo->{areaX1}, $iinfo->{are
+aY1},
            $iinfo->{areaX2}, $iinfo->{areaY2})) {
    my @tags = $c->gettags($i); 
    if (defined($tags[0]) and grep $_ eq 'item', @tags) {
        push @items, $i;
    }
    }
    @items = 'None' unless @items;
    print STDOUT 'Items overlapping area:  ', join(' ', @items), ".\n"
+;

} # end items_under_area

1;
[download]