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 / _0e1bcdb9c5253b8f2c550a18a7c1076e < prev    next >
Encoding:
Text File  |  2004-04-13  |  8.5 KB  |  354 lines
  1. #
  2. # BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
  3.  
  4. package Tk::BrowseEntry;
  5.  
  6. use vars qw($VERSION);
  7. $VERSION = '3.030'; # $Id: //depot/Tk8/Tixish/BrowseEntry.pm#30 $
  8.  
  9. use Tk qw(Ev);
  10. use Carp;
  11. use strict;
  12.  
  13. require Tk::Frame;
  14. require Tk::LabEntry;
  15.  
  16. use base qw(Tk::Frame);
  17. Construct Tk::Widget 'BrowseEntry';
  18.  
  19. sub Populate {
  20.     my ($w, $args) = @_;
  21.  
  22.     $w->SUPER::Populate($args);
  23.  
  24.     # entry widget and arrow button
  25.     my $lpack = delete $args->{-labelPack};
  26.     if (not defined $lpack) {
  27.     $lpack = [-side => 'left', -anchor => 'e'];
  28.     }
  29.     my $var = "";
  30.     my $e = $w->LabEntry(-labelPack => $lpack,
  31.              -label => delete $args->{-label},
  32.              -textvariable => \$var,);
  33.     my $b = $w->Button(-bitmap => '@' . Tk->findINC('cbxarrow.xbm'));
  34.     $w->Advertise('entry' => $e);
  35.     $w->Advertise('arrow' => $b);
  36.     $b->pack(-side => 'right', -padx => 1);
  37.     $e->pack(-side => 'right', -fill => 'x', -expand => 1, -padx => 1);
  38.  
  39.     # popup shell for listbox with values.
  40.     my $c = $w->Toplevel(-bd => 2, -relief => 'raised');
  41.     $c->overrideredirect(1);
  42.     $c->withdraw;
  43.     my $sl = $c->Scrolled( qw/Listbox -selectmode browse -scrollbars oe/ );
  44.     $w->Advertise('choices' => $c);
  45.     $w->Advertise('slistbox' => $sl);
  46.     $sl->pack(-expand => 1, -fill => 'both');
  47.  
  48.     # other initializations
  49.     $w->SetBindings;
  50.     $w->{'popped'} = 0;
  51.     $w->Delegates('insert' => $sl, 'delete' => $sl, get => $sl, DEFAULT => $e);
  52.     $w->ConfigSpecs(
  53.         -listwidth   => [qw/PASSIVE  listWidth   ListWidth/,   undef],
  54.         -listcmd     => [qw/CALLBACK listCmd     ListCmd/,     undef],
  55.         -browsecmd   => [qw/CALLBACK browseCmd   BrowseCmd/,   undef],
  56.         -choices     => [qw/METHOD   choices     Choices/,     undef],
  57.         -state       => [qw/METHOD   state       State         normal/],
  58.         -arrowimage  => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
  59.         -variable    => '-textvariable',
  60.     -colorstate  => [qw/PASSIVE  colorState  ColorState/,  undef],
  61.         -command     => '-browsecmd',
  62.         -options     => '-choices',
  63.         DEFAULT      => [$e] );
  64. }
  65.  
  66. sub SetBindings {
  67.     my ($w) = @_;
  68.  
  69.     my $e = $w->Subwidget('entry');
  70.     my $b = $w->Subwidget('arrow');
  71.  
  72.     # set bind tags
  73.     $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']);
  74.     $e->bindtags([$e, $e->toplevel, 'all']);
  75.  
  76.     # bindings for the button and entry
  77.     $b->bind('<1>',[$w,'BtnDown']);
  78.     $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']);
  79.     $b->bind('<space>',[$w,'space']);
  80.  
  81.     # bindings for listbox
  82.     my $sl = $w->Subwidget('slistbox');
  83.     my $l = $sl->Subwidget('listbox');
  84.     $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
  85.     $l->bind('<Escape>' => [$w,'LbClose']);
  86.     $l->bind('<Return>' => [$w,'Return',$l]);
  87.  
  88.     # allow click outside the popped up listbox to pop it down.
  89.     $w->bind('<1>','BtnDown');
  90. }
  91.  
  92. sub space
  93. {
  94.  my $w = shift;
  95.  $w->BtnDown;
  96.  $w->{'savefocus'} = $w->focusCurrent;
  97.  $w->Subwidget('slistbox')->focus;
  98. }
  99.  
  100.  
  101. sub ListboxRelease
  102. {
  103.  my ($w,$x,$y) = @_;
  104.  $w->ButtonHack;
  105.  $w->LbChoose($x, $y);
  106. }
  107.  
  108. sub Return
  109. {
  110.  my ($w,$l) = @_;
  111.  my($x, $y) = $l->bbox($l->curselection);
  112.  $w->LbChoose($x, $y)
  113. }
  114.  
  115.  
  116. sub BtnDown {
  117.     my ($w) = @_;
  118.     return if $w->cget( '-state' ) eq 'disabled';
  119.  
  120.     if ($w->{'popped'}) {
  121.     $w->Popdown;
  122.     $w->{'buttonHack'} = 0;
  123.     } else {
  124.     $w->PopupChoices;
  125.     $w->{'buttonHack'} = 1;
  126.     }
  127. }
  128.  
  129. sub PopupChoices {
  130.     my ($w) = @_;
  131.  
  132.     if (!$w->{'popped'}) {
  133.        $w->Callback(-listcmd => $w);
  134.     my $e = $w->Subwidget('entry');
  135.     my $c = $w->Subwidget('choices');
  136.     my $s = $w->Subwidget('slistbox');
  137.     my $a = $w->Subwidget('arrow');
  138.     my $y1 = $e->rooty + $e->height + 3;
  139.     my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
  140.     my $ht = $s->reqheight + 2 * $bd;
  141.     my $x1 = $e->rootx;
  142.     my ($width, $x2);
  143.     if (defined $w->cget(-listwidth)) {
  144.         $width = $w->cget(-listwidth);
  145.         $x2 = $x1 + $width;
  146.     } else {
  147.         $x2 = $a->rootx + $a->width;
  148.         $width = $x2 - $x1;
  149.     }
  150.     my $rw = $c->reqwidth;
  151.     if ($rw < $width) {
  152.         $rw = $width
  153.     } else {
  154.         if ($rw > $width * 3) {
  155.         $rw = $width * 3;
  156.         }
  157.         if ($rw > $w->vrootwidth) {
  158.         $rw = $w->vrootwidth;
  159.         }
  160.     }
  161.     $width = $rw;
  162.  
  163.     # if listbox is too far right, pull it back to the left
  164.     #
  165.     if ($x2 > $w->vrootwidth) {
  166.         $x1 = $w->vrootwidth - $width;
  167.     }
  168.  
  169.     # if listbox is too far left, pull it back to the right
  170.     #
  171.     if ($x1 < 0) {
  172.         $x1 = 0;
  173.     }
  174.  
  175.     # if listbox is below bottom of screen, pull it up.
  176.     my $y2 = $y1 + $ht;
  177.     if ($y2 > $w->vrootheight) {
  178.         $y1 = $y1 - $ht - ($e->height - 5);
  179.     }
  180.  
  181.     $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
  182.     $c->deiconify;
  183.     $c->raise;
  184.     $e->focus;
  185.     $w->{'popped'} = 1;
  186.  
  187.     $c->configure(-cursor => 'arrow');
  188.     $w->grabGlobal;
  189.     }
  190. }
  191.  
  192. # choose value from listbox if appropriate
  193. sub LbChoose {
  194.     my ($w, $x, $y) = @_;
  195.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  196.     if ((($x < 0) || ($x > $l->Width)) ||
  197.     (($y < 0) || ($y > $l->Height))) {
  198.     # mouse was clicked outside the listbox... close the listbox
  199.     $w->LbClose;
  200.     } else {
  201.     # select appropriate entry and close the listbox
  202.     $w->LbCopySelection;
  203.        $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get);
  204.     }
  205. }
  206.  
  207. # close the listbox after clearing selection
  208. sub LbClose {
  209.     my ($w) = @_;
  210.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  211.     $l->selection('clear', 0, 'end');
  212.     $w->Popdown;
  213. }
  214.  
  215. # copy the selection to the entry and close listbox
  216. sub LbCopySelection {
  217.     my ($w) = @_;
  218.     my $index = $w->LbIndex;
  219.     if (defined $index) {
  220.     $w->{'curIndex'} = $index;
  221.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  222.         my $var_ref = $w->cget( '-textvariable' );
  223.         $$var_ref = $l->get($index);
  224.     if ($w->{'popped'}) {
  225.         $w->Popdown;
  226.     }
  227.     }
  228.     $w->Popdown;
  229. }
  230.  
  231. sub LbIndex {
  232.     my ($w, $flag) = @_;
  233.     my $sel = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
  234.     if (defined $sel) {
  235.     return int($sel);
  236.     } else {
  237.     if (defined $flag && ($flag eq 'emptyOK')) {
  238.         return undef;
  239.     } else {
  240.         return 0;
  241.     }
  242.     }
  243. }
  244.  
  245. # pop down the listbox
  246. sub Popdown {
  247.     my ($w) = @_;
  248.     if ($w->{'savefocus'} && Tk::Exists($w->{'savefocus'})) {
  249.     $w->{'savefocus'}->focus;
  250.     delete $w->{'savefocus'};
  251.     }
  252.     if ($w->{'popped'}) {
  253.     my $c = $w->Subwidget('choices');
  254.     $c->withdraw;
  255.     $w->grabRelease;
  256.     $w->{'popped'} = 0;
  257.     }
  258. }
  259.  
  260. # This hack is to prevent the ugliness of the arrow being depressed.
  261. #
  262. sub ButtonHack {
  263.     my ($w) = @_;
  264.     my $b = $w->Subwidget('arrow');
  265.     if ($w->{'buttonHack'}) {
  266.     $b->butUp;
  267.     }
  268. }
  269.  
  270. sub choices
  271. {
  272.  my ($w,$choices) = @_;
  273.  if (@_ > 1)
  274.   {
  275.    $w->delete( qw/0 end/ );
  276.    my %hash;
  277.    my $var = $w->cget('-textvariable');
  278.    my $old = $$var;
  279.    foreach my $val (@$choices)
  280.     {
  281.      $w->insert( 'end', $val);
  282.      $hash{$val} = 1;
  283.     }
  284.    $old = (@$choices) ? $choices->[0] : undef unless exists $hash{$old};
  285.    $$var = $old;
  286.   }
  287.  else
  288.   {
  289.    return( $w->get( qw/0 end/ ) );
  290.   }
  291. }
  292.  
  293. sub _set_edit_state {
  294.     my( $w, $state ) = @_;
  295.  
  296.     my $entry  = $w->Subwidget( 'entry' );
  297.     my $button = $w->Subwidget( 'arrow' );
  298.  
  299.     if ($w->cget( '-colorstate' )) {
  300.     my $color;
  301.     if( $state eq 'normal' ) {                  # Editable
  302.         $color = 'gray95';
  303.     } else {                                    # Not Editable
  304.         $color = $w->cget( -background ) || 'lightgray';
  305.     }
  306.     $entry->Subwidget( 'entry' )->configure( -background => $color );
  307.     }
  308.  
  309.     if( $state eq 'readonly' ) {
  310.         $entry->configure( -state => 'disabled' );
  311.         $button->configure( -state => 'normal' );
  312.     } else {
  313.         $entry->configure( -state => $state );
  314.         $button->configure( -state => $state );
  315.     }
  316. }
  317.  
  318. sub state {
  319.     my $w = shift;
  320.     unless( @_ ) {
  321.         return( $w->{Configure}{-state} );
  322.     } else {
  323.         my $state = shift;
  324.         $w->{Configure}{-state} = $state;
  325.         $w->_set_edit_state( $state );
  326.     }
  327. }
  328.  
  329. sub _max {
  330.     my $max = shift;
  331.     foreach my $val (@_) {
  332.         $max = $val if $max < $val;
  333.     }
  334.     return( $max );
  335. }
  336.  
  337. sub shrinkwrap {
  338.     my( $w, $size ) = @_;
  339.  
  340.     unless( defined $size ) {
  341.         $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
  342.     }
  343.  
  344.     my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
  345.     $w->configure(  -width => $size );
  346.     $lb->configure( -width => $size );
  347. }
  348.  
  349.  
  350. 1;
  351.  
  352. __END__
  353.  
  354.