home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / BrowseEntry.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  7.4 KB  |  319 lines
  1. # $Id: BrowseEntry.pm,v 1.4 1997/02/08 19:19:35 rsi Exp $
  2. #
  3. # BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
  4.  
  5. package Tk::BrowseEntry;
  6.  
  7. use Tk;
  8. use Carp;
  9. use strict;
  10.  
  11. require Tk::Frame;
  12. require Tk::LabEntry;
  13.  
  14. Tk::Widget->Construct("BrowseEntry");
  15.  
  16. @Tk::BrowseEntry::ISA = qw(Tk::Frame);
  17.  
  18. sub Populate {
  19.     my ($w, $args) = @_;
  20.  
  21.     $w->SUPER::Populate($args);
  22.  
  23.     # entry widget and arrow button
  24.     $w->{-variable} = delete $args->{-variable};
  25.     my $lpack = delete $args->{-labelPack};
  26.     if (not defined $lpack) {
  27.     $lpack = [-side => "left", -anchor => "e"];
  28.     }
  29.     my $e = $w->LabEntry(-labelPack => $lpack, %$args);
  30.     delete $args->{-label};
  31.     my $b = $w->Button(-bitmap => '@' . Tk->findINC("cbxarrow.xbm"));
  32.     $w->Advertise("entry" => $e);
  33.     $w->Advertise("arrow" => $b);
  34.     $b->pack(-side => "right", -padx => 1);
  35.     $e->pack(-side => "right", -fill => 'x', -expand => 1, -padx => 1);
  36.     $e->configure(-textvariable => $w->{-variable});
  37.  
  38.     # popup shell for listbox with values.
  39.     my $c = $w->Toplevel(-bd => 2, -relief => "raised");
  40.     $c->overrideredirect(1);
  41.     $c->withdraw;
  42.     my $sl = $c->ScrlListbox(-selectmode => "browse");
  43.     $w->Advertise("choices" => $c);
  44.     $w->Advertise("slistbox" => $sl);
  45.     $sl->pack(-expand => 1, -fill => "both");
  46.  
  47.     # other initializations
  48.     $w->SetBindings;
  49.     $w->{"popped"} = 0;
  50.     $w->Delegates('insert' => $sl, 'delete' => $sl, DEFAULT => $e);
  51.     $w->ConfigSpecs(-listwidth => ["PASSIVE", "listWidth", "ListWidth", undef],
  52.             -listcmd => ["PASSIVE", "listCmd", "ListCmd", undef],
  53.             -browsecmd => ["PASSIVE", "browseCmd", "BrowseCmd", undef],
  54.             "DEFAULT" => [$e]);
  55. }
  56.  
  57. sub SetBindings {
  58.     my ($w) = @_;
  59.  
  60.     my $e = $w->Subwidget("entry");
  61.     my $b = $w->Subwidget("arrow");
  62.  
  63.     # set bind tags
  64.     $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, "all"]);
  65.     $e->bindtags([$e, $e->toplevel, "all"]);
  66.  
  67.     # bindings for the button and entry
  68.     $b->bind("<1>", sub {$w->BtnDown;});
  69.     $b->toplevel->bind("<ButtonRelease-1>", sub {$w->ButtonHack;});
  70.  
  71.     # bindings for listbox
  72.     my $sl = $w->Subwidget("slistbox");
  73.     my $l = $sl->Subwidget("listbox");
  74.     $l->bind("<ButtonRelease-1>", sub {
  75.     $w->ButtonHack;
  76.     LbChoose($w, $l->XEvent->x, $l->XEvent->y);
  77.     });
  78.  
  79.     # allow click outside the popped up listbox to pop it down.
  80.     $w->bind("<1>", sub {$w->BtnDown;});
  81. }
  82.  
  83. sub BtnDown {
  84.     my ($w) = @_;
  85.     if ($w->cget(-state) =~ /disabled/) {
  86.     return;
  87.     }
  88.     if ($w->{"popped"}) {
  89.     $w->Popdown;
  90.     $w->{"buttonHack"} = 0;
  91.     } else {
  92.     $w->PopupChoices;
  93.     $w->{"buttonHack"} = 1;
  94.     }
  95. }
  96.  
  97. sub PopupChoices {
  98.     my ($w) = @_;
  99.  
  100.     if (!$w->{"popped"}) {
  101.     my $listcmd = $w->cget(-listcmd);
  102.     if (defined $listcmd) {
  103.         &$listcmd($w);
  104.     }
  105.     my $e = $w->Subwidget("entry");
  106.     my $c = $w->Subwidget("choices");
  107.     my $s = $w->Subwidget("slistbox");
  108.     my $a = $w->Subwidget("arrow");
  109.     my $y1 = $e->rooty + $e->height + 3;
  110.     my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
  111.     my $ht = $s->reqheight + 2 * $bd;
  112.     my $x1 = $e->rootx;
  113.     my ($width, $x2);
  114.     if (defined $w->cget(-listwidth)) {
  115.         $width = $w->cget(-listwidth);
  116.         $x2 = $x1 + $width;
  117.     } else {
  118.         $x2 = $a->rootx + $a->width;
  119.         $width = $x2 - $x1;
  120.     }
  121.     my $rw = $c->reqwidth;
  122.     if ($rw < $width) {
  123.         $rw = $width
  124.     } else {
  125.         if ($rw > $width * 3) {
  126.         $rw = $width * 3;
  127.         }
  128.         if ($rw > $w->vrootwidth) {
  129.         $rw = $w->vrootwidth;
  130.         }
  131.     }
  132.     $width = $rw;
  133.     
  134.     # if listbox is too far right, pull it back to the left
  135.     #
  136.     if ($x2 > $w->vrootwidth) {
  137.         $x1 = $w->vrootwidth - $width;
  138.     }
  139.  
  140.     # if listbox is too far left, pull it back to the right
  141.     #
  142.     if ($x1 < 0) {
  143.         $x1 = 0;
  144.     }
  145.  
  146.     # if listbox is below bottom of screen, pull it up.
  147.     my $y2 = $y1 + $ht;
  148.     if ($y2 > $w->vrootheight) {
  149.         $y1 = $y1 - $ht - ($e->height - 5);
  150.     }
  151.  
  152.     $c->geometry(sprintf("%dx%d+%d+%d", $rw, $ht, $x1, $y1));
  153.     $c->deiconify;
  154.     $c->raise;
  155.     $e->focus;
  156.     $w->{"popped"} = 1;
  157.  
  158.     $c->configure(-cursor => "arrow");
  159.     $w->grabGlobal;
  160.     }
  161. }
  162.  
  163. # choose value from listbox if appropriate
  164. sub LbChoose {
  165.     my ($w, $x, $y) = @_;
  166.     my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
  167.     if ((($x < 0) || ($x > $l->Width)) ||
  168.     (($y < 0) || ($y > $l->Height))) {
  169.     # mouse was clicked outside the listbox... close the listbox
  170.     $w->LbClose;
  171.     } else {
  172.     # select appropriate entry and close the listbox
  173.     $w->LbCopySelection;
  174.     my $browsecmd = $w->cget(-browsecmd);
  175.     if (defined $browsecmd) {
  176.         &$browsecmd($w, $w->Subwidget('entry')->get());
  177.     }
  178.     }
  179. }
  180.  
  181. # close the listbox after clearing selection
  182. sub LbClose {
  183.     my ($w) = @_;
  184.     my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
  185.     $l->selection("clear", 0, "end");
  186.     $w->Popdown;
  187. }
  188.  
  189. # copy the selection to the entry and close listbox
  190. sub LbCopySelection {
  191.     my ($w) = @_;
  192.     my $index = $w->LbIndex;
  193.     if (defined $index) {
  194.     $w->{"curIndex"} = $index;
  195.     my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
  196.     ${$w->{-variable}} = $l->get($index);
  197.     if ($w->{"popped"}) {
  198.         $w->Popdown;
  199.     }
  200.     }
  201.     $w->Popdown;
  202. }
  203.  
  204. sub LbIndex {
  205.     my ($w, $flag) = @_;
  206.     my $sel = $w->Subwidget("slistbox")->Subwidget("listbox")->curselection;
  207.     if (defined $sel) {
  208.     return int($sel);
  209.     } else {
  210.     if (defined $flag && ($flag eq "emptyOK")) {
  211.         return undef;
  212.     } else {
  213.         return 0;
  214.     }
  215.     }
  216. }
  217.  
  218. # pop down the listbox
  219. sub Popdown {
  220.     my ($w) = @_;
  221.     if ($w->{"popped"}) {
  222.     my $c = $w->Subwidget("choices");
  223.     $c->withdraw;
  224.     $w->grabRelease;
  225.     $w->{"popped"} = 0;
  226.     }
  227. }
  228.  
  229. # This hack is to prevent the ugliness of the arrow being depressed.
  230. #
  231. sub ButtonHack {
  232.     my ($w) = @_;
  233.     my $b = $w->Subwidget("arrow");
  234.     if ($w->{"buttonHack"}) {
  235.     $b->butUp;
  236.     }
  237. }
  238.  
  239. 1;
  240.  
  241. __END__
  242.  
  243. =head1 NAME
  244.  
  245. Tk::BrowseEntry - entry widget with popup choices.
  246.  
  247. =head1 SYNOPSIS
  248.  
  249.     use Tk::BrowseEntry;
  250.  
  251.     $b = $frame->BrowseEntry(-label => "Label", -variable => \$var);
  252.     $b->insert("end", "opt1");
  253.     $b->insert("end", "opt2");
  254.     $b->insert("end", "opt3");
  255.     ...
  256.     $b->pack;
  257.  
  258. =head1 DESCRIPTION
  259.  
  260. BrowseEntry is a poor man's ComboBox. It may be considered an
  261. enhanced version of LabEntry which provides a button to popup the
  262. choices of the possible values that the Entry may
  263. take. BrowseEntry supports all the options LabEntry supports
  264. except B<-textvariable>. This is replaced by B<-variable>. Other
  265. options that BrowseEntry supports.
  266.  
  267. =over 4
  268.  
  269. =item B<-listwidth>
  270.  
  271. Specifies the width of the popup listbox.
  272.  
  273. =item B<-variable>
  274.  
  275. Specifies the variable in which the entered value is to be stored.
  276.  
  277. =item B<-browsecmd>
  278.  
  279. Specifies a function to call when a selection is made in the
  280. popped up listbox. It is passed the widget and the text of the
  281. entry selected. This function is called after the entry variable
  282. has been assigned the value.
  283.  
  284. =item B<-listcmd>
  285.  
  286. Specifies the function to call when the button next to the entry
  287. is pressed to popup the choices in the listbox. This is called before
  288. popping up the listbox, so can be used to populate the entries in
  289. the listbox.
  290.  
  291. =back
  292.  
  293. =head1 METHODS
  294.  
  295. =over 4
  296.  
  297. =item B<insert(>I<index>, I<string>B<)>
  298.  
  299. Inserts the text of I<string> at the specified I<index>. This string
  300. then becomes available as one of the choices.
  301.  
  302. =item B<delete(>I<index1>, I<index2>B<)>
  303.  
  304. Deletes items from I<index1> to I<index2>.
  305.  
  306. =back
  307.  
  308. =head1 BUGS
  309.  
  310. BrowseEntry should really provide more of the ComboBox options.
  311.  
  312. =head1 AUTHOR
  313.  
  314. B<Rajappa Iyer> rsi@earthling.net
  315.  
  316. This code was inspired by ComboBox.tcl in Tix4.0 by Ioi Lam and
  317. bears more than a passing resemblance to ComboBox code. This may
  318. be distributed under the same conditions as Perl.
  319.