home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _578a7e716d2bd16ca7de646aed40251e < prev    next >
Encoding:
Text File  |  2004-06-01  |  23.0 KB  |  911 lines
  1. # Converted from listbox.tcl --
  2. #
  3. # This file defines the default bindings for Tk listbox widgets.
  4. #
  5. # @(#) listbox.tcl 1.7 94/12/17 16:05:18
  6. #
  7. # Copyright (c) 1994 The Regents of the University of California.
  8. # Copyright (c) 1994 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  
  13. # Modifications from standard Listbox.pm
  14. # --------------------------------------
  15. # 27-JAN-2001 Alasdair Allan
  16. #    Modified for local use by adding tied scalar and arrays
  17. #    Implemented TIESCALAR, TIEARRAY, FETCH, FETCHSIZE, STORE, CLEAR & EXTEND
  18. # 31-JAN-2001 Alasdair Allan
  19. #    Made changes suggested by Tim Jenness
  20. # 03-FEB-2001 Alasdair Allan
  21. #    Modified STORE for tied scalars to clear and select elements
  22. # 06-FEB-2001 Alasdair Allan
  23. #    Added POD documentation for tied listbox
  24. # 13-FEB-2001 Alasdair Allan
  25. #    Implemented EXISTS, DELETE, PUSH, POP, SHIFT & UNSHIFT for tied arrays
  26. # 14-FEB-2001 Alasdair Allan
  27. #    Implemented SPLICE for tied arrays, all tied functionality in place
  28. # 16-FEB-2001 Alasdair Allan
  29. #    Tweak to STORE interface for tied scalars
  30. # 23-FEB-2001 Alasdair Allan
  31. #    Added flag to FETCH for tied scalars, modified to return hashes
  32. # 24-FEB-2001 Alasdair Allan
  33. #    Updated Pod documentation
  34. #
  35.  
  36. package Tk::Listbox;
  37.  
  38. use vars qw($VERSION @Selection $Prev);
  39. use strict;
  40. $VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/;
  41.  
  42. use Tk qw(Ev $XS_VERSION);
  43. use Tk::Clipboard ();
  44. use AutoLoader;
  45.  
  46. use base  qw(Tk::Clipboard Tk::Widget);
  47.  
  48. Construct Tk::Widget 'Listbox';
  49.  
  50. bootstrap Tk::Listbox;
  51.  
  52. sub Tk_cmd { \&Tk::listbox }
  53.  
  54. Tk::Methods('activate','bbox','curselection','delete','get','index',
  55.             'insert','itemcget','itemconfigure','nearest','scan','see',
  56.             'selection','size','xview','yview');
  57.  
  58. use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)],
  59.              'scan'      => [qw(mark dragto)],
  60.              'xview'     => [qw(moveto scroll)],
  61.              'yview'     => [qw(moveto scroll)],
  62.              );
  63.  
  64. *Getselected = \&getSelected;
  65.  
  66. sub clipEvents
  67. {
  68.  return qw[Copy];
  69. }
  70.  
  71. sub BalloonInfo
  72. {
  73.  my ($listbox,$balloon,$X,$Y,@opt) = @_;
  74.  my $e = $listbox->XEvent;
  75.  return if !$e;
  76.  my $index = $listbox->index('@' . $e->x . ',' . $e->y);
  77.  foreach my $opt (@opt)
  78.   {
  79.    my $info = $balloon->GetOption($opt,$listbox);
  80.    if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
  81.     {
  82.      $balloon->Subclient($index);
  83.      if (defined $info->[$index])
  84.       {
  85.        return $info->[$index];
  86.       }
  87.      return '';
  88.     }
  89.    return $info;
  90.   }
  91. }
  92.  
  93. sub ClassInit
  94. {
  95.  my ($class,$mw) = @_;
  96.  $class->SUPER::ClassInit($mw);
  97.  # Standard Motif bindings:
  98.  $mw->bind($class,'<1>',[sub {
  99.                my $w = shift;
  100.                if (Tk::Exists($w)) {
  101.                  $w->BeginSelect(@_);
  102.                }
  103.              }, Ev('index',Ev('@'))]);
  104.  $mw->bind($class, '<Double-1>' => \&Tk::NoOp);
  105.  $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
  106.  $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
  107.  ;
  108.  $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
  109.  $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
  110.  
  111.  $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
  112.  $mw->bind($class,'<B1-Enter>','CancelRepeat');
  113.  $mw->bind($class,'<Up>',['UpDown',-1]);
  114.  $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
  115.  $mw->bind($class,'<Down>',['UpDown',1]);
  116.  $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
  117.  
  118.  $mw->XscrollBind($class);
  119.  $mw->bind($class,'<Prior>', sub {
  120.            my $w = shift;
  121.            $w->yview('scroll',-1,'pages');
  122.            $w->activate('@0,0');
  123.        });
  124.  $mw->bind($class,'<Next>',  sub {
  125.            my $w = shift;
  126.            $w->yview('scroll',1,'pages');
  127.            $w->activate('@0,0');
  128.        });
  129.  $mw->bind($class,'<Control-Prior>', ['xview', 'scroll', -1, 'pages']);
  130.  $mw->bind($class,'<Control-Next>',  ['xview', 'scroll',  1, 'pages']);
  131.  # <Home> and <End> defined in XscrollBind
  132.  $mw->bind($class,'<Control-Home>','Cntrl_Home');
  133.  ;
  134.  $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
  135.  $mw->bind($class,'<Control-End>','Cntrl_End');
  136.  ;
  137.  $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
  138.  # XXX What about <<Copy>>? Already handled in Tk::Clipboard?
  139.  # $class->clipboardOperations($mw,'Copy');
  140.  $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
  141.  $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
  142.  $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
  143.  $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
  144.  $mw->bind($class,'<Escape>','Cancel');
  145.  $mw->bind($class,'<Control-slash>','SelectAll');
  146.  $mw->bind($class,'<Control-backslash>','Cntrl_backslash');
  147.  ;
  148.  # Additional Tk bindings that aren't part of the Motif look and feel:
  149.  $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
  150.  $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
  151.  
  152.  $mw->MouseWheelBind($class); # XXX Both needed?
  153.  $mw->YMouseWheelBind($class);
  154.  return $class;
  155. }
  156.  
  157. 1;
  158. __END__
  159.  
  160. sub TIEARRAY {
  161.   my ( $class, $obj, %options ) = @_;
  162.   return bless {
  163.         OBJECT => \$obj,
  164.         OPTION => \%options }, $class;
  165. }
  166.  
  167.  
  168.  
  169. sub TIESCALAR {
  170.   my ( $class, $obj, %options ) = @_;
  171.   return bless {
  172.         OBJECT => \$obj,
  173.         OPTION => \%options }, $class;
  174. }
  175.  
  176. # FETCH
  177. # -----
  178. # Return either the full contents or only the selected items in the
  179. # box depending on whether we tied it to an array or scalar respectively
  180. sub FETCH {
  181.   my $class = shift;
  182.  
  183.   my $self = ${$class->{OBJECT}};
  184.   my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
  185.  
  186.   # Define the return variable
  187.   my $result;
  188.  
  189.   # Check whether we are have a tied array or scalar quantity
  190.   if ( @_ ) {
  191.      my $i = shift;
  192.      # The Tk:: Listbox has been tied to an array, we are returning
  193.      # an array list of the current items in the Listbox
  194.      $result = $self->get($i);
  195.   } else {
  196.      # The Tk::Listbox has been tied to a scalar, we are returning a
  197.      # reference to an array or hash containing the currently selected items
  198.      my ( @array, %hash );
  199.  
  200.      if ( defined $options{ReturnType} ) {
  201.  
  202.         # THREE-WAY SWITCH
  203.         if ( $options{ReturnType} eq "index" ) {
  204.            $result = [$self->curselection];
  205.         } elsif ( $options{ReturnType} eq "element" ) {
  206.        foreach my $selection ( $self->curselection ) {
  207.               push(@array,$self->get($selection)); }
  208.            $result = \@array;
  209.     } elsif ( $options{ReturnType} eq "both" ) {
  210.        foreach my $selection ( $self->curselection ) {
  211.               %hash = ( %hash, $selection => $self->get($selection)); }
  212.            $result = \%hash;
  213.     }
  214.      } else {
  215.         # return elements (default)
  216.         foreach my $selection ( $self->curselection ) {
  217.            push(@array,$self->get($selection)); }
  218.         $result = \@array;
  219.      }
  220.   }
  221.   return $result;
  222. }
  223.  
  224. # FETCHSIZE
  225. # ---------
  226. # Return the number of elements in the Listbox when tied to an array
  227. sub FETCHSIZE {
  228.   my $class = shift;
  229.   return ${$class->{OBJECT}}->size();
  230. }
  231.  
  232. # STORE
  233. # -----
  234. # If tied to an array we will modify the Listbox contents, while if tied
  235. # to a scalar we will select and clear elements.
  236. sub STORE {
  237.  
  238.   if ( scalar(@_) == 2 ) {
  239.      # we have a tied scalar
  240.      my ( $class, $selected ) = @_;
  241.      my $self = ${$class->{OBJECT}};
  242.      my %options = %{$class->{OPTION}} if defined $class->{OPTION};;
  243.  
  244.      # clear currently selected elements
  245.      $self->selectionClear(0,'end');
  246.  
  247.      # set selected elements
  248.      if ( defined $options{ReturnType} ) {
  249.  
  250.         # THREE-WAY SWITCH
  251.         if ( $options{ReturnType} eq "index" ) {
  252.            for ( my $i=0; $i < scalar(@$selected) ; $i++ ) {
  253.               for ( my $j=0; $j < $self->size() ; $j++ ) {
  254.                   if( $j == $$selected[$i] ) {
  255.                  $self->selectionSet($j); last; }
  256.               }
  257.            }
  258.         } elsif ( $options{ReturnType} eq "element" ) {
  259.            for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
  260.               for ( my $l=0; $l < $self->size() ; $l++ ) {
  261.                  if( $self->get($l) eq $$selected[$k] ) {
  262.                 $self->selectionSet($l); last; }
  263.               }
  264.            }
  265.     } elsif ( $options{ReturnType} eq "both" ) {
  266.            foreach my $key ( keys %$selected ) {
  267.               $self->selectionSet($key)
  268.                   if $$selected{$key} eq $self->get($key);
  269.        }
  270.     }
  271.      } else {
  272.         # return elements (default)
  273.         for ( my $k=0; $k < scalar(@$selected) ; $k++ ) {
  274.            for ( my $l=0; $l < $self->size() ; $l++ ) {
  275.               if( $self->get($l) eq $$selected[$k] ) {
  276.              $self->selectionSet($l); last; }
  277.            }
  278.         }
  279.      }
  280.  
  281.   } else {
  282.      # we have a tied array
  283.      my ( $class, $index, $value ) = @_;
  284.      my $self = ${$class->{OBJECT}};
  285.  
  286.      # check size of current contents list
  287.      my $sizeof = $self->size();
  288.  
  289.      if ( $index <= $sizeof ) {
  290.         # Change a current listbox entry
  291.         $self->delete($index);
  292.         $self->insert($index, $value);
  293.      } else {
  294.         # Add a new value
  295.         if ( defined $index ) {
  296.            $self->insert($index, $value);
  297.         } else {
  298.            $self->insert("end", $value);
  299.         }
  300.      }
  301.    }
  302. }
  303.  
  304. # CLEAR
  305. # -----
  306. # Empty the Listbox of contents if tied to an array
  307. sub CLEAR {
  308.   my $class = shift;
  309.   ${$class->{OBJECT}}->delete(0, 'end');
  310. }
  311.  
  312. # EXTEND
  313. # ------
  314. # Do nothing and be happy about it
  315. sub EXTEND { }
  316.  
  317. # PUSH
  318. # ----
  319. # Append elements onto the Listbox contents
  320. sub PUSH {
  321.   my ( $class, @list ) = @_;
  322.   ${$class->{OBJECT}}->insert('end', @list);
  323. }
  324.  
  325. # POP
  326. # ---
  327. # Remove last element of the array and return it
  328. sub POP {
  329.    my $class = shift;
  330.  
  331.    my $value = ${$class->{OBJECT}}->get('end');
  332.    ${$class->{OBJECT}}->delete('end');
  333.    return $value;
  334. }
  335.  
  336. # SHIFT
  337. # -----
  338. # Removes the first element and returns it
  339. sub SHIFT {
  340.    my $class = shift;
  341.  
  342.    my $value = ${$class->{OBJECT}}->get(0);
  343.    ${$class->{OBJECT}}->delete(0);
  344.    return $value
  345. }
  346.  
  347. # UNSHIFT
  348. # -------
  349. # Insert elements at the beginning of the Listbox
  350. sub UNSHIFT {
  351.    my ( $class, @list ) = @_;
  352.    ${$class->{OBJECT}}->insert(0, @list);
  353. }
  354.  
  355. # DELETE
  356. # ------
  357. # Delete element at specified index
  358. sub DELETE {
  359.    my ( $class, @list ) = @_;
  360.  
  361.    my $value = ${$class->{OBJECT}}->get(@list);
  362.    ${$class->{OBJECT}}->delete(@list);
  363.    return $value;
  364. }
  365.  
  366. # EXISTS
  367. # ------
  368. # Returns true if the index exist, and undef if not
  369. sub EXISTS {
  370.    my ( $class, $index ) = @_;
  371.    return undef unless ${$class->{OBJECT}}->get($index);
  372. }
  373.  
  374. # SPLICE
  375. # ------
  376. # Performs equivalent of splice on the listbox contents
  377. sub SPLICE {
  378.    my $class = shift;
  379.  
  380.    my $self = ${$class->{OBJECT}};
  381.  
  382.    # check for arguments
  383.    my @elements;
  384.    if ( scalar(@_) == 0 ) {
  385.       # none
  386.       @elements = $self->get(0,'end');
  387.       $self->delete(0,'end');
  388.       return wantarray ? @elements : $elements[scalar(@elements)-1];;
  389.  
  390.    } elsif ( scalar(@_) == 1 ) {
  391.       # $offset
  392.       my ( $offset ) = @_;
  393.       if ( $offset < 0 ) {
  394.          my $start = $self->size() + $offset;
  395.          if ( $start > 0 ) {
  396.         @elements = $self->get($start,'end');
  397.             $self->delete($start,'end');
  398.         return wantarray ? @elements : $elements[scalar(@elements)-1];
  399.          } else {
  400.             return undef;
  401.      }
  402.       } else {
  403.      @elements = $self->get($offset,'end');
  404.          $self->delete($offset,'end');
  405.          return wantarray ? @elements : $elements[scalar(@elements)-1];
  406.       }
  407.  
  408.    } elsif ( scalar(@_) == 2 ) {
  409.       # $offset and $length
  410.       my ( $offset, $length ) = @_;
  411.       if ( $offset < 0 ) {
  412.          my $start = $self->size() + $offset;
  413.          my $end = $self->size() + $offset + $length - 1;
  414.      if ( $start > 0 ) {
  415.         @elements = $self->get($start,$end);
  416.             $self->delete($start,$end);
  417.         return wantarray ? @elements : $elements[scalar(@elements)-1];
  418.          } else {
  419.             return undef;
  420.      }
  421.       } else {
  422.      @elements = $self->get($offset,$offset+$length-1);
  423.          $self->delete($offset,$offset+$length-1);
  424.          return wantarray ? @elements : $elements[scalar(@elements)-1];
  425.       }
  426.  
  427.    } else {
  428.       # $offset, $length and @list
  429.       my ( $offset, $length, @list ) = @_;
  430.       if ( $offset < 0 ) {
  431.          my $start = $self->size() + $offset;
  432.          my $end = $self->size() + $offset + $length - 1;
  433.      if ( $start > 0 ) {
  434.         @elements = $self->get($start,$end);
  435.             $self->delete($start,$end);
  436.         $self->insert($start,@list);
  437.         return wantarray ? @elements : $elements[scalar(@elements)-1];
  438.          } else {
  439.             return undef;
  440.      }
  441.       } else {
  442.      @elements = $self->get($offset,$offset+$length-1);
  443.          $self->delete($offset,$offset+$length-1);
  444.      $self->insert($offset,@list);
  445.          return wantarray ? @elements : $elements[scalar(@elements)-1];
  446.       }
  447.    }
  448. }
  449.  
  450. # ----
  451.  
  452. #
  453. # Bind --
  454. # This procedure is invoked the first time the mouse enters a listbox
  455. # widget or a listbox widget receives the input focus. It creates
  456. # all of the class bindings for listboxes.
  457. #
  458. # Arguments:
  459. # event - Indicates which event caused the procedure to be invoked
  460. # (Enter or FocusIn). It is used so that we can carry out
  461. # the functions of that event in addition to setting up
  462. # bindings.
  463.  
  464. sub xyIndex
  465. {
  466.  my $w = shift;
  467.  my $Ev = $w->XEvent;
  468.  return $w->index($Ev->xy);
  469. }
  470.  
  471. sub ButtonRelease_1
  472. {
  473.  my $w = shift;
  474.  my $Ev = $w->XEvent;
  475.  $w->CancelRepeat;
  476.  $w->activate($Ev->xy);
  477. }
  478.  
  479.  
  480. sub Cntrl_Home
  481. {
  482.  my $w = shift;
  483.  my $Ev = $w->XEvent;
  484.  $w->activate(0);
  485.  $w->see(0);
  486.  $w->selectionClear(0,'end');
  487.  $w->selectionSet(0);
  488.  $w->eventGenerate("<<ListboxSelect>>");
  489. }
  490.  
  491.  
  492. sub Cntrl_End
  493. {
  494.  my $w = shift;
  495.  my $Ev = $w->XEvent;
  496.  $w->activate('end');
  497.  $w->see('end');
  498.  $w->selectionClear(0,'end');
  499.  $w->selectionSet('end');
  500.  $w->eventGenerate("<<ListboxSelect>>");
  501. }
  502.  
  503.  
  504. sub Cntrl_backslash
  505. {
  506.  my $w = shift;
  507.  my $Ev = $w->XEvent;
  508.  if ($w->cget('-selectmode') ne 'browse')
  509.  {
  510.   $w->selectionClear(0,'end');
  511.   $w->eventGenerate("<<ListboxSelect>>");
  512.  }
  513. }
  514.  
  515. # BeginSelect --
  516. #
  517. # This procedure is typically invoked on button-1 presses. It begins
  518. # the process of making a selection in the listbox. Its exact behavior
  519. # depends on the selection mode currently in effect for the listbox;
  520. # see the Motif documentation for details.
  521. #
  522. # Arguments:
  523. # w - The listbox widget.
  524. # el - The element for the selection operation (typically the
  525. # one under the pointer). Must be in numerical form.
  526. sub BeginSelect
  527. {
  528.  my $w = shift;
  529.  my $el = shift;
  530.  if ($w->cget('-selectmode') eq 'multiple')
  531.   {
  532.    if ($w->selectionIncludes($el))
  533.     {
  534.      $w->selectionClear($el)
  535.     }
  536.    else
  537.     {
  538.      $w->selectionSet($el)
  539.     }
  540.   }
  541.  else
  542.   {
  543.    $w->selectionClear(0,'end');
  544.    $w->selectionSet($el);
  545.    $w->selectionAnchor($el);
  546.    @Selection = ();
  547.    $Prev = $el
  548.   }
  549.  $w->focus if ($w->cget('-takefocus'));
  550.  $w->eventGenerate("<<ListboxSelect>>");
  551. }
  552. # Motion --
  553. #
  554. # This procedure is called to process mouse motion events while
  555. # button 1 is down. It may move or extend the selection, depending
  556. # on the listbox's selection mode.
  557. #
  558. # Arguments:
  559. # w - The listbox widget.
  560. # el - The element under the pointer (must be a number).
  561. sub Motion
  562. {
  563.  my $w = shift;
  564.  my $el = shift;
  565.  if (defined($Prev) && $el == $Prev)
  566.   {
  567.    return;
  568.   }
  569.  my $anchor = $w->index('anchor');
  570.  my $mode = $w->cget('-selectmode');
  571.  if ($mode eq 'browse')
  572.   {
  573.    $w->selectionClear(0,'end');
  574.    $w->selectionSet($el);
  575.    $Prev = $el;
  576.    $w->eventGenerate("<<ListboxSelect>>");
  577.   }
  578.  elsif ($mode eq 'extended')
  579.   {
  580.    my $i = $Prev;
  581.    if (!defined $i || $i eq '')
  582.     {
  583.      $i = $el;
  584.      $w->selectionSet($el);
  585.     }
  586.    if ($w->selectionIncludes('anchor'))
  587.     {
  588.      $w->selectionClear($i,$el);
  589.      $w->selectionSet('anchor',$el)
  590.     }
  591.    else
  592.     {
  593.      $w->selectionClear($i,$el);
  594.      $w->selectionClear('anchor',$el)
  595.     }
  596.    if (!@Selection)
  597.     {
  598.      @Selection = $w->curselection;
  599.     }
  600.    while ($i < $el && $i < $anchor)
  601.     {
  602.      if (Tk::lsearch(\@Selection,$i) >= 0)
  603.       {
  604.        $w->selectionSet($i)
  605.       }
  606.      $i++
  607.     }
  608.    while ($i > $el && $i > $anchor)
  609.     {
  610.      if (Tk::lsearch(\@Selection,$i) >= 0)
  611.       {
  612.        $w->selectionSet($i)
  613.       }
  614.      $i--
  615.     }
  616.    $Prev = $el;
  617.    $w->eventGenerate("<<ListboxSelect>>");
  618.   }
  619. }
  620. # BeginExtend --
  621. #
  622. # This procedure is typically invoked on shift-button-1 presses. It
  623. # begins the process of extending a selection in the listbox. Its
  624. # exact behavior depends on the selection mode currently in effect
  625. # for the listbox; see the Motif documentation for details.
  626. #
  627. # Arguments:
  628. # w - The listbox widget.
  629. # el - The element for the selection operation (typically the
  630. # one under the pointer). Must be in numerical form.
  631. sub BeginExtend
  632. {
  633.  my $w = shift;
  634.  my $el = shift;
  635.  if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
  636.   {
  637.    $w->Motion($el)
  638.   }
  639.  else
  640.   {
  641.    # No selection yet; simulate the begin-select operation.
  642.    $w->BeginSelect($el);
  643.   }
  644. }
  645. # BeginToggle --
  646. #
  647. # This procedure is typically invoked on control-button-1 presses. It
  648. # begins the process of toggling a selection in the listbox. Its
  649. # exact behavior depends on the selection mode currently in effect
  650. # for the listbox; see the Motif documentation for details.
  651. #
  652. # Arguments:
  653. # w - The listbox widget.
  654. # el - The element for the selection operation (typically the
  655. # one under the pointer). Must be in numerical form.
  656. sub BeginToggle
  657. {
  658.  my $w = shift;
  659.  my $el = shift;
  660.  if ($w->cget('-selectmode') eq 'extended')
  661.   {
  662.    @Selection = $w->curselection();
  663.    $Prev = $el;
  664.    $w->selectionAnchor($el);
  665.    if ($w->selectionIncludes($el))
  666.     {
  667.      $w->selectionClear($el)
  668.     }
  669.    else
  670.     {
  671.      $w->selectionSet($el)
  672.     }
  673.    $w->eventGenerate("<<ListboxSelect>>");
  674.   }
  675. }
  676. # AutoScan --
  677. # This procedure is invoked when the mouse leaves an entry window
  678. # with button 1 down. It scrolls the window up, down, left, or
  679. # right, depending on where the mouse left the window, and reschedules
  680. # itself as an "after" command so that the window continues to scroll until
  681. # the mouse moves back into the window or the mouse button is released.
  682. #
  683. # Arguments:
  684. # w - The entry window.
  685. # x - The x-coordinate of the mouse when it left the window.
  686. # y - The y-coordinate of the mouse when it left the window.
  687. sub AutoScan
  688. {
  689.  my $w = shift;
  690.  return if !Tk::Exists($w);
  691.  my $x = shift;
  692.  my $y = shift;
  693.  if ($y >= $w->height)
  694.   {
  695.    $w->yview('scroll',1,'units')
  696.   }
  697.  elsif ($y < 0)
  698.   {
  699.    $w->yview('scroll',-1,'units')
  700.   }
  701.  elsif ($x >= $w->width)
  702.   {
  703.    $w->xview('scroll',2,'units')
  704.   }
  705.  elsif ($x < 0)
  706.   {
  707.    $w->xview('scroll',-2,'units')
  708.   }
  709.  else
  710.   {
  711.    return;
  712.   }
  713.  $w->Motion($w->index("@" . $x . ',' . $y));
  714.  $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
  715. }
  716. # UpDown --
  717. #
  718. # Moves the location cursor (active element) up or down by one element,
  719. # and changes the selection if we're in browse or extended selection
  720. # mode.
  721. #
  722. # Arguments:
  723. # w - The listbox widget.
  724. # amount - +1 to move down one item, -1 to move back one item.
  725. sub UpDown
  726. {
  727.  my $w = shift;
  728.  my $amount = shift;
  729.  $w->activate($w->index('active')+$amount);
  730.  $w->see('active');
  731.  my $mode = $w->cget('-selectmode');
  732.  if ($mode eq 'browse')
  733.   {
  734.    $w->selectionClear(0,'end');
  735.    $w->selectionSet('active');
  736.    $w->eventGenerate("<<ListboxSelect>>");
  737.   }
  738.  elsif ($mode eq 'extended')
  739.   {
  740.    $w->selectionClear(0,'end');
  741.    $w->selectionSet('active');
  742.    $w->selectionAnchor('active');
  743.    $Prev = $w->index('active');
  744.    @Selection = ();
  745.    $w->eventGenerate("<<ListboxSelect>>");
  746.   }
  747. }
  748. # ExtendUpDown --
  749. #
  750. # Does nothing unless we're in extended selection mode; in this
  751. # case it moves the location cursor (active element) up or down by
  752. # one element, and extends the selection to that point.
  753. #
  754. # Arguments:
  755. # w - The listbox widget.
  756. # amount - +1 to move down one item, -1 to move back one item.
  757. sub ExtendUpDown
  758. {
  759.  my $w = shift;
  760.  my $amount = shift;
  761.  if ($w->cget('-selectmode') ne 'extended')
  762.   {
  763.    return;
  764.   }
  765.  my $active = $w->index('active');
  766.  if (!@Selection)
  767.   {
  768.    $w->selectionSet($active);
  769.    @Selection = $w->curselection;
  770.   }
  771.  $w->activate($active + $amount);
  772.  $w->see('active');
  773.  $w->Motion($w->index('active'))
  774. }
  775. # DataExtend
  776. #
  777. # This procedure is called for key-presses such as Shift-KEndData.
  778. # If the selection mode isn't multiple or extend then it does nothing.
  779. # Otherwise it moves the active element to el and, if we're in
  780. # extended mode, extends the selection to that point.
  781. #
  782. # Arguments:
  783. # w - The listbox widget.
  784. # el - An integer element number.
  785. sub DataExtend
  786. {
  787.  my $w = shift;
  788.  my $el = shift;
  789.  my $mode = $w->cget('-selectmode');
  790.  if ($mode eq 'extended')
  791.   {
  792.    $w->activate($el);
  793.    $w->see($el);
  794.    if ($w->selectionIncludes('anchor'))
  795.     {
  796.      $w->Motion($el)
  797.     }
  798.   }
  799.  elsif ($mode eq 'multiple')
  800.   {
  801.    $w->activate($el);
  802.    $w->see($el)
  803.   }
  804. }
  805. # Cancel
  806. #
  807. # This procedure is invoked to cancel an extended selection in
  808. # progress. If there is an extended selection in progress, it
  809. # restores all of the items between the active one and the anchor
  810. # to their previous selection state.
  811. #
  812. # Arguments:
  813. # w - The listbox widget.
  814. sub Cancel
  815. {
  816.  my $w = shift;
  817.  if ($w->cget('-selectmode') ne 'extended' || !defined $Prev)
  818.   {
  819.    return;
  820.   }
  821.  my $first = $w->index('anchor');
  822.  my $last = $Prev;
  823.  if ($first > $last)
  824.   {
  825.    ($first, $last) = ($last, $first);
  826.   }
  827.  $w->selectionClear($first,$last);
  828.  while ($first <= $last)
  829.   {
  830.    if (Tk::lsearch(\@Selection,$first) >= 0)
  831.     {
  832.      $w->selectionSet($first)
  833.     }
  834.    $first++
  835.   }
  836.  $w->eventGenerate("<<ListboxSelect>>");
  837. }
  838. # SelectAll
  839. #
  840. # This procedure is invoked to handle the "select all" operation.
  841. # For single and browse mode, it just selects the active element.
  842. # Otherwise it selects everything in the widget.
  843. #
  844. # Arguments:
  845. # w - The listbox widget.
  846. sub SelectAll
  847. {
  848.  my $w = shift;
  849.  my $mode = $w->cget('-selectmode');
  850.  if ($mode eq 'single' || $mode eq 'browse')
  851.   {
  852.    $w->selectionClear(0,'end');
  853.    $w->selectionSet('active')
  854.   }
  855.  else
  856.   {
  857.    $w->selectionSet(0,'end')
  858.   }
  859.  $w->eventGenerate("<<ListboxSelect>>");
  860. }
  861.  
  862. # Perl/Tk extensions:
  863. sub SetList
  864. {
  865.  my $w = shift;
  866.  $w->delete(0,'end');
  867.  $w->insert('end',@_);
  868. }
  869.  
  870. sub deleteSelected
  871. {
  872.  my $w = shift;
  873.  my $i;
  874.  foreach $i (reverse $w->curselection)
  875.   {
  876.    $w->delete($i);
  877.   }
  878. }
  879.  
  880. sub clipboardPaste
  881. {
  882.  my $w = shift;
  883.  my $index = $w->index('active') || $w->index($w->XEvent->xy);
  884.  my $str;
  885.  eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
  886.  return if $@;
  887.  foreach (split("\n",$str))
  888.   {
  889.    $w->insert($index++,$_);
  890.   }
  891. }
  892.  
  893. sub getSelected
  894. {
  895.  my ($w) = @_;
  896.  my $i;
  897.  my (@result) = ();
  898.  foreach $i ($w->curselection)
  899.   {
  900.    push(@result,$w->get($i));
  901.   }
  902.  return (wantarray) ? @result : $result[0];
  903. }
  904.  
  905.  
  906.  
  907. 1;
  908. __END__
  909.  
  910.  
  911.