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