home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _854c7921a6050e63e3959d567651636d < prev    next >
Encoding:
Text File  |  2004-06-01  |  19.9 KB  |  713 lines
  1. # -*- perl -*-
  2. #
  3. # tkfbox.tcl --
  4. #
  5. #       Implements the "TK" standard file selection dialog box. This
  6. #       dialog box is used on the Unix platforms whenever the tk_strictMotif
  7. #       flag is not set.
  8. #
  9. #       The "TK" standard file selection dialog box is similar to the
  10. #       file selection dialog box on Win95(TM). The user can navigate
  11. #       the directories by clicking on the folder icons or by
  12. #       selectinf the "Directory" option menu. The user can select
  13. #       files by clicking on the file icons or by entering a filename
  14. #       in the "Filename:" entry.
  15. #
  16. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  17. #
  18. # See the file "license.terms" for information on usage and redistribution
  19. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  20. #
  21. # Translated to perk/Tk and modified by Slaven Rezic <slaven@rezic.de>.
  22. #
  23.  
  24. #----------------------------------------------------------------------
  25. #
  26. #                     I C O N   L I S T
  27. #
  28. # This is a pseudo-widget that implements the icon list inside the
  29. # tkFDialog dialog box.
  30. #
  31. #----------------------------------------------------------------------
  32. # tkIconList --
  33. #
  34. #       Creates an IconList widget.
  35. #
  36.  
  37. package Tk::IconList;
  38. require Tk::Frame;
  39.  
  40. use vars qw($VERSION);
  41. $VERSION = '4.007'; # $Id: //depot/Tkutf8/Tk/IconList.pm#7 $
  42.  
  43. use Tk qw(Ev);
  44. use strict;
  45. use Carp;
  46.  
  47. use base 'Tk::Frame';
  48.  
  49. Construct Tk::Widget 'IconList';
  50.  
  51. # tkIconList_Create --
  52. #
  53. #       Creates an IconList widget by assembling a canvas widget and a
  54. #       scrollbar widget. Sets all the bindings necessary for the IconList's
  55. #       operations.
  56. #
  57. sub Populate {
  58.     my($w, $args) = @_;
  59.     $w->SUPER::Populate($args);
  60.  
  61.     my $sbar = $w->Component('Scrollbar' => 'sbar',
  62.                  -orient => 'horizontal',
  63.                  -highlightthickness => 0,
  64.                  -takefocus => 0,
  65.                 );
  66.     # make sure that the size does not exceed handhelds' dimensions
  67.     my($sw,$sh) = ($w->screenwidth, $w->screenheight);
  68.     my $canvas = $w->Component('Canvas' => 'canvas',
  69.                    -bd => 2,
  70.                    -relief => 'sunken',
  71.                    -width  => ($sw > 420 ? 400 : $sw-20),
  72.                    -height => ($sh > 160 ? 120 : $sh-40),
  73.                    -takefocus => 1,
  74.                   );
  75.     $sbar->pack(-side => 'bottom', -fill => 'x', -padx => 2);
  76.     $canvas->pack(-expand => 'yes', -fill => 'both');
  77.     $sbar->configure(-command => ['xview', $canvas]);
  78.     $canvas->configure(-xscrollcommand => ['set', $sbar]);
  79.  
  80.     # Initializes the max icon/text width and height and other variables
  81.     $w->{'maxIW'} = 1;
  82.     $w->{'maxIH'} = 1;
  83.     $w->{'maxTW'} = 1;
  84.     $w->{'maxTH'} = 1;
  85.     $w->{'numItems'} = 0;
  86. #XXX curItem never used    delete $w->{'curItem'};
  87.     $w->{'noScroll'} = 1;
  88.     $w->{'selection'} = [];
  89.     $w->{'index,anchor'} = '';
  90.  
  91.     # Creates the event bindings.
  92.     $canvas->Tk::bind('<Configure>', sub { $w->Arrange } );
  93.     $canvas->Tk::bind('<1>', [$w,'Btn1',Ev('x'),Ev('y')]);
  94.     $canvas->Tk::bind('<B1-Motion>', [$w,'Motion1',Ev('x'),Ev('y')]);
  95.     $canvas->Tk::bind('<Control-B1-Motion>', 'NoOp');
  96.     $canvas->Tk::bind('<Shift-B1-Motion>', 'NoOp');
  97.     $canvas->Tk::bind('<Control-1>', [$w,'CtrlBtn1',Ev('x'),Ev('y')]);
  98.     $canvas->Tk::bind('<Shift-1>', [$w,'ShiftBtn1',Ev('x'),Ev('y')]);
  99.     $canvas->Tk::bind('<Double-ButtonRelease-1>', [$w,'Double1',Ev('x'),Ev('y')]);
  100.     $canvas->Tk::bind('<Control-Double-ButtonRelease-1>', 'NoOp');
  101.     $canvas->Tk::bind('<Shift-Double-ButtonRelease-1>', 'NoOp');
  102.     $canvas->Tk::bind('<ButtonRelease-1>', [$w,'CancelRepeat']);
  103.     $canvas->Tk::bind('<B1-Leave>', [$w,'Leave1',Ev('x'),Ev('y')]);
  104.     $canvas->Tk::bind('<B1-Enter>', [$w,'CancelRepeat']);
  105.     $canvas->Tk::bind('<Up>',       [$w,'UpDown',   -1]);
  106.     $canvas->Tk::bind('<Down>',     [$w,'UpDown',    1]);
  107.     $canvas->Tk::bind('<Left>',     [$w,'LeftRight',-1]);
  108.     $canvas->Tk::bind('<Right>',    [$w,'LeftRight', 1]);
  109.     $canvas->Tk::bind('<Return>',   [$w,'ReturnKey']);
  110.     $canvas->Tk::bind('<KeyPress>', [$w,'KeyPress',Ev('A')]);
  111.     $canvas->Tk::bind('<Control-KeyPress>', 'NoOp');
  112.     $canvas->Tk::bind('<Alt-KeyPress>', 'NoOp');
  113.     $canvas->Tk::bind('<Meta-KeyPress>', 'NoOp');
  114. #XXX bad....
  115. #    $canvas->Tk::bind('<FocusIn>', sub { $w->FocusIn });
  116. #    $canvas->Tk::bind('<FocusOut>', sub { $w->FocusOut });
  117.  
  118.     # additional bindings not in tkfbox.tcl
  119.     $canvas->Tk::bind('<2>',['scan','mark',Ev('x'),Ev('y')]);
  120.     $canvas->Tk::bind('<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
  121.     # Remove the standard Canvas bindings
  122.     $canvas->bindtags([$canvas, $canvas->toplevel, 'all']);
  123.     # ... and define some again
  124.     $canvas->Tk::bind('<Home>', ['xview','moveto',0]);
  125.     $canvas->Tk::bind('<End>',  ['xview','moveto',1]);
  126.  
  127.     $w->ConfigSpecs(-browsecmd =>
  128.             ['METHOD', 'browseCommand', 'BrowseCommand', undef],
  129.             -command =>
  130.             ['CALLBACK', 'command', 'Command', undef],
  131.             -font =>
  132.             ['PASSIVE', 'font', 'Font', undef],
  133.             -foreground =>
  134.             ['PASSIVE', 'foreground', 'Foreground', undef],
  135.             -fg => '-foreground',
  136.             -multiple =>
  137.             ['PASSIVE', 'multiple', 'Multiple', 0],
  138.             -selectmode =>
  139.             ['PASSIVE', 'selectMode', 'SelectMode', 'browse'],
  140.             -selectbackground =>
  141.             ['PASSIVE', 'selectBackground', 'Foreground', '#a0a0ff'],
  142.            );
  143.  
  144.     $w;
  145. }
  146.  
  147. # compatibility for old -browsecmd options
  148. sub browsecmd {
  149.     my $w = shift;
  150.     if (@_) {
  151.     $w->{Configure}{'-browsecmd'} = $_[0];
  152.     $w->bind('<<ListboxSelect>>' => $_[0]);
  153.     }
  154.     $w->{Configure}{'-browsecmd'};
  155. }
  156.  
  157. sub Index {
  158.     my($w, $i) = @_;
  159.     if (!$w->{'list'}) { $w->{'list'} = [] }
  160.     if ($i =~ /^-?[0-9]+$/) {
  161.     if ($i < 0) {
  162.         $i = 0;
  163.     }
  164.     if ($i > @{ $w->{'list'} }) {
  165.         $i = @{ $w->{'list'} } - 1;
  166.     }
  167.     return $i;
  168.     } elsif ($i eq 'active') {
  169.     return $w->{'index,active'};
  170.     } elsif ($i eq 'anchor') {
  171.     return $w->{'index,anchor'};
  172.     } elsif ($i eq 'end') {
  173.     return @{ $w->{'list'} };
  174.     } elsif ($i =~ /@(-?[0-9]+),(-?[0-9]+)/) {
  175.     my($x, $y) = ($1, $2);
  176.     my $canvas = $w->Subwidget('canvas');
  177.     my $item = $canvas->find('closest', $x, $y);
  178.     if (defined $item) {
  179.         return $canvas->itemcget($item, '-tags')->[1];
  180.     } else {
  181.         return "";
  182.     }
  183.     } else {
  184.     croak "Unrecognized Index parameter `$i', use active, anchor, end, \@x,y, or x";
  185.     }
  186. }
  187.  
  188. sub Selection {
  189.     my($w, $op, @args) = @_;
  190.     if ($op eq 'anchor') {
  191.     if (@args == 1) {
  192.         $w->{'index,anchor'} = $w->Index($args[0]);
  193.     } else {
  194.         return $w->{'index,anchor'};
  195.     }
  196.     } elsif ($op eq 'clear') {
  197.     my($first, $last);
  198.     if (@args == 2) {
  199.         ($first, $last) = @args;
  200.     } elsif (@args == 1) {
  201.         $first = $last = $args[0];
  202.     } else {
  203.         croak "wrong # args: should be Selection('clear', first, ?last?)"
  204.     }
  205.     $first = $w->Index($first);
  206.     $last  = $w->Index($last);
  207.     if ($first > $last) {
  208.         ($first, $last) = ($last, $first);
  209.     }
  210.     my $ind = 0;
  211.     for my $item (@{ $w->{'selection'} }) {
  212.         if ($item >= $first) {
  213.         $first = $ind;
  214.         last;
  215.         }
  216.         $ind++; # XXX seems to be missing in the Tcl version
  217.     }
  218.     $ind = @{ $w->{'selection'} } - 1;
  219.     for(; $ind >= 0; $ind--) {
  220.         my $item = $w->{'selection'}->[$ind];
  221.         if ($item <= $last) {
  222.         $last = $ind;
  223.         last;
  224.         }
  225.     }
  226.     if ($first > $last) {
  227.         return;
  228.     }
  229.     splice @{ $w->{'selection'} }, $first, $last-$first+1;
  230.     $w->event('generate', '<<ListboxSelect>>');
  231.     $w->DrawSelection;
  232.     } elsif ($op eq 'includes') {
  233.     my $index;
  234.     for (@{ $w->{'selection'} }) {
  235.         if ($args[0] eq $_) {
  236.         return 1;
  237.         }
  238.     }
  239.     return 0;
  240.     } elsif ($op eq 'set') {
  241.     my($first, $last);
  242.     if (@args == 2) {
  243.         ($first, $last) = @args;
  244.     } elsif (@args == 1) {
  245.         $first = $last = $args[0];
  246.     } else {
  247.         croak "wrong # args: should be Selection('set', first, ?last?)";
  248.     }
  249.  
  250.     $first = $w->Index($first);
  251.     $last  = $w->Index($last);
  252.     if ($first > $last) {
  253.         ($first, $last) = ($last, $first);
  254.     }
  255.     for(my $i = $first; $i <= $last; $i++) {
  256.         push @{ $w->{'selection'} }, $i;
  257.     }
  258.     # lsort -integer -unique
  259.     my %sel = map { ($_ => 1) } @{ $w->{'selection'} };
  260.     @{ $w->{'selection'} } = sort { $a <=> $b } keys %sel;
  261.     $w->event('generate', '<<ListboxSelect>>');
  262.     $w->DrawSelection;
  263.     } else {
  264.     croak "Unrecognized Selection parameter `$op', use anchor, clear, includes, or set";
  265.     }
  266. }
  267.  
  268. # XXX why lower case 's' here and upper in DrawSelection?
  269. sub Curselection {
  270.     my $w = shift;
  271.     @{ $w->{'selection'} };
  272. }
  273.  
  274. sub DrawSelection {
  275.     my $w = shift;
  276.     my $canvas = $w->Subwidget('canvas');
  277.     $canvas->delete('selection');
  278.     my $selBg = $w->cget('-selectbackground');
  279.     for my $item (@{ $w->{'selection'} }) {
  280.     my $rTag = $w->{'list'}->[$item][2];
  281.     my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
  282.     my @bbox = $canvas->bbox($tTag);
  283.     # XXX don't hardcode colors
  284.     $canvas->createRectangle
  285.         (@bbox, -fill => $selBg, -outline => $selBg, -tags => 'selection');
  286.     }
  287.     $canvas->lower('selection');
  288. }
  289.  
  290. # Returns the selected item
  291. #
  292. sub Get {
  293.     my($w, $item) = @_;
  294.     my $rTag = $w->{'list'}->[$item][2];
  295.     my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
  296.     $text;
  297. }
  298.  
  299.  
  300. # tkIconList_AutoScan --
  301. #
  302. # This procedure is invoked when the mouse leaves an entry window
  303. # with button 1 down.  It scrolls the window up, down, left, or
  304. # right, depending on where the mouse left the window, and reschedules
  305. # itself as an "after" command so that the window continues to scroll until
  306. # the mouse moves back into the window or the mouse button is released.
  307. #
  308. # Arguments:
  309. # w -           The IconList window.
  310. #
  311. sub AutoScan {
  312.     my $w = shift;
  313.     return unless ($w->exists);
  314.     return if ($w->{'noScroll'});
  315.     my($x, $y);
  316.     $x = $Tk::x;
  317.     $y = $Tk::y;
  318.     my $canvas = $w->Subwidget('canvas');
  319.     if ($x >= $canvas->width) {
  320.     $canvas->xview('scroll', 1, 'units');
  321.     } elsif ($x < 0) {
  322.     $canvas->xview('scroll', -1, 'units');
  323.     } elsif ($y >= $canvas->height) {
  324.     # do nothing
  325.     } elsif ($y < 0) {
  326.     # do nothing
  327.     } else {
  328.     return;
  329.     }
  330.     $w->Motion1($x, $y);
  331.     $w->RepeatId($w->after(50, ['AutoScan', $w]));
  332. }
  333.  
  334. # Deletes all the items inside the canvas subwidget and reset the IconList's
  335. # state.
  336. #
  337. sub DeleteAll {
  338.     my $w = shift;
  339.     my $canvas = $w->Subwidget('canvas');
  340.     $canvas->delete('all');
  341.     delete $w->{'selected'};
  342.     delete $w->{'rect'};
  343.     delete $w->{'list'};
  344.     delete $w->{'itemList'};
  345.     $w->{'maxIW'} = 1;
  346.     $w->{'maxIH'} = 1;
  347.     $w->{'maxTW'} = 1;
  348.     $w->{'maxTH'} = 1;
  349.     $w->{'numItems'} = 0;
  350. #XXX curItem never used    delete $w->{'curItem'};
  351.     $w->{'noScroll'} = 1;
  352.     $w->{'selection'} = [];
  353.     $w->{'index,anchor'} = '';
  354.     $w->Subwidget('sbar')->set(0.0, 1.0);
  355.     $canvas->xview('moveto', 0);
  356. }
  357.  
  358. # Adds an icon into the IconList with the designated image and items
  359. #
  360. sub Add {
  361.     my($w, $image, @items) = @_;
  362.     my $canvas = $w->Subwidget('canvas');
  363.     my $font = $w->cget(-font);
  364.     my $fg   = $w->cget(-foreground);
  365.     foreach my $text (@items) {
  366.     my $iTag = $canvas->createImage
  367.         (0, 0, -image => $image, -anchor => 'nw',
  368.          -tags => ['icon', $w->{numItems}, 'item'.$w->{numItems}],
  369.         );
  370.     my $tTag = $canvas->createText
  371.         (0, 0, -text => $text, -anchor => 'nw',
  372.          (defined $fg   ? (-fill => $fg)   : ()),
  373.          (defined $font ? (-font => $font) : ()),
  374.          -tags => ['text', $w->{numItems}, 'item'.$w->{numItems}],
  375.         );
  376.     my $rTag = $canvas->createRectangle
  377.         (0, 0, 0, 0,
  378.          -fill => undef,
  379.          -outline => undef,
  380.          -tags => ['rect', $w->{numItems}, 'item'.$w->{numItems}],
  381.         );
  382.     my(@b) = $canvas->bbox($iTag);
  383.     my $iW = $b[2] - $b[0];
  384.     my $iH = $b[3] - $b[1];
  385.     $w->{'maxIW'} = $iW if ($w->{'maxIW'} < $iW);
  386.     $w->{'maxIH'} = $iH if ($w->{'maxIH'} < $iH);
  387.     @b = $canvas->bbox($tTag);
  388.     my $tW = $b[2] - $b[0];
  389.     my $tH = $b[3] - $b[1];
  390.     $w->{'maxTW'} = $tW if ($w->{'maxTW'} < $tW);
  391.     $w->{'maxTH'} = $tH if ($w->{'maxTH'} < $tH);
  392.     push @{ $w->{'list'} }, [$iTag, $tTag, $rTag, $iW, $iH, $tW, $tH,
  393.                  $w->{'numItems'}];
  394.     $w->{'itemList'}{$rTag} = [$iTag, $tTag, $text, $w->{'numItems'}];
  395.     $w->{'textList'}{$w->{'numItems'}} = lc($text);
  396.     ++$w->{'numItems'};
  397.     }
  398. }
  399.  
  400. # Places the icons in a column-major arrangement.
  401. #
  402. sub Arrange {
  403.     my $w = shift;
  404.     my $canvas = $w->Subwidget('canvas');
  405.     my $sbar   = $w->Subwidget('sbar');
  406.     unless (exists $w->{'list'}) {
  407.     if (defined $canvas && Tk::Exists($canvas)) {
  408.         $w->{'noScroll'} = 1;
  409.         $sbar->configure(-command => sub { });
  410.     }
  411.     return;
  412.     }
  413.  
  414.     my $W = $canvas->width;
  415.     my $H = $canvas->height;
  416.     my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
  417.     $pad = 2 if ($pad < 2);
  418.     $W -= $pad*2;
  419.     $H -= $pad*2;
  420.     my $dx = $w->{'maxIW'} + $w->{'maxTW'} + 8;
  421.     my $dy;
  422.     if ($w->{'maxTH'} > $w->{'maxIH'}) {
  423.     $dy = $w->{'maxTH'};
  424.     } else {
  425.     $dy = $w->{'maxIH'};
  426.     }
  427.     $dy += 2;
  428.     my $shift = $w->{'maxIW'} + 4;
  429.     my $x = $pad * 2;
  430.     my $y = $pad;
  431.     my $usedColumn = 0;
  432.     foreach my $sublist (@{ $w->{'list'} }) {
  433.     $usedColumn = 1;
  434.     my($iTag, $tTag, $rTag, $iW, $iH, $tW, $tH) = @$sublist;
  435.     my $i_dy = ($dy - $iH) / 2;
  436.     my $t_dy = ($dy - $tH) / 2;
  437.     $canvas->coords($iTag, $x, $y + $i_dy);
  438.     $canvas->coords($tTag, $x + $shift, $y + $t_dy);
  439.     $canvas->coords($rTag, $x, $y, $x + $dx, $y + $dy);
  440.     $y += $dy;
  441.     if ($y + $dy > $H) {
  442.         $y = $pad;
  443.         $x += $dx;
  444.         $usedColumn = 0;
  445.     }
  446.     }
  447.     my $sW;
  448.     if ($usedColumn) {
  449.     $sW = $x + $dx;
  450.     } else {
  451.     $sW = $x;
  452.     }
  453.     if ($sW < $W) {
  454.     $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
  455.     $sbar->configure(-command => sub { });
  456.     $canvas->xview(moveto => 0);
  457.     $w->{'noScroll'} = 1;
  458.     } else {
  459.     $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
  460.     $sbar->configure(-command => ['xview', $canvas]);
  461.     $w->{'noScroll'} = 0;
  462.     }
  463.     $w->{'itemsPerColumn'} = int(($H - $pad) / $dy);
  464.     $w->{'itemsPerColumn'} = 1 if ($w->{'itemsPerColumn'} < 1);
  465. #XXX    $w->Select($w->{'list'}[$w->{'curItem'}][2], 0)
  466. #      if (exists $w->{'curItem'});
  467.     $w->DrawSelection; # missing in Tcl XXX
  468. }
  469.  
  470. # Gets called when the user invokes the IconList (usually by double-clicking
  471. # or pressing the Return key).
  472. #
  473. sub Invoke {
  474.     my $w = shift;
  475.     $w->Callback(-command => $w->{'selected'}) if (@{ $w->{'selection'} });
  476. }
  477.  
  478. # tkIconList_See --
  479. #
  480. #       If the item is not (completely) visible, scroll the canvas so that
  481. #       it becomes visible.
  482. sub See {
  483.     my($w, $rTag) = @_;
  484.     return if ($w->{'noScroll'});
  485.     return if ($rTag < 0 || $rTag >= @{ $w->{'list'} });
  486.     my $canvas = $w->Subwidget('canvas');
  487.     my(@sRegion) = @{ $canvas->cget('-scrollregion') };
  488.     return unless (@sRegion);
  489.     my(@bbox) = $canvas->bbox('item'.$rTag);
  490.     my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
  491.     my $x1 = $bbox[0];
  492.     my $x2 = $bbox[2];
  493.     $x1 -= $pad * 2;
  494.     $x2 -= $pad;
  495.     my $cW = $canvas->width - $pad * 2;
  496.     my $scrollW = $sRegion[2] - $sRegion[0] + 1;
  497.     my $dispX = int(($canvas->xview)[0] * $scrollW);
  498.     my $oldDispX = $dispX;
  499.     # check if out of the right edge
  500.     $dispX = $x2 - $cW if ($x2 - $dispX >= $cW);
  501.     # check if out of the left edge
  502.     $dispX = $x1 if ($x1 - $dispX < 0);
  503.     if ($oldDispX != $dispX) {
  504.     my $fraction = $dispX / $scrollW;
  505.     $canvas->xview('moveto', $fraction);
  506.     }
  507. }
  508.  
  509. sub Btn1 {
  510.     my($w, $x, $y) = @_;
  511.  
  512.     my $canvas = $w->Subwidget('canvas');
  513.     $canvas->CanvasFocus;
  514.     $x = int($canvas->canvasx($x));
  515.     $y = int($canvas->canvasy($y));
  516.     my $i = $w->Index('@'.$x.','.$y);
  517.     return if ($i eq '');
  518.     $w->Selection('clear', 0, 'end');
  519.     $w->Selection('set', $i);
  520.     $w->Selection('anchor', $i);
  521. }
  522.  
  523. sub CtrlBtn1 {
  524.     my($w, $x, $y) = @_;
  525.  
  526.     if ($w->cget(-multiple)) {
  527.     my $canvas = $w->Subwidget('canvas');
  528.     $canvas->CanvasFocus;
  529.     my $x = int($canvas->canvasx($x));
  530.     my $y = int($canvas->canvasy($y));
  531.     my $i = $w->Index('@'.$x.','.$y);
  532.     return if ($i eq '');
  533.     if ($w->Selection('includes', $i)) {
  534.         $w->Selection('clear', $i);
  535.     } else {
  536.         $w->Selection('set', $i);
  537.         $w->Selection('anchor', $i);
  538.     }
  539.     }
  540. }
  541.  
  542. sub ShiftBtn1 {
  543.     my($w, $x, $y) = @_;
  544.  
  545.     if ($w->cget(-multiple)) {
  546.     my $canvas = $w->Subwidget('canvas');
  547.     $canvas->CanvasFocus;
  548.     my $x = int($canvas->canvasx($x));
  549.     my $y = int($canvas->canvasy($y));
  550.     my $i = $w->Index('@'.$x.','.$y);
  551.     return if ($i eq '');
  552.     my $a = $w->Index('anchor');
  553.     if ($a eq '') {
  554.         $a = $i;
  555.     }
  556.     $w->Selection('clear', 0, 'end');
  557.     $w->Selection('set', $a, $i);
  558.     }
  559. }
  560.  
  561. # Gets called on button-1 motions
  562. #
  563. sub Motion1 {
  564.     my($w, $x, $y) = @_;
  565.     $Tk::x = $x;
  566.     $Tk::y = $y;
  567.     my $canvas = $w->Subwidget('canvas');
  568.     $canvas->CanvasFocus;
  569.     $x = int($canvas->canvasx($x));
  570.     $y = int($canvas->canvasy($y));
  571.     my $i = $w->Index('@'.$x.','.$y);
  572.     return if ($i eq '');
  573.     $w->Selection('clear', 0, 'end');
  574.     $w->Selection('set', $i);
  575. }
  576.  
  577. sub Double1 {
  578.     my($w, $x, $y) = @_;
  579.     $w->Invoke if (@{ $w->{'selection'} });
  580. }
  581.  
  582. sub ReturnKey {
  583.     my $w = shift;
  584.     $w->Invoke;
  585. }
  586.  
  587. sub Leave1 {
  588.     my($w, $x, $y) = @_;
  589.     $Tk::x = $x;
  590.     $Tk::y = $y;
  591.     $w->AutoScan;
  592. }
  593.  
  594. sub FocusIn {
  595.     my $w = shift;
  596.     return unless (exists $w->{'list'});
  597.     if (@{ $w->{'selection'} }) {
  598.     $w->DrawSelection;
  599.     }
  600. }
  601.  
  602. sub FocusOut {
  603.     my $w = shift;
  604.     $w->Selection('clear', 0, 'end');
  605. }
  606.  
  607. # tkIconList_UpDown --
  608. #
  609. # Moves the active element up or down by one element
  610. #
  611. # Arguments:
  612. # w -           The IconList widget.
  613. # amount -      +1 to move down one item, -1 to move back one item.
  614. #
  615. sub UpDown {
  616.     my($w, $amount) = @_;
  617.     return unless (exists $w->{'list'});
  618.     my $i;
  619.     my(@curr) = $w->Curselection;
  620.     if (!@curr) {
  621.     $i = 0;
  622.     } else {
  623.     $i = $w->Index('anchor');
  624.     return if ($i eq '');
  625.     $i += $amount;
  626.     }
  627.     $w->Selection('clear', 0, 'end');
  628.     $w->Selection('set', $i);
  629.     $w->Selection('anchor', $i);
  630.     $w->See($i);
  631. }
  632.  
  633. # tkIconList_LeftRight --
  634. #
  635. # Moves the active element left or right by one column
  636. #
  637. # Arguments:
  638. # w -           The IconList widget.
  639. # amount -      +1 to move right one column, -1 to move left one column.
  640. #
  641. sub LeftRight {
  642.     my($w, $amount) = @_;
  643.     return unless (exists $w->{'list'});
  644.     my $i;
  645.     my(@curr) = $w->Curselection;
  646.     if (!@curr) {
  647.     $i = 0;
  648.     } else {
  649.     $i = $w->Index('anchor');
  650.     return if ($i eq '');
  651.     $i += $amount*$w->{'itemsPerColumn'};
  652.     }
  653.     $w->Selection('clear', 0, 'end');
  654.     $w->Selection('set', $i);
  655.     $w->Selection('anchor', $i);
  656.     $w->See($i);
  657. }
  658.  
  659. #----------------------------------------------------------------------
  660. #               Accelerator key bindings
  661. #----------------------------------------------------------------------
  662. # tkIconList_KeyPress --
  663. #
  664. #       Gets called when user enters an arbitrary key in the listbox.
  665. #
  666. sub KeyPress {
  667.     my($w, $key) = @_;
  668.     $w->{'_ILAccel'} .= $key;
  669.     $w->Goto($w->{'_ILAccel'});
  670.     eval {
  671.     $w->afterCancel($w->{'_ILAccel_afterid'});
  672.     };
  673.     $w->{'_ILAccel_afterid'} = $w->after(500, ['Reset', $w]);
  674. }
  675.  
  676. sub Goto {
  677.     my($w, $text) = @_;
  678.     return unless (exists $w->{'list'});
  679.     return if (not defined $text or $text eq '');
  680. #XXX curItem never used    my $start = (!exists $w->{'curItem'} ? 0 : $w->{'curItem'});
  681.     my $start = 0;
  682.     $text = lc($text);
  683.     my $theIndex = -1;
  684.     my $less = 0;
  685.     my $len = length($text);
  686.     my $i = $start;
  687.     # Search forward until we find a filename whose prefix is an exact match
  688.     # with $text
  689.     while (1) {
  690.     my $sub = substr($w->{'textList'}{$i}, 0, $len);
  691.     if ($text eq $sub) {
  692.         $theIndex = $i;
  693.         last;
  694.     }
  695.     ++$i;
  696.     $i = 0 if ($i == $w->{'numItems'});
  697.     last if ($i == $start);
  698.     }
  699.     if ($theIndex > -1) {
  700.     $w->Selection(qw(clear 0 end));
  701.     $w->Selection('set', $theIndex);
  702.     $w->Selection('anchor', $theIndex);
  703.     $w->See($theIndex);
  704.     }
  705. }
  706.  
  707. sub Reset {
  708.     my $w = shift;
  709.     undef $w->{'_ILAccel'};
  710. }
  711.  
  712. 1;
  713.