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 / _854c7921a6050e63e3959d567651636d < prev    next >
Encoding:
Text File  |  2004-04-13  |  14.6 KB  |  537 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 by Slaven Rezic <eserte@cs.tu-berlin.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. use strict;
  40.  
  41. use vars qw($VERSION);
  42. $VERSION = '3.005'; # $Id: //depot/Tk8/Tk/IconList.pm#5 $
  43.  
  44. use base 'Tk::Frame';
  45.  
  46. Construct Tk::Widget 'IconList';
  47.  
  48. # tkIconList_Create --
  49. #
  50. #    Creates an IconList widget by assembling a canvas widget and a
  51. #    scrollbar widget. Sets all the bindings necessary for the IconList's
  52. #    operations.
  53. #
  54. sub Populate {
  55.     my($w, $args) = @_;
  56.     $w->SUPER::Populate($args);
  57.  
  58.     my $sbar = $w->Component('Scrollbar' => 'sbar',
  59.                  -orient => 'horizontal',
  60.                  -highlightthickness => 0,
  61.                  -takefocus => 0,
  62.                 );
  63.     my $canvas = $w->Component('Canvas' => 'canvas',
  64.                    -bd => 2,
  65.                    -relief => 'sunken',
  66.                    -width => 400,
  67.                    -height => 120,
  68.                    -takefocus => 1,
  69.                   );
  70.     $sbar->pack(-side => 'bottom', -fill => 'x', -padx => 2);
  71.     $canvas->pack(-expand => 'yes', -fill => 'both');
  72.     $sbar->configure(-command => ['xview', $canvas]);
  73.     $canvas->configure(-xscrollcommand => ['set', $sbar]);
  74.  
  75.     # Initializes the max icon/text width and height and other variables
  76.     $w->{'maxIW'} = 1;
  77.     $w->{'maxIH'} = 1;
  78.     $w->{'maxTW'} = 1;
  79.     $w->{'maxTH'} = 1;
  80.     $w->{'numItems'} = 0;
  81.     delete $w->{'curItem'};
  82.     $w->{'noScroll'} = 1;
  83.  
  84.     # Creates the event bindings.
  85.     $canvas->Tk::bind('<Configure>', sub { $w->Arrange } );
  86.     $canvas->Tk::bind('<1>',
  87.               sub {
  88.               my $c = shift;
  89.               my $Ev = $c->XEvent;
  90.               $w->Btn1($Ev->x, $Ev->y);
  91.               }
  92.              );
  93.     $canvas->Tk::bind('<B1-Motion>',
  94.               sub {
  95.               my $c = shift;
  96.               my $Ev = $c->XEvent;
  97.               $w->Motion1($Ev->x, $Ev->y);
  98.               }
  99.              );
  100.     $canvas->Tk::bind('<Double-ButtonRelease-1>',
  101.               sub {
  102.               my $c = shift;
  103.               my $Ev = $c->XEvent;
  104.               $w->Double1($Ev->x,$Ev->y);
  105.               }
  106.              );
  107.     $canvas->Tk::bind('<ButtonRelease-1>', sub { $w->CancelRepeat });
  108.     $canvas->Tk::bind('<B1-Leave>',
  109.               sub {
  110.               my $c = shift;
  111.               my $Ev = $c->XEvent;
  112.               $w->Leave1($Ev->x, $Ev->y);
  113.               }
  114.              );
  115.     $canvas->Tk::bind('<B1-Enter>', sub { $w->CancelRepeat });
  116.     $canvas->Tk::bind('<Up>',     sub { $w->UpDown(-1) });
  117.     $canvas->Tk::bind('<Down>',   sub { $w->UpDown(1)  });
  118.     $canvas->Tk::bind('<Left>',   sub { $w->LeftRight(-1) });
  119.     $canvas->Tk::bind('<Right>',  sub { $w->LeftRight(1) });
  120.     $canvas->Tk::bind('<Return>', sub { $w->ReturnKey });
  121.     $canvas->Tk::bind('<KeyPress>',
  122.               sub {
  123.               my $c = shift;
  124.               my $Ev = $c->XEvent;
  125.               $w->KeyPress($Ev->A);
  126.               }
  127.              );
  128.     $canvas->Tk::bind('<Control-KeyPress>', 'NoOp');
  129.     $canvas->Tk::bind('<Alt-KeyPress>', 'NoOp');
  130.     $canvas->Tk::bind('<FocusIn>', sub { $w->FocusIn });
  131.  
  132.     $w->ConfigSpecs(-browsecmd =>
  133.             ['CALLBACK', 'browseCommand', 'BrowseCommand', undef],
  134.             -command =>
  135.             ['CALLBACK', 'command', 'Command', undef],
  136.             -font =>
  137.             ['PASSIVE', 'font', 'Font', undef],
  138.             -foreground =>
  139.             ['PASSIVE', 'foreground', 'Foreground', undef],
  140.             -fg => '-foreground',
  141.            );
  142.  
  143.     $w;
  144. }
  145.  
  146. # tkIconList_AutoScan --
  147. #
  148. # This procedure is invoked when the mouse leaves an entry window
  149. # with button 1 down.  It scrolls the window up, down, left, or
  150. # right, depending on where the mouse left the window, and reschedules
  151. # itself as an "after" command so that the window continues to scroll until
  152. # the mouse moves back into the window or the mouse button is released.
  153. #
  154. # Arguments:
  155. # w -        The IconList window.
  156. #
  157. sub AutoScan {
  158.     my $w = shift;
  159.     return unless ($w->exists);
  160.     return if ($w->{'noScroll'});
  161.     my($x, $y);
  162.     $x = $Tk::x;
  163.     $y = $Tk::y;
  164.     my $canvas = $w->Subwidget('canvas');
  165.     if ($x >= $canvas->width) {
  166.     $canvas->xview('scroll', 1, 'units');
  167.     } elsif ($x < 0) {
  168.     $canvas->xview('scroll', -1, 'units');
  169.     } elsif ($y >= $canvas->height) {
  170.     # do nothing
  171.     } elsif ($y < 0) {
  172.     # do nothing
  173.     } else {
  174.     return;
  175.     }
  176.     $w->Motion1($x, $y);
  177.     $w->RepeatId($w->after(50, ['AutoScan', $w]));
  178. }
  179.  
  180. # Deletes all the items inside the canvas subwidget and reset the IconList's
  181. # state.
  182. #
  183. sub DeleteAll {
  184.     my $w = shift;
  185.     my $canvas = $w->Subwidget('canvas');
  186.     $canvas->delete('all');
  187.     delete $w->{'selected'};
  188.     delete $w->{'rect'};
  189.     delete $w->{'list'};
  190.     delete $w->{'itemList'};
  191.     $w->{'maxIW'} = 1;
  192.     $w->{'maxIH'} = 1;
  193.     $w->{'maxTW'} = 1;
  194.     $w->{'maxTH'} = 1;
  195.     $w->{'numItems'} = 0;
  196.     delete $w->{'curItem'};
  197.     $w->{'noScroll'} = 1;
  198.     $w->Subwidget('sbar')->set(0.0, 1.0);
  199.     $canvas->xview('moveto', 0);
  200. }
  201.  
  202. # Adds an icon into the IconList with the designated image and text
  203. #
  204. sub Add {
  205.     my($w, $image, $text) = @_;
  206.     my $canvas = $w->Subwidget('canvas');
  207.     my $iTag = $canvas->createImage(0, 0, -image => $image, -anchor => 'nw');
  208.     my $font = $w->cget(-font);
  209.     my $fg   = $w->cget(-foreground);
  210.     my $tTag = $canvas->createText(0, 0, -text => $text, -anchor => 'nw',
  211.                    (defined $fg   ? (-fill => $fg)   : ()),
  212.                    (defined $font ? (-font => $font) : ()),
  213.                   );
  214.     my $rTag = $canvas->createRectangle(0, 0, 0, 0,
  215.                     -fill => undef,
  216.                     -outline => undef);
  217.     my(@b) = $canvas->bbox($iTag);
  218.     my $iW = $b[2] - $b[0];
  219.     my $iH = $b[3] - $b[1];
  220.     $w->{'maxIW'} = $iW if ($w->{'maxIW'} < $iW);
  221.     $w->{'maxIH'} = $iH if ($w->{'maxIH'} < $iH);
  222.     @b = $canvas->bbox($tTag);
  223.     my $tW = $b[2] - $b[0];
  224.     my $tH = $b[3] - $b[1];
  225.     $w->{'maxTW'} = $tW if ($w->{'maxTW'} < $tW);
  226.     $w->{'maxTH'} = $tH if ($w->{'maxTH'} < $tH);
  227.     push @{ $w->{'list'} }, [$iTag, $tTag, $rTag, $iW, $iH, $tW, $tH,
  228.                  $w->{'numItems'}];
  229.     $w->{'itemList'}{$rTag} = [$iTag, $tTag, $text, $w->{'numItems'}];
  230.     $w->{'textList'}{$w->{'numItems'}} = lc($text);
  231.     ++$w->{'numItems'};
  232. }
  233.  
  234. # Places the icons in a column-major arrangement.
  235. #
  236. sub Arrange {
  237.     my $w = shift;
  238.     my $canvas = $w->Subwidget('canvas');
  239.     my $sbar   = $w->Subwidget('sbar');
  240.     unless (exists $w->{'list'}) {
  241.     if (defined $canvas && Tk::Exists($canvas)) {
  242.         $w->{'noScroll'} = 1;
  243.         $sbar->configure(-command => sub { });
  244.     }
  245.     return;
  246.     }
  247.  
  248.     my $W = $canvas->width;
  249.     my $H = $canvas->height;
  250.     my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
  251.     $pad = 2 if ($pad < 2);
  252.     $W -= $pad*2;
  253.     $H -= $pad*2;
  254.     my $dx = $w->{'maxIW'} + $w->{'maxTW'} + 8;
  255.     my $dy;
  256.     if ($w->{'maxTH'} > $w->{'maxIH'}) {
  257.     $dy = $w->{'maxTH'};
  258.     } else {
  259.     $dy = $w->{'maxIH'};
  260.     }
  261.     $dy += 2;
  262.     my $shift = $w->{'maxIW'} + 4;
  263.     my $x = $pad * 2;
  264.     my $y = $pad;
  265.     my $usedColumn = 0;
  266.     foreach my $sublist (@{ $w->{'list'} }) {
  267.     $usedColumn = 1;
  268.     my($iTag, $tTag, $rTag, $iW, $iH, $tW, $tH) = @$sublist;
  269.     my $i_dy = ($dy - $iH) / 2;
  270.     my $t_dy = ($dy - $tH) / 2;
  271.     $canvas->coords($iTag, $x, $y + $i_dy);
  272.     $canvas->coords($tTag, $x + $shift, $y + $t_dy);
  273.     $canvas->coords($tTag, $x + $shift, $y + $t_dy);
  274.     $canvas->coords($rTag, $x, $y, $x + $dx, $y + $dy);
  275.     $y += $dy;
  276.     if ($y + $dy > $H) {
  277.         $y = $pad;
  278.         $x += $dx;
  279.         $usedColumn = 0;
  280.     }
  281.     }
  282.     my $sW;
  283.     if ($usedColumn) {
  284.     $sW = $x + $dx;
  285.     } else {
  286.     $sW = $x;
  287.     }
  288.     if ($sW < $W) {
  289.     $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
  290.     $sbar->configure(-command => sub { });
  291.     $canvas->xview(moveto => 0);
  292.     $w->{'noScroll'} = 1;
  293.     } else {
  294.     $canvas->configure(-scrollregion => [$pad, $pad, $sW, $H]);
  295.     $sbar->configure(-command => ['xview', $canvas]);
  296.     $w->{'noScroll'} = 0;
  297.     }
  298.     $w->{'itemsPerColumn'} = ($H - $pad) / $dy;
  299.     $w->{'itemsPerColumn'} = 1 if ($w->{'itemsPerColumn'} < 1);
  300.     $w->Select($w->{'list'}[$w->{'curItem'}][2], 0)
  301.       if (exists $w->{'curItem'});
  302. }
  303.  
  304. # Gets called when the user invokes the IconList (usually by double-clicking
  305. # or pressing the Return key).
  306. #
  307. sub Invoke {
  308.     my $w = shift;
  309.     $w->Callback(-command => $w->{'selected'}) if (exists $w->{'selected'});
  310. }
  311.  
  312. # tkIconList_See --
  313. #
  314. #    If the item is not (completely) visible, scroll the canvas so that
  315. #    it becomes visible.
  316. sub See {
  317.     my($w, $rTag) = @_;
  318.     return if ($w->{'noScroll'});
  319.     return unless (exists $w->{'itemList'}{$rTag});
  320.     my $canvas = $w->Subwidget('canvas');
  321.     my(@sRegion) = @{ $canvas->cget('-scrollregion') };
  322.     return unless (@sRegion);
  323.     my(@bbox) = $canvas->bbox($rTag);
  324.     my $pad = $canvas->cget(-highlightthickness) + $canvas->cget(-bd);
  325.     my $x1 = $bbox[0];
  326.     my $x2 = $bbox[2];
  327.     $x1 -= $pad * 2;
  328.     $x2 -= $pad;
  329.     my $cW = $canvas->width - $pad * 2;
  330.     my $scrollW = $sRegion[2] - $sRegion[0] + 1;
  331.     my $dispX = int(($canvas->xview)[0] * $scrollW);
  332.     my $oldDispX = $dispX;
  333.     # check if out of the right edge
  334.     $dispX = $x2 - $cW if ($x2 - $dispX >= $cW);
  335.     # check if out of the left edge
  336.     $dispX = $x1 if ($x1 - $dispX < 0);
  337.     if ($oldDispX != $dispX) {
  338.     my $fraction = $dispX / $scrollW;
  339.     $canvas->xview('moveto', $fraction);
  340.     }
  341. }
  342.  
  343. sub SelectAtXY {
  344.     my($w, $x, $y) = @_;
  345.     my $canvas = $w->Subwidget('canvas');
  346.     $w->Select($canvas->find('closest',
  347.                  $canvas->canvasx($x),
  348.                  $canvas->canvasy($y)));
  349. }
  350.  
  351. sub Select {
  352.     my $w = shift;
  353.     my $rTag = shift;
  354.     my $callBrowse = (@_ ? shift : 1);
  355.     return unless (exists $w->{'itemList'}{$rTag});
  356.     my($iTag, $tTag, $text, $serial) = @{ $w->{'itemList'}{$rTag} };
  357.     my $canvas = $w->Subwidget('canvas');
  358.     $w->{'rect'} = $canvas->createRectangle(0, 0, 0, 0, -fill => '#a0a0ff',
  359.                         -outline => '#a0a0ff')
  360.       unless (exists $w->{'rect'});
  361.     $canvas->lower($w->{'rect'});
  362.     my(@bbox) = $canvas->bbox($tTag);
  363.     $canvas->coords($w->{'rect'}, @bbox);
  364.     $w->{'curItem'} = $serial;
  365.     $w->{'selected'} = $text;
  366.     if ($callBrowse) {
  367.     $w->Callback(-browsecmd => $text);
  368.     }
  369. }
  370.  
  371. sub Unselect {
  372.     my $w = shift;
  373.     my $canvas = $w->Subwidget('canvas');
  374.     if (exists $w->{'rect'}) {
  375.     $canvas->delete($w->{'rect'});
  376.     delete $w->{'rect'};
  377.     }
  378.     delete $w->{'selected'} if (exists $w->{'selected'});
  379.     delete $w->{'curItem'};
  380. }
  381.  
  382. # Returns the selected item
  383. #
  384. sub Get {
  385.     my $w = shift;
  386.     if (exists $w->{'selected'}) {
  387.     $w->{'selected'};
  388.     } else {
  389.     undef;
  390.     }
  391. }
  392.  
  393. sub Btn1 {
  394.     my($w, $x, $y) = @_;
  395.     $w->Subwidget('canvas')->focus;
  396.     $w->SelectAtXY($x, $y);
  397. }
  398.  
  399. # Gets called on button-1 motions
  400. #
  401. sub Motion1 {
  402.     my($w, $x, $y) = @_;
  403.     $Tk::x = $x;
  404.     $Tk::y = $y;
  405.     $w->SelectAtXY($x, $y);
  406. }
  407.  
  408. sub Double1 {
  409.     my($w, $x, $y) = @_;
  410.     $w->Invoke if (exists $w->{'curItem'});
  411. }
  412.  
  413. sub ReturnKey {
  414.     my $w = shift;
  415.     $w->Invoke;
  416. }
  417.  
  418. sub Leave1 {
  419.     my($w, $x, $y) = @_;
  420.     $Tk::x = $x;
  421.     $Tk::y = $y;
  422.     $w->AutoScan;
  423. }
  424.  
  425. sub FocusIn {
  426.     my $w = shift;
  427.     return unless (exists $w->{'list'});
  428.     unless (exists $w->{'curItem'}) {
  429.     my $rTag = $w->{'list'}[0][2];
  430.     $w->Select($rTag);
  431.     }
  432. }
  433.  
  434. # tkIconList_UpDown --
  435. #
  436. # Moves the active element up or down by one element
  437. #
  438. # Arguments:
  439. # w -        The IconList widget.
  440. # amount -    +1 to move down one item, -1 to move back one item.
  441. #
  442. sub UpDown {
  443.     my($w, $amount) = @_;
  444.     my $rTag;
  445.     return unless (exists $w->{'list'});
  446.     unless (exists $w->{'curItem'}) {
  447.     $rTag = $w->{'list'}[0][2];
  448.     } else {
  449.     my $oldRTag = $w->{'list'}[$w->{'curItem'}][2];
  450.     $rTag = $w->{'list'}[($w->{'curItem'} + $amount)][2];
  451.     $rTag = $oldRTag unless defined $rTag;
  452.     }
  453.     if (defined $rTag) {
  454.     $w->Select($rTag);
  455.     $w->See($rTag);
  456.     }
  457. }
  458.  
  459. # tkIconList_LeftRight --
  460. #
  461. # Moves the active element left or right by one column
  462. #
  463. # Arguments:
  464. # w -        The IconList widget.
  465. # amount -    +1 to move right one column, -1 to move left one column.
  466. #
  467. sub LeftRight {
  468.     my($w, $amount) = @_;
  469.     my $rTag;
  470.     return unless (exists $w->{'list'});
  471.     unless (exists $w->{'curItem'}) {
  472.     $rTag = $w->{'list'}[0][2];
  473.     } else {
  474.     my $oldRTag = $w->{'list'}[$w->{'curItem'}][2];
  475.     my $newItem = $w->{'curItem'} + $amount * $w->{'itemsPerColumn'};
  476.     $rTag = $w->{'list'}[$newItem][2];
  477.     $rTag = $oldRTag unless (defined $rTag);
  478.     }
  479.     if (defined $rTag) {
  480.     $w->Select($rTag);
  481.     $w->See($rTag);
  482.     }
  483. }
  484.  
  485. #----------------------------------------------------------------------
  486. #        Accelerator key bindings
  487. #----------------------------------------------------------------------
  488. # tkIconList_KeyPress --
  489. #
  490. #    Gets called when user enters an arbitrary key in the listbox.
  491. #
  492. sub KeyPress {
  493.     my($w, $key) = @_;
  494.     $w->{'_ILAccel'} .= $key;
  495.     $w->Goto($w->{'_ILAccel'});
  496.     eval {
  497.     $w->afterCancel($w->{'_ILAccel_afterid'});
  498.     };
  499.     $w->{'_ILAccel_afterid'} = $w->after(500, ['Reset', $w]);
  500. }
  501.  
  502. sub Goto {
  503.     my($w, $text) = @_;
  504.     return unless (exists $w->{'list'});
  505.     return if (not defined $text or $text eq '');
  506.     my $start = (!exists $w->{'curItem'} ? 0 : $w->{'curItem'});
  507.     $text = lc($text);
  508.     my $theIndex = -1;
  509.     my $less = 0;
  510.     my $len = length($text);
  511.     my $i = $start;
  512.     # Search forward until we find a filename whose prefix is an exact match
  513.     # with $text
  514.     while (1) {
  515.     my $sub = substr($w->{'textList'}{$i}, 0, $len);
  516.     if ($text eq $sub) {
  517.         $theIndex = $i;
  518.         last;
  519.     }
  520.     ++$i;
  521.     $i = 0 if ($i == $w->{'numItems'});
  522.     last if ($i == $start);
  523.     }
  524.     if ($theIndex > -1) {
  525.     my $rTag = $w->{'list'}[$theIndex][2];
  526.     $w->Select($rTag, 0);
  527.     $w->See($rTag);
  528.     }
  529. }
  530.  
  531. sub Reset {
  532.     my $w = shift;
  533.     undef $w->{'_ILAccel'};
  534. }
  535.  
  536. 1;
  537.