home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _0e1bcdb9c5253b8f2c550a18a7c1076e < prev    next >
Text File  |  2004-06-01  |  14KB  |  511 lines
  1. #
  2. # BrowseEntry is a stripped down version of ComboBox.tcl from Tix4.0
  3. #
  4. # Some additions by Slaven Rezic <slaven@rezic.de> to make the widget
  5. # look like the Windows' Combobox. There are also additional options.
  6. #
  7.  
  8. package Tk::BrowseEntry;
  9.  
  10. use vars qw($VERSION);
  11. $VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/;
  12.  
  13. use Tk qw(Ev);
  14. use Carp;
  15. use strict;
  16.  
  17. use base qw(Tk::Frame);
  18. Construct Tk::Widget 'BrowseEntry';
  19.  
  20. require Tk::LabEntry;
  21.  
  22. sub LabEntryWidget { "LabEntry" }
  23. sub ButtonWidget   { "Button"   }
  24. sub ListboxWidget  { "Listbox"  }
  25.  
  26. sub Populate {
  27.     my ($w, $args) = @_;
  28.  
  29.     $w->Tk::Frame::Populate($args);
  30.  
  31.     # entry widget and arrow button
  32.     my $lpack = delete $args->{-labelPack};
  33.     if (not defined $lpack) {
  34.     $lpack = [-side => 'left', -anchor => 'e'];
  35.     }
  36.     $w->{_BE_Style} = delete $args->{-style} || $Tk::platform;
  37.     my $LabEntry = $w->LabEntryWidget;
  38.     my $Listbox  = $w->ListboxWidget;
  39.     my $Button   = $w->ButtonWidget;
  40.     # XXX should this be retained?
  41. #      if (defined $args->{-state} and $args->{-state} eq 'readonly') { # XXX works only at construction time
  42. #      $LabEntry = "NoSelLabEntry";
  43. #      require Tk::NoSelLabEntry;
  44. #      }
  45.     my $e;
  46.     my $var = "";
  47.     my @LabEntry_args = (-textvariable => \$var);
  48.     if (exists $args->{-label}) {
  49.     $e = $w->$LabEntry(-labelPack => $lpack,
  50.                -label => delete $args->{-label},
  51.                @LabEntry_args,
  52.               );
  53.     } else {
  54.     $e = $w->$LabEntry(@LabEntry_args);
  55.     }
  56.     my $b = $w->$Button(-bitmap => '@' . Tk->findINC($w->{_BE_Style} eq 'MSWin32' ? 'arrowdownwin.xbm' : 'cbxarrow.xbm'));
  57.     $w->Advertise('entry' => $e);
  58.     $w->Advertise('arrow' => $b);
  59.  
  60.     # Pack the button to align vertically with the entry widget
  61.     my @anch;
  62.     my $edge = {@$lpack}->{-side};
  63.     push(@anch,-anchor => 's') if ($edge && $edge eq 'top');
  64.     push(@anch,-anchor => 'n') if ($edge && $edge eq 'bottom');
  65.     $b->pack(-side => 'right', -padx => 1, @anch);
  66.  
  67.     $e->pack(-side => 'right', -fill => 'x', -expand => 1); #XXX, -padx => 1);
  68.  
  69.     # popup shell for listbox with values.
  70.     my $c = $w->Toplevel(-bd => 2,
  71.              -relief => ($w->{_BE_Style} eq 'MSWin32'
  72.                      ? "solid" : "raised"));
  73.     $c->overrideredirect(1);
  74.     $c->withdraw;
  75.     my $sl = $c->Scrolled( $Listbox, qw/-selectmode browse -scrollbars oe/ );
  76.     if ($w->{_BE_Style} eq 'MSWin32' and $Tk::platform eq 'MSWin32') {
  77.     $sl->configure(-bg => 'SystemWindow', -relief => "flat");
  78.     }
  79.     $w->Advertise('choices' => $c);
  80.     $w->Advertise('slistbox' => $sl);
  81.     $sl->pack(-expand => 1, -fill => 'both');
  82.  
  83.     $sl->Subwidget("scrolled")->bind("<Motion>",sub {
  84.     return unless ($w->{_BE_Style} eq 'MSWin32');
  85.     my $e = $_[0]->XEvent;
  86.     my $y = $e->y;
  87.     my $inx = $sl->nearest($y);
  88.     if (defined $inx) {
  89.         $sl->selectionClear(0, "end");
  90.         $sl->selectionSet($inx);
  91.     }
  92.    });
  93.  
  94.     # other initializations
  95.     $w->SetBindings;
  96.     $w->{'_BE_popped'} = 0;
  97.     $w->Delegates(get => $sl, DEFAULT => $e);
  98.     $w->ConfigSpecs(
  99.         -font        => [qw/DESCENDANTS font Font/],
  100.         -listwidth   => [qw/PASSIVE  listWidth   ListWidth/,   undef],
  101.         -listheight  => [{-height => $sl}, qw/listHeight ListHeight/, undef],
  102.         -listcmd     => [qw/CALLBACK listCmd     ListCmd/,     undef],
  103.         -autolistwidth   => [qw/PASSIVE autoListWidth AutoListWidth/, undef],
  104.         -autolimitheight => [qw/PASSIVE autoLimitHeight AutoLimitHeight 0/],
  105.         -browsecmd   => [qw/CALLBACK browseCmd   BrowseCmd/,   undef],
  106.     -browse2cmd  => [qw/CALLBACK browse2Cmd  Browse2Cmd/,  undef],
  107.         -choices     => [qw/METHOD   choices     Choices/,     undef],
  108.         -state       => [qw/METHOD   state       State         normal/],
  109.         -arrowimage  => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
  110.         -variable    => [ {'-textvariable' => $e} ],
  111.     -colorstate  => [qw/PASSIVE  colorState  ColorState/,  undef],
  112.         -command     => '-browsecmd',
  113.         -options     => '-choices',
  114.     -label       => [qw/PASSIVE  label       Label/,       undef],
  115.     -labelPack   => [qw/PASSIVE  labelPack   LabelPack/,   undef],
  116.             #-background  => [$e, qw/background Background/,   undef],
  117.             #-foreground  => [$e, qw/foreground Foreground/,   undef],
  118.     -buttontakefocus => [{-takefocus => $b}, 'buttonTakefocus',
  119.                  'ButtonTakefocus', 1],
  120.         DEFAULT      => [$e] );
  121. }
  122.  
  123. sub SetBindings {
  124.     my ($w) = @_;
  125.  
  126.     my $e = $w->Subwidget('entry');
  127.     my $b = $w->Subwidget('arrow');
  128.  
  129.     # set bind tags
  130.     $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']);
  131.     # as we don't bind $e here leave its tags alone ...
  132.     # $e->bindtags([$e, ref($e), $e->toplevel, 'all']);
  133.  
  134.     # bindings for the button and entry
  135.     $b->bind('<1>',[$w,'BtnDown']);
  136.     $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']);
  137.     $b->bind('<space>',[$w,'space']);
  138.  
  139.     # bindings for listbox
  140.     my $sl = $w->Subwidget('slistbox');
  141.     my $l = $sl->Subwidget('listbox');
  142.     $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
  143.     $l->bind('<Escape>' => [$w,'LbClose']);
  144.     $l->bind('<Return>' => [$w,'Return',$l]);
  145.  
  146.     # allow click outside the popped up listbox to pop it down.
  147.     $w->bind('<1>','BtnDown');
  148. }
  149.  
  150. sub space
  151. {
  152.  my $w = shift;
  153.  $w->BtnDown;
  154.  $w->{'_BE_savefocus'} = $w->focusCurrent;
  155.  $w->Subwidget('slistbox')->focus;
  156. }
  157.  
  158.  
  159. sub ListboxRelease
  160. {
  161.  my ($w,$x,$y) = @_;
  162.  $w->ButtonHack;
  163.  $w->LbChoose($x, $y);
  164. }
  165.  
  166. sub Return
  167. {
  168.  my ($w,$l) = @_;
  169.  my($x, $y) = $l->bbox($l->curselection);
  170.  $w->LbChoose($x, $y)
  171. }
  172.  
  173.  
  174. sub BtnDown {
  175.     my ($w) = @_;
  176.     return if $w->cget( '-state' ) eq 'disabled';
  177.  
  178.     if ($w->{'_BE_popped'}) {
  179.     $w->Popdown;
  180.     $w->{'_BE_buttonHack'} = 0;
  181.     } else {
  182.     $w->PopupChoices;
  183.     $w->{'_BE_buttonHack'} = 1;
  184.     }
  185. }
  186.  
  187. sub PopupChoices {
  188.     my ($w) = @_;
  189.  
  190.     if (!$w->{'_BE_popped'}) {
  191.     $w->Callback(-listcmd => $w);
  192.     my $e = $w->Subwidget('entry');
  193.     my $c = $w->Subwidget('choices');
  194.     my $s = $w->Subwidget('slistbox');
  195.     my $a = $w->Subwidget('arrow');
  196.     my $y1 = ($w->{_BE_Style} eq 'MSWin32'
  197.           ? $a->rooty + $a->height
  198.           : $e->rooty + $e->height + 3
  199.          );
  200.     my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
  201.     # using the real listbox reqheight rather than the
  202.     # container frame one, which does not change after resizing the
  203.     # listbox
  204.     my $ht = $s->Subwidget("scrolled")->reqheight + 2 * $bd;
  205.     my $x1 = ($w->{_BE_Style} eq 'MSWin32'
  206.           ? $e->Subwidget("entry")->rootx
  207.           : $e->rootx
  208.          );
  209.     my ($width, $x2);
  210.     if (defined $w->cget(-listwidth)) {
  211.         $width = $w->cget(-listwidth);
  212.         $x2 = $x1 + $width;
  213.     } else {
  214.         $x2 = $a->rootx + $a->width;
  215.         $width = $x2 - $x1;
  216.     }
  217.         my $rw = $c->reqwidth;
  218.         if ($rw < $width) {
  219.             $rw = $width
  220.         } else {
  221.             if ($rw > $width * 3) {
  222.             $rw = $width * 3;
  223.             }
  224.             if ($rw > $w->vrootwidth) {
  225.             $rw = $w->vrootwidth;
  226.             }
  227.         }
  228.         $width = $rw;
  229.  
  230.     # if listbox is too far right, pull it back to the left
  231.     #
  232.     if ($x2 > $w->vrootwidth) {
  233.         $x1 = $w->vrootwidth - $width;
  234.     }
  235.  
  236.     # if listbox is too far left, pull it back to the right
  237.     #
  238.     if ($x1 < 0) {
  239.         $x1 = 0;
  240.     }
  241.  
  242.     # if listbox is below bottom of screen, pull it up.
  243.     # check the Win32 taskbar, if possible
  244.     my $rootheight;
  245.     if ($Tk::platform eq 'MSWin32' and $^O eq 'MSWin32') {
  246.         eval {
  247.         require Win32Util; # XXX should not use a non-CPAN widget
  248.         $rootheight = (Win32Util::screen_region($w))[3];
  249.         };
  250.     }
  251.     if (!defined $rootheight) {
  252.         $rootheight = $w->vrootheight;
  253.     }
  254.  
  255.     my $y2 = $y1 + $ht;
  256.     if ($y2 > $rootheight) {
  257.         $y1 = $y1 - $ht - ($e->height - 5);
  258.     }
  259.     $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
  260.     $c->deiconify;
  261.     $c->raise;
  262.     $e->focus;
  263.     $w->{'_BE_popped'} = 1;
  264.  
  265.     # highlight current selection
  266.     my $current_sel = $e->get;
  267.     if (defined $current_sel) {
  268.         my $i = 0;
  269.         foreach my $str ($s->get(0, "end")) {
  270.         if ($str eq $current_sel) {
  271.             $s->selectionClear(0, "end");
  272.             $s->selectionSet($i);
  273.             last;
  274.         }
  275.         $i++;
  276.         }
  277.     }
  278.  
  279.     $c->configure(-cursor => 'arrow');
  280.     $w->{'_BE_grabinfo'} = $w->grabSave;
  281.     $w->grabGlobal;
  282.     }
  283. }
  284.  
  285. # choose value from listbox if appropriate
  286. sub LbChoose {
  287.     my ($w, $x, $y) = @_;
  288.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  289.     if ((($x < 0) || ($x > $l->Width)) ||
  290.         (($y < 0) || ($y > $l->Height))) {
  291.         # mouse was clicked outside the listbox... close the listbox
  292.         $w->LbClose;
  293.     } else {
  294.         # select appropriate entry and close the listbox
  295.         $w->LbCopySelection;
  296.     $w->Callback(-browsecmd, $w, $w->Subwidget('entry')->get());
  297.     $w->Callback(-browse2cmd => $w, $w->LbIndex);
  298.     }
  299. }
  300.  
  301. # close the listbox after clearing selection
  302. sub LbClose {
  303.     my ($w) = @_;
  304.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  305.     $l->selection('clear', 0, 'end');
  306.     $w->Popdown;
  307. }
  308.  
  309. # copy the selection to the entry and close listbox
  310. sub LbCopySelection {
  311.     my ($w) = @_;
  312.     my $index = $w->LbIndex;
  313.     if (defined $index) {
  314.     $w->{'_BE_curIndex'} = $index;
  315.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  316.         my $var_ref = $w->cget( '-textvariable' );
  317.         $$var_ref = $l->get($index);
  318.     if ($w->{'_BE_popped'}) {
  319.         $w->Popdown;
  320.     }
  321.     }
  322.     $w->Popdown;
  323. }
  324.  
  325. sub LbIndex {
  326.     my ($w, $flag) = @_;
  327.     my ($sel) = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
  328.     if (defined $sel) {
  329.     return int($sel);
  330.     } else {
  331.     if (defined $flag && ($flag eq 'emptyOK')) {
  332.         return undef;
  333.     } else {
  334.         return 0;
  335.     }
  336.     }
  337. }
  338.  
  339. # pop down the listbox
  340. sub Popdown {
  341.     my ($w) = @_;
  342.     if ($w->{'_BE_savefocus'} && Tk::Exists($w->{'_BE_savefocus'})) {
  343.     $w->{'_BE_savefocus'}->focus;
  344.     delete $w->{'_BE_savefocus'};
  345.     }
  346.     if ($w->{'_BE_popped'}) {
  347.     my $c = $w->Subwidget('choices');
  348.     $c->withdraw;
  349.     $w->grabRelease;
  350.     if (ref $w->{'_BE_grabinfo'} eq 'CODE') {
  351.         $w->{'_BE_grabinfo'}->();
  352.         delete $w->{'_BE_grabinfo'};
  353.     }
  354.     $w->{'_BE_popped'} = 0;
  355.     }
  356. }
  357.  
  358. # This hack is to prevent the ugliness of the arrow being depressed.
  359. #
  360. sub ButtonHack {
  361.     my ($w) = @_;
  362.     my $b = $w->Subwidget('arrow');
  363.     if ($w->{'_BE_buttonHack'}) {
  364.     $b->butUp;
  365.     }
  366. }
  367.  
  368. sub choices
  369. {
  370.  my ($w,$choices) = @_;
  371.  if (@_ > 1)
  372.   {
  373.    $w->delete( qw/0 end/ );
  374.    my %hash;
  375.    my $var = $w->cget('-textvariable');
  376.    my $old = $$var;
  377.    foreach my $val (@$choices)
  378.     {
  379.      $w->insert( 'end', $val);
  380.      $hash{$val} = 1;
  381.     }
  382.    $old = $choices->[0]
  383.     if defined $old && not exists $hash{$old} && defined $choices->[0];
  384.    $$var = $old;
  385.   }
  386.  else
  387.   {
  388.    return( $w->get( qw/0 end/ ) );
  389.   }
  390. }
  391.  
  392. sub _set_edit_state {
  393.     my( $w, $state ) = @_;
  394.  
  395.     my $entry  = $w->Subwidget( 'entry' );
  396.     my $button = $w->Subwidget( 'arrow' );
  397.  
  398.     if ($w->cget( '-colorstate' )) {
  399.     my $color;
  400.     if( $state eq 'normal' ) {                  # Editable
  401.         $color = 'gray95';
  402.     } else {                                    # Not Editable
  403.         $color = $w->cget( -background ) || 'lightgray';
  404.     }
  405.     $entry->Subwidget( 'entry' )->configure( -background => $color );
  406.     }
  407.  
  408.     if( $state eq 'readonly' ) {
  409.         $entry->configure( -state => 'disabled' );
  410.         $button->configure( -state => 'normal' );
  411.     if ($w->{_BE_Style} eq 'MSWin32') {
  412.         $entry->bind('<1>',[$w,'BtnDown']);
  413.         $w->{_BE_OriginalCursor} = $entry->cget( -cursor );
  414.         $entry->configure( -cursor => 'left_ptr' );
  415.     }
  416.     } else {
  417.         $entry->configure( -state => $state );
  418.     if (exists $w->{_BE_OriginalCursor}) {
  419.         $entry->configure(-cursor => delete $w->{_BE_OriginalCursor});
  420.     }
  421.         $button->configure( -state => $state );
  422.     if ($w->{_BE_Style} eq 'MSWin32') {
  423.         $entry->bind('<1>',['Button1',Tk::Ev('x')]);
  424.     }
  425.     }
  426. }
  427.  
  428. sub state {
  429.     my $w = shift;
  430.     unless( @_ ) {
  431.         return( $w->{Configure}{-state} );
  432.     } else {
  433.         my $state = shift;
  434.         $w->{Configure}{-state} = $state;
  435.         $w->_set_edit_state( $state );
  436.     }
  437. }
  438.  
  439. sub _max {
  440.     my $max = shift;
  441.     foreach my $val (@_) {
  442.         $max = $val if $max < $val;
  443.     }
  444.     return( $max );
  445. }
  446.  
  447. sub shrinkwrap {
  448.     my( $w, $size ) = @_;
  449.  
  450.     unless( defined $size ) {
  451.         $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
  452.     }
  453.  
  454.     my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
  455.     $w->configure(  -width => $size );
  456.     $lb->configure( -width => $size );
  457. }
  458.  
  459. sub limitheight {
  460.     my $w = shift;
  461.     my $choices_number = shift || $w->Subwidget('slistbox')->index("end");
  462.     $choices_number = 10 if $choices_number > 10;
  463.     $w->configure(-listheight => $choices_number) if ($choices_number > 0);
  464. }
  465.  
  466. sub insert {
  467.     my $w = shift;
  468.     $w->Subwidget("slistbox")->insert(@_);
  469.     if ($w->cget(-autolimitheight)) {
  470.     $w->limitheight;
  471.     }
  472.     if ($w->cget(-autolistwidth)) {
  473.     $w->updateListWidth(@_[1..$#_]);
  474.     }
  475. }
  476.  
  477. sub delete {
  478.     my $w = shift;
  479.     $w->Subwidget("slistbox")->delete(@_);
  480.     if ($w->cget(-autolimitheight)) {
  481.     $w->limitheight;
  482.     }
  483.     if ($w->cget(-autolistwidth)) {
  484.     $w->updateListWidth();
  485.     }
  486. }
  487.  
  488. sub updateListWidth {
  489.     my $w = shift;
  490.     my @ins = @_;
  491.     if (!@ins) {
  492.     @ins = $w->get(0, "end");
  493.     }
  494.  
  495.     my $max_width = 0;
  496.     foreach my $ins (@ins) {
  497.     my $new_width = $w->fontMeasure($w->cget(-font), $ins);
  498.     if ($new_width > $max_width) {
  499.         $max_width = $new_width;
  500.     }
  501.     }
  502.     if ($max_width > 20) { # be sane
  503.     $w->configure(-listwidth => $max_width + 32); # XXX for scrollbar
  504.     }
  505. }
  506.  
  507. 1;
  508.  
  509. __END__
  510.  
  511.