home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Listbox.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  11.1 KB  |  495 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. package Tk::Listbox; 
  14. use Tk qw(Ev);
  15. require Tk::Clipboard;
  16. use AutoLoader;
  17.  
  18. @ISA = qw(Tk::Widget);
  19.  
  20. Construct Tk::Widget 'Listbox';
  21.  
  22. bootstrap Tk::Listbox $Tk::VERSION; 
  23.  
  24. sub Tk_cmd { \&Tk::listbox }
  25.  
  26. use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)],
  27.                      'scan' => [qw(mark dragto)]
  28.                    );
  29.  
  30. 1;
  31. __END__
  32.  
  33. #
  34. # Bind --
  35. # This procedure is invoked the first time the mouse enters a listbox
  36. # widget or a listbox widget receives the input focus. It creates
  37. # all of the class bindings for listboxes.
  38. #
  39. # Arguments:
  40. # event - Indicates which event caused the procedure to be invoked
  41. # (Enter or FocusIn). It is used so that we can carry out
  42. # the functions of that event in addition to setting up
  43. # bindings.
  44.  
  45. sub xyIndex
  46. {
  47.  my $w = shift;
  48.  my $Ev = $w->XEvent;
  49.  return $w->index($Ev->xy);
  50. }
  51.  
  52. sub ClassInit
  53. {
  54.  my ($class,$mw) = @_;
  55.  
  56.  # Standard Motif bindings:
  57.  $mw->bind($class,"<1>",['BeginSelect',Ev('index',Ev('@'))]);
  58.  $mw->bind($class,"<B1-Motion>",['Motion',Ev('index',Ev('@'))]);
  59.  $mw->bind($class,"<ButtonRelease-1>",
  60.            sub
  61.            {
  62.         my $w = shift;
  63.         my $Ev = $w->XEvent;
  64.         $w->CancelRepeat;
  65.         $w->activate($Ev->xy);
  66.            }
  67.           )
  68.  ;
  69.  $mw->bind($class,"<Shift-1>",['BeginExtend',Ev('index',Ev('@'))]);
  70.  $mw->bind($class,"<Control-1>",['BeginToggle',Ev('index',Ev('@'))]);
  71.  
  72.  $mw->bind($class,"<B1-Leave>",['AutoScan',Ev('x'),Ev('y')]);
  73.  $mw->bind($class,"<B1-Enter>",'CancelRepeat');
  74.  $mw->bind($class,"<Up>",['UpDown',-1]);
  75.  $mw->bind($class,"<Shift-Up>",['ExtendUpDown',-1]);
  76.  $mw->bind($class,"<Down>",['UpDown',1]);
  77.  $mw->bind($class,"<Shift-Down>",['ExtendUpDown',1]);
  78.  
  79.  $mw->XscrollBind($class); 
  80.  $mw->PriorNextBind($class); 
  81.  
  82.  $mw->bind($class,"<Control-Home>",
  83.            sub
  84.            {
  85.         my $w = shift;
  86.         my $Ev = $w->XEvent;
  87.         $w->activate(0);
  88.         $w->see(0);
  89.         $w->selectionClear(0,"end");
  90.         $w->selectionSet(0)
  91.            }
  92.           )
  93.  ;
  94.  $mw->bind($class,"<Shift-Control-Home>",['DataExtend',0]);
  95.  $mw->bind($class,"<Control-End>",
  96.            sub
  97.            {
  98.         my $w = shift;
  99.         my $Ev = $w->XEvent;
  100.         $w->activate("end");
  101.         $w->see("end");
  102.         $w->selectionClear(0,"end");
  103.         $w->selectionSet('end')
  104.            }
  105.           )
  106.  ;
  107.  $mw->bind($class,"<Shift-Control-End>",['DataExtend','end']);
  108.  $class->clipboardKeysyms($mw,"F16");
  109.  $mw->bind($class,"<space>",['BeginSelect',Ev('index','active')]);
  110.  $mw->bind($class,"<Select>",['BeginSelect',Ev('index','active')]);
  111.  $mw->bind($class,"<Control-Shift-space>",['BeginExtend',Ev('index','active')]);
  112.  $mw->bind($class,"<Shift-Select>",['BeginExtend',Ev('index','active')]);
  113.  $mw->bind($class,"<Escape>",'Cancel');
  114.  $mw->bind($class,"<Control-slash>",'SelectAll');
  115.  $mw->bind($class,"<Control-backslash>",
  116.            sub
  117.            {
  118.         my $w = shift;
  119.         my $Ev = $w->XEvent;
  120.         if ($w->cget("-selectmode") ne "browse")
  121.          {
  122.           $w->selectionClear(0,"end");
  123.          }
  124.            }
  125.           )
  126.  ;
  127.  # Additional Tk bindings that aren't part of the Motif look and feel:
  128.  $mw->bind($class,"<2>",['scan','mark',Ev('x'),Ev('y')]);
  129.  $mw->bind($class,"<B2-Motion>",['scan','dragto',Ev('x'),Ev('y')]);
  130.  return $class;
  131. }
  132. # BeginSelect --
  133. #
  134. # This procedure is typically invoked on button-1 presses. It begins
  135. # the process of making a selection in the listbox. Its exact behavior
  136. # depends on the selection mode currently in effect for the listbox;
  137. # see the Motif documentation for details.
  138. #
  139. # Arguments:
  140. # w - The listbox widget.
  141. # el - The element for the selection operation (typically the
  142. # one under the pointer). Must be in numerical form.
  143. sub BeginSelect
  144. {
  145.  my $w = shift;
  146.  my $el = shift;
  147.  if ($w->cget("-selectmode") eq "multiple")
  148.   {
  149.    if ($w->selectionIncludes($el))
  150.     {
  151.      $w->selectionClear($el)
  152.     }
  153.    else
  154.     {
  155.      $w->selectionSet($el)
  156.     }
  157.   }
  158.  else
  159.   {
  160.    $w->selectionClear(0,"end");
  161.    $w->selectionSet($el);
  162.    $w->selectionAnchor($el);
  163.    @Selection = ();
  164.    $Prev = $el
  165.   }
  166. }
  167. # Motion --
  168. #
  169. # This procedure is called to process mouse motion events while
  170. # button 1 is down. It may move or extend the selection, depending
  171. # on the listbox's selection mode.
  172. #
  173. # Arguments:
  174. # w - The listbox widget.
  175. # el - The element under the pointer (must be a number).
  176. sub Motion
  177. {
  178.  my $w = shift;
  179.  my $el = shift;
  180.  if (defined($Prev) && $el == $Prev)
  181.   {
  182.    return;
  183.   }
  184.  $anchor = $w->index("anchor");
  185.  my $mode = $w->cget("-selectmode");
  186.  if ($mode eq "browse")
  187.   {
  188.    $w->selectionClear(0,"end");
  189.    $w->selectionSet($el);
  190.    $Prev = $el;
  191.   }
  192.  elsif ($mode eq "extended")
  193.   {
  194.    $i = $Prev;
  195.    if ($w->selectionIncludes('anchor'))
  196.     {
  197.      $w->selectionClear($i,$el);
  198.      $w->selectionSet("anchor",$el)
  199.     }
  200.    else
  201.     {
  202.      $w->selectionClear($i,$el);
  203.      $w->selectionClear("anchor",$el)
  204.     }
  205.    while ($i < $el && $i < $anchor)
  206.     {
  207.      if (Tk::lsearch(\@Selection,$i) >= 0)
  208.       {
  209.        $w->selectionSet($i)
  210.       }
  211.      $i += 1
  212.     }
  213.    while ($i > $el && $i > $anchor)
  214.     {
  215.      if (Tk::lsearch(\@Selection,$i) >= 0)
  216.       {
  217.        $w->selectionSet($i)
  218.       }
  219.      $i += -1
  220.     }
  221.    $Prev = $el
  222.   }
  223. }
  224. # BeginExtend --
  225. #
  226. # This procedure is typically invoked on shift-button-1 presses. It
  227. # begins the process of extending a selection in the listbox. Its
  228. # exact behavior depends on the selection mode currently in effect
  229. # for the listbox; see the Motif documentation for details.
  230. #
  231. # Arguments:
  232. # w - The listbox widget.
  233. # el - The element for the selection operation (typically the
  234. # one under the pointer). Must be in numerical form.
  235. sub BeginExtend
  236. {
  237.  my $w = shift;
  238.  my $el = shift;
  239.  if ($w->cget("-selectmode") eq "extended" && $w->selectionIncludes("anchor"))
  240.   {
  241.    $w->Motion($el)
  242.   }
  243. }
  244. # BeginToggle --
  245. #
  246. # This procedure is typically invoked on control-button-1 presses. It
  247. # begins the process of toggling a selection in the listbox. Its
  248. # exact behavior depends on the selection mode currently in effect
  249. # for the listbox; see the Motif documentation for details.
  250. #
  251. # Arguments:
  252. # w - The listbox widget.
  253. # el - The element for the selection operation (typically the
  254. # one under the pointer). Must be in numerical form.
  255. sub BeginToggle
  256. {
  257.  my $w = shift;
  258.  my $el = shift;
  259.  if ($w->cget("-selectmode") eq "extended")
  260.   {
  261.    @Selection = $w->curselection();
  262.    $Prev = $el;
  263.    $w->selectionAnchor($el);
  264.    if ($w->selectionIncludes($el))
  265.     {
  266.      $w->selectionClear($el)
  267.     }
  268.    else
  269.     {
  270.      $w->selectionSet($el)
  271.     }
  272.   }
  273. }
  274. # AutoScan --
  275. # This procedure is invoked when the mouse leaves an entry window
  276. # with button 1 down. It scrolls the window up, down, left, or
  277. # right, depending on where the mouse left the window, and reschedules
  278. # itself as an "after" command so that the window continues to scroll until
  279. # the mouse moves back into the window or the mouse button is released.
  280. #
  281. # Arguments:
  282. # w - The entry window.
  283. # x - The x-coordinate of the mouse when it left the window.
  284. # y - The y-coordinate of the mouse when it left the window.
  285. sub AutoScan
  286. {
  287.  my $w = shift;
  288.  my $x = shift;
  289.  my $y = shift;
  290.  if ($y >= $w->height)
  291.   {
  292.    $w->yview("scroll",1,"units")
  293.   }
  294.  elsif ($y < 0)
  295.   {
  296.    $w->yview("scroll",-1,"units")
  297.   }
  298.  elsif ($x >= $w->width)
  299.   {
  300.    $w->xview("scroll",2,"units")
  301.   }
  302.  elsif ($x < 0)
  303.   {
  304.    $w->xview("scroll",-2,"units")
  305.   }
  306.  else
  307.   {
  308.    return;
  309.   }
  310.  $w->Motion($w->index("@" . $x . ',' . $y));
  311.  $w->RepeatId($w->after(50,"AutoScan",$w,$x,$y));
  312. }
  313. # UpDown --
  314. #
  315. # Moves the location cursor (active element) up or down by one element,
  316. # and changes the selection if we're in browse or extended selection
  317. # mode.
  318. #
  319. # Arguments:
  320. # w - The listbox widget.
  321. # amount - +1 to move down one item, -1 to move back one item.
  322. sub UpDown
  323. {
  324.  my $w = shift;
  325.  my $amount = shift;
  326.  $w->activate($w->index("active")+$amount);
  327.  $w->see("active");
  328.  $LNet__0 = $w->cget("-selectmode");
  329.  if ($LNet__0 eq "browse")
  330.   {
  331.    $w->selectionClear(0,"end");
  332.    $w->selectionSet("active")
  333.   }
  334.  elsif ($LNet__0 eq "extended")
  335.   {
  336.    $w->selectionClear(0,"end");
  337.    $w->selectionSet("active");
  338.    $w->selectionAnchor("active");
  339.    $Prev = $w->index("active");
  340.    @Selection = ();
  341.   }
  342. }
  343. # ExtendUpDown --
  344. #
  345. # Does nothing unless we're in extended selection mode; in this
  346. # case it moves the location cursor (active element) up or down by
  347. # one element, and extends the selection to that point.
  348. #
  349. # Arguments:
  350. # w - The listbox widget.
  351. # amount - +1 to move down one item, -1 to move back one item.
  352. sub ExtendUpDown
  353. {
  354.  my $w = shift;
  355.  my $amount = shift;
  356.  if ($w->cget("-selectmode") ne "extended")
  357.   {
  358.    return;
  359.   }
  360.  $w->activate($w->index("active")+$amount);
  361.  $w->see("active");
  362.  $w->Motion($w->index("active"))
  363. }
  364. # DataExtend
  365. #
  366. # This procedure is called for key-presses such as Shift-KEndData.
  367. # If the selection mode isn't multiple or extend then it does nothing.
  368. # Otherwise it moves the active element to el and, if we're in
  369. # extended mode, extends the selection to that point.
  370. #
  371. # Arguments:
  372. # w - The listbox widget.
  373. # el - An integer element number.
  374. sub DataExtend
  375. {
  376.  my $w = shift;
  377.  my $el = shift;
  378.  $mode = $w->cget("-selectmode");
  379.  if ($mode eq "extended")
  380.   {
  381.    $w->activate($el);
  382.    $w->see($el);
  383.    if ($w->selectionIncludes("anchor"))
  384.     {
  385.      $w->Motion($el)
  386.     }
  387.   }
  388.  elsif ($mode eq "multiple")
  389.   {
  390.    $w->activate($el);
  391.    $w->see($el)
  392.   }
  393. }
  394. # Cancel
  395. #
  396. # This procedure is invoked to cancel an extended selection in
  397. # progress. If there is an extended selection in progress, it
  398. # restores all of the items between the active one and the anchor
  399. # to their previous selection state.
  400. #
  401. # Arguments:
  402. # w - The listbox widget.
  403. sub Cancel
  404. {
  405.  my $w = shift;
  406.  if ($w->cget("-selectmode") ne "extended")
  407.   {
  408.    return;
  409.   }
  410.  $first = $w->index("anchor");
  411.  $last = $Prev;
  412.  if ($first > $last)
  413.   {
  414.    $tmp = $first;
  415.    $first = $last;
  416.    $last = $tmp
  417.   }
  418.  $w->selectionClear($first,$last);
  419.  while ($first <= $last)
  420.   {
  421.    if (Tk::lsearch(\@Selection,$first) >= 0)
  422.     {
  423.      $w->selectionSet($first)
  424.     }
  425.    $first += 1
  426.   }
  427. }
  428. # SelectAll
  429. #
  430. # This procedure is invoked to handle the "select all" operation.
  431. # For single and browse mode, it just selects the active element.
  432. # Otherwise it selects everything in the widget.
  433. #
  434. # Arguments:
  435. # w - The listbox widget.
  436. sub SelectAll
  437. {
  438.  my $w = shift;
  439.  my $mode = $w->cget("-selectmode");
  440.  if ($mode eq "single" || $mode eq "browse")
  441.   {
  442.    $w->selectionClear(0,"end");
  443.    $w->selectionSet("active")
  444.   }
  445.  else
  446.   {
  447.    $w->selectionSet(0,"end")
  448.   }
  449. }
  450.  
  451. sub SetList
  452. {
  453.  my $w = shift;
  454.  $w->delete(0,"end");
  455.  $w->insert("end",@_);
  456. }
  457.  
  458. sub Getselected
  459. {
  460.  my ($w) = @_;
  461.  my $i;
  462.  my (@result) = ();
  463.  foreach $i ($w->curselection)
  464.   {
  465.    push(@result,$w->get($i));
  466.   }
  467.  return (wantarray) ? @result : $result[0];
  468. }
  469.  
  470. sub deleteSelected
  471. {
  472.  my $w = shift;
  473.  my $i;
  474.  foreach $i (reverse $w->curselection)
  475.   {
  476.    $w->delete($i);
  477.   }
  478. }
  479.  
  480. sub clipboardPaste
  481. {
  482.  my $w = shift;
  483.  my $index = $w->index('active') || $w->index($w->XEvent->xy);
  484.  my $str;
  485.  eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
  486.  return if $@;
  487.  foreach (split("\n",$str))
  488.   {
  489.    $w->insert($index++,$_);
  490.   }
  491. }
  492.  
  493. 1;
  494. __END__
  495.