home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.8.3.809-MSWin32-x86.msi / _461eb5274fcd31f71f07fd28ca3ae481 < prev    next >
Encoding:
Text File  |  2004-02-02  |  12.7 KB  |  339 lines
  1.  
  2.  
  3. # Utility procedures for highlighting the item under the pointer:
  4.  
  5.  
  6. sub itemEnter {
  7.  
  8.     my($c) = @_;
  9.  
  10.     $mkItems::restoreCmd = '';
  11.  
  12.     if ($mkItems->depth == 1) {
  13.     $mkItems::restoreCmd = '';
  14.     return;
  15.     }
  16.     my $type = $c->type('current');
  17.     if ($type eq 'window') {
  18.     $mkItems::restoreCmd = '';
  19.     return;
  20.     }
  21.  
  22.     if ($type eq 'bitmap') {
  23.     my $bg = ($c->itemconfigure('current', -background))[4];
  24.     if (defined $bg) {
  25.         $mkItems::restoreCmd = "\$c->itemconfigure('current', -background => '$bg');";
  26.     } else {
  27.         $mkItems::restoreCmd = "\$c->itemconfigure('current', -background => undef);";
  28.     }
  29.     $c->itemconfigure('current', -background => 'SteelBlue2');
  30.     return;
  31.     }
  32.     my $fill = ($c->itemconfigure('current', -fill))[4];
  33.     if (($type eq 'rectangle' or $type eq 'oval' or $type eq 'arc') and not defined $fill) {
  34.     my $outline = ($c->itemconfigure('current', -outline))[4];
  35.     $mkItems::restoreCmd = "\$c->itemconfigure('current', -outline => '$outline')";
  36.     $c->itemconfigure('current', -outline => 'SteelBlue2');
  37.     } else {
  38.     $mkItems::restoreCmd = "\$c->itemconfigure('current', -fill => '$fill')";
  39.     $c->itemconfigure('current', -fill => 'SteelBlue2');
  40.     }
  41.  
  42. } # end itemEnter
  43.  
  44.  
  45. sub itemLeave {
  46.  
  47.     local ($c) = @_;
  48.  
  49.     eval $mkItems::restoreCmd;
  50.  
  51. } # end itemLeave
  52.  
  53.  
  54. # Utility procedures to support dragging of items.
  55.  
  56.  
  57. sub itemStartDrag {
  58.  
  59.     my($c, $x, $y) = @_;
  60.  
  61.     $mkItems::lastX = $c->canvasx($x);
  62.     $mkItems::lastY = $c->canvasy($y);
  63.  
  64. } # end itemStartDrag
  65.  
  66.  
  67. sub itemDrag {
  68.  
  69.     my($c, $x, $y) = @_;
  70.  
  71.     $x = $c->canvasx($x);
  72.     $y = $c->canvasy($y);
  73.     $c->move('current', $x-$mkItems::lastX, $y-$mkItems::lastY);
  74.     $mkItems::lastX = $x;
  75.     $mkItems::lastY = $y;
  76.  
  77. } # end itemDrag
  78.  
  79.  
  80. # Utility procedures for stroking out a rectangle and printing what's underneath the rectangle's area.
  81.  
  82.  
  83. $mkItems::areaX1 = 0;
  84. $mkItems::areaY1 = 0;
  85. $mkItems::areaX2 = 0;
  86. $mkItems::areaY2 = 0;
  87.  
  88.  
  89. sub itemMark {
  90.  
  91.     my($c, $x, $y) = @_;
  92.  
  93.     $mkItems::areaX1 = $c->canvasx($x);
  94.     $mkItems::areaY1 = $c->canvasy($y);
  95.     $c->delete('area');
  96.  
  97. } # end itemMark
  98.  
  99.  
  100. sub itemStroke {
  101.  
  102.     my($c, $x, $y) = @_;
  103.  
  104.     $x = $c->canvasx($x);
  105.     $y = $c->canvasy($y);
  106.     if (($mkItems::areaX1 != $x) and ($mkItems::areaY1 != $y)) {
  107.     $c->delete('area');
  108.     $c->addtag('area', 'withtag', $c->create('rectangle', $mkItems::areaX1, $mkItems::areaY1, $x, $y, -outline => 'black'));
  109.     $mkItems::areaX2 = $x;
  110.     $mkItems::areaY2 = $y;
  111.     }
  112.  
  113. } # end itemStroke
  114.  
  115.  
  116. sub itemsUnderArea {
  117.  
  118.     my($c) = @_;
  119.  
  120.     my $area = $c->find('withtag', 'area');
  121.     my @items  = ();
  122.     my $i;
  123.     foreach $i ($c->find('enclosed', $mkItems::areaX1, $mkItems::areaY1, $mkItems::areaX2, $mkItems::areaY2)) {
  124.     my @tags = $c->gettags($i); 
  125.     if (defined($tags[0]) and grep $_ eq 'item', @tags) {
  126.         push @items, $i;
  127.     }
  128.     }
  129.     @items = 'None' unless @items;
  130.     print STDOUT 'Items enclosed by area:  ', join(' ', @items), ".\n";
  131.     @items = ();
  132.     foreach $i ($c->find('overlapping', $mkItems::areaX1, $mkItems::areaY1, $mkItems::areaX2, $mkItems::areaY2)) {
  133.     my @tags = $c->gettags($i); 
  134.     if (defined($tags[0]) and grep $_ eq 'item', @tags) {
  135.         push @items, $i;
  136.     }
  137.     }
  138.     @items = 'None' unless @items;
  139.     print STDOUT 'Items overlapping area:  ', join(' ', @items), ".\n";
  140.  
  141. } # end itemsUnderArea
  142.  
  143.  
  144. sub butPress {
  145.  
  146.     # Procedure that's invoked when the button embedded in the canvas is invoked.
  147.  
  148.     my($w, $color) = @_;
  149.  
  150.     my $i = $w->create(qw(text 25c 18.1c -anchor n), -text => 'Ouch!!', -fill => $color);
  151.     $w->after(500, sub { $w->delete($i) });
  152.  
  153. } # end butPress
  154.  
  155.  
  156. sub mkItems {
  157.  
  158.     # Create a top-level window containing a canvas that displays the various item types and allows them to be selected and
  159.     # moved.  This demo can be used to test out the point-hit and rectangle-hit code for items.
  160.  
  161.     $mkItems->destroy if Exists($mkItems);
  162.     $mkItems = $top->Toplevel();
  163.     my $w = $mkItems;
  164.     dpos $w;
  165.     $w->title('Canvas Item Demonstration');
  166.     $w->iconname('Items');
  167.     $w->minsize(100, 100);
  168.  
  169.  
  170.     my $w_msg = $w->Label(-font => '-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*', -wraplength => '5i',
  171.                -justify => 'left', -text => "This window contains a canvas widget with examples of the various " .
  172.                "kinds of items supported by canvases.  The following operations are supported:\n  Button-1 " .
  173.                "drag:\tmoves item under pointer.\n  Button-2 drag:\trepositions view.\n  Button-3 drag:\t" .
  174.                "strokes out area.\n Ctrl+f:\t\tdisplays items under area.");
  175.     my $w_frame2 = $w->Frame();
  176.     my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);
  177.     $w_msg->pack(-side => 'top', -fill => 'x');
  178.     $w_frame2->pack(-side => 'top', -fill => 'both', -expand => 'yes');
  179.     $w_ok->pack(-side => 'bottom', -pady => '5', -anchor => 'center');
  180.  
  181.     my $c = $w_frame2->Canvas(-scrollregion => ['0c', '0c', '30c', '24c'], -width => '15c', -height => '10c',
  182.             -relief => 'sunken', -bd => 2);
  183.     my $w_frame2_vscroll = $w_frame2->Scrollbar(-command => ['yview', $c]);
  184.     my $w_frame2_hscroll = $w_frame2->Scrollbar(-orient => 'horiz', -command => ['xview', $c]);
  185.     $c->configure(-xscrollcommand => ['set', $w_frame2_hscroll]);
  186.     $c->configure(-yscrollcommand => ['set', $w_frame2_vscroll]);
  187.     $w_frame2_hscroll->pack(-side => 'bottom', -fill => 'x');
  188.     $w_frame2_vscroll->pack(-side => 'right', -fill => 'y');
  189.     $c->pack(-expand => 'yes', -fill => 'both');
  190.     
  191.     # Display a 3x3 rectangular grid.
  192.  
  193.     $c->create(qw(rect 0c 0c 30c 24c -width 2));
  194.     $c->create(qw(line 0c 8c 30c 8c -width 2));
  195.     $c->create(qw(line 0c 16c 30c 16c -width 2));
  196.     $c->create(qw(line 10c 0c 10c 24c -width 2));
  197.     $c->create(qw(line 20c 0c 20c 24c -width 2));
  198.  
  199.     $font1 = '-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*';
  200.     $font2 = '-Adobe-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*';
  201.     if ($mkItems->depth > 1) {
  202.     $blue = 'DeepSkyBlue3';
  203.     $red = 'red';
  204.     $bisque = 'bisque3';
  205.     $green = 'SeaGreen3';
  206.     } else {
  207.     $blue = 'black';
  208.     $red = 'black';
  209.     $bisque = 'black';
  210.     $green = 'black';
  211.     }
  212.  
  213.     # Set up demos within each of the areas of the grid.
  214.  
  215.     $c->create(qw(text 5c .2c -text Lines -anchor n));
  216.     $c->create(qw(line 1c 1c 3c 1c 1c 4c 3c 4c -width 2m), -fill => $blue, qw(-cap butt -join miter -tags item));
  217.     $c->create(qw(line 4.67c 1c 4.67c 4c -arrow last -tags item));
  218.     $c->create(qw(line 6.33c 1c 6.33c 4c -arrow both -tags item));
  219.     $c->create(qw(line 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
  220.           8.4c 4.4c -width 3), -fill => $red, qw(-tags item));
  221.     $c->create(qw(line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c), -stipple => '@'.Tk->findINC('demos/images/grey.25'),
  222.            qw(-arrow both), -arrowshape => [15, 15, 7], qw(-tags item));
  223.     $c->create(qw(line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c -cap round -join round -tags item));
  224.  
  225.     $c->create(qw(text 15c .2c), -text => 'Curves (smoothed lines)', qw(-anchor n));
  226.     $c->create(qw(line 11c 4c 11.5c 1c 13.5c 1c 14c 4c -smooth on), -fill =>$blue, qw(-tags item));
  227.     $c->create(qw(line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on -arrow both -width 3 -tags item));
  228.     $c->create(qw(line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round),
  229.            -stipple => '@'.Tk->findINC('demos/images/grey.25'), -fill => $red, qw(-tags item));
  230.  
  231.     $c->create(qw(text 25c .2c -text Polygons -anchor n));
  232.     $c->create(qw(polygon 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),
  233.            -fill => $green, qw( -tags item));
  234.     $c->create(qw(polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c 29c 1c 29c 4c 29c 4c), -fill => $red,
  235.            qw(-smooth on -tags item));
  236.     $c->create(qw(polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c),
  237.            -stipple => '@'.Tk->findINC('demos/images/grey.25'), qw( -tags item));
  238.  
  239.     $c->create(qw(text 5c 8.2c -text Rectangles -anchor n));
  240.     $c->create(qw(rectangle 1c 9.5c 4c 12.5c), -outline => $red, qw(-width 3m -tags item));
  241.     $c->create(qw(rectangle 0.5c 13.5c 4.5c 15.5c), -fill => $green, qw(-tags item));
  242.     $c->create(qw(rectangle 6c 10c 9c 15c), -outline => undef, -stipple => '@'.Tk->findINC('demos/images/grey.25'), -fill => $blue,
  243.            qw(-tags item));
  244.  
  245.     $c->create(qw(text 15c 8.2c -text Ovals -anchor n));
  246.     $c->create(qw(oval 11c 9.5c 14c 12.5c), -outline => $red, qw(-width 3m -tags item));
  247.     $c->create(qw(oval 10.5c 13.5c 14.5c 15.5c), -fill => $green, qw(-tags item));
  248.     $c->create(qw(oval 16c 10c 19c 15c), -outline => undef, -stipple => '@'.Tk->findINC('demos/images/grey.25'), -fill => $blue,
  249.            qw(-tags item));
  250.  
  251.     $c->create(qw(text 25c 8.2c -text Text -anchor n));
  252.     $c->create(qw(rectangle 22.4c 8.9c 22.6c 9.1c));
  253.     $c->create(qw(text 22.5c 9c -anchor n -width 4c), -font => $font1, -text => 'A short string of text, word-wrapped, ' .
  254.            'justified left, and anchored north (at the top).  The rectangles show the anchor points for each piece ' .
  255.            'of text.', qw(-tags item));
  256.     $c->create(qw(rectangle 25.4c 10.9c 25.6c 11.1c));
  257.     $c->create(qw(text 25.5c 11c -anchor w), -font => $font1, -fill => $blue, -text => "Several lines,\n each centered\n" .
  258.            "individually,\nand all anchored\nat the left edge.", qw(-justify center -tags item));
  259.     $c->create(qw(rectangle 24.9c 13.9c 25.1c 14.1c));
  260.     $c->create(qw(text 25c 14c -anchor c), -font => $font2, -fill => $red, -stipple => '@'.Tk->findINC('demos/images/grey.5'),
  261.            -text => 'Stippled characters', qw(-tags item));
  262.  
  263.     $c->create(qw(text 5c 16.2c -text Arcs -anchor n));
  264.     $c->create(qw(arc 0.5c 17c 7c 20c), -fill => $green, qw(-outline black -start 45 -extent 270 -style pieslice -tags item));
  265.     $c->create(qw(arc 6.5c 17c 9.5c 20c -width 4m -style arc), -fill => $blue, -stipple => '@'.Tk->findINC('demos/images/grey.25'),
  266.            qw(-start -135 -extent 270 -tags item));
  267.     $c->create(qw(arc 0.5c 20c 9.5c 24c -width 4m -style pieslice), -fill => undef, -outline => $red,
  268.            qw(-start 225 -extent -90 -tags item));
  269.     $c->create(qw(arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord), -fill => $blue, -outline => undef,
  270.            qw(-start 45 -extent 270  -tags item));
  271.  
  272.     $c->create(qw(text 15c 16.2c -text Bitmaps -anchor n));
  273.     $c->create(qw(bitmap 13c 20c), -bitmap => '@'.Tk->findINC('demos/images/face'), qw(-tags item));
  274.     $c->create(qw(bitmap 17c 18.5c), -bitmap => '@'.Tk->findINC('demos/images/noletters'), qw(-tags item));
  275.     $c->create(qw(bitmap 17c 21.5c), -bitmap => '@'.Tk->findINC('demos/images/letters'), qw(-tags item));
  276.  
  277.     $c->create(qw(text 25c 16.2c -text Windows -anchor n));
  278.     my $c_button = $c->Button(-text => 'Press Me', -command => [sub {butPress(@_)}, $c, $red]);
  279.     $c->create(qw(window 21c 18c), -window => $c_button, qw(-anchor nw -tags item));
  280.     my $c_entry = $c->Entry(-width => '20', -relief => 'sunken');
  281.     $c_entry->insert('end' => 'Edit this text');
  282.     $c->create(qw(window 21c 21c), -window => $c_entry, qw(-anchor nw -tags item));
  283.     my $c_scale = $c->Scale(-from => '0', -to => '100', '-length' => '6c', -sliderlength => '.4c', -width => '.5c',
  284.                  -tickinterval => '0');
  285.     $c->create(qw(window 28.5c 17.5c), -window => $c_scale, qw(-anchor n -tags item));
  286.     $c->create(qw(text 21c 17.9c -text Button: -anchor sw));
  287.     $c->create(qw(text 21c 20.9c -text Entry: -anchor sw));
  288.     $c->create(qw(text 28.5c 17.4c -text Scale: -anchor s));
  289.  
  290.     # Set up event bindings for canvas.
  291.  
  292.     $c->bind('item', '<Any-Enter>' => sub {itemEnter(@_)});
  293.     $c->bind('item', '<Any-Leave>' => sub {itemLeave(@_)});
  294.     $c->Tk::bind('<1>' => sub {
  295.     my($c) = @_;
  296.         my $e = $c->XEvent;
  297.     itemStartDrag $c, $e->x, $e->y;
  298.     });
  299.     $c->Tk::bind('<B1-Motion>' => sub {
  300.     my($c) = @_;
  301.         my $e = $c->XEvent;
  302.     itemDrag $c, $e->x, $e->y;
  303.     });
  304.     $c->Tk::bind('<2>' => sub {
  305.     my($c) = @_;
  306.         my $e = $c->XEvent;
  307.     $c->scan('mark', $e->x, $e->y);
  308.     });
  309.     $c->Tk::bind('<B2-Motion>' => sub {
  310.     my ($c) = @_;
  311.         my $e = $c->XEvent;
  312.     $c->scan('dragto', $e->x, $e->y);
  313.     });
  314.     $c->Tk::bind('<3>' => sub {
  315.     my($c) = @_;
  316.         my $e = $c->XEvent;
  317.     itemMark $c, $e->x, $e->y;
  318.     });
  319.     $c->Tk::bind('<B3-Motion>' => sub {
  320.     my($c) = @_;
  321.         my $e = $c->XEvent;
  322.     itemStroke $c, $e->x, $e->y;
  323.     });
  324.     $c->Tk::bind('<Control-f>' => sub {
  325.     my($c) = @_;
  326.         my $e = $c->XEvent;
  327.     itemsUnderArea $c;
  328.     });
  329.     $w->bind('<Any-Enter>' => [sub {
  330.     my($w, $c) = @_;
  331.         my $e = $c->XEvent;
  332.     $c->Tk::focus;
  333.     }, $c]);
  334.  
  335. } # end mkItems
  336.  
  337.  
  338. 1;
  339.