home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / BrowseEntry.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-21  |  13.0 KB  |  510 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: #12 $ =~ /\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.         -listwidth   => [qw/PASSIVE  listWidth   ListWidth/,   undef],
  100.         -listheight  => [{-height => $sl}, qw/listHeight ListHeight/, undef],
  101.         -listcmd     => [qw/CALLBACK listCmd     ListCmd/,     undef],
  102.         -autolistwidth   => [qw/PASSIVE autoListWidth AutoListWidth/, undef],
  103.         -autolimitheight => [qw/PASSIVE autoLimitHeight AutoLimitHeight 0/],
  104.         -browsecmd   => [qw/CALLBACK browseCmd   BrowseCmd/,   undef],
  105.     -browse2cmd  => [qw/CALLBACK browse2Cmd  Browse2Cmd/,  undef],
  106.         -choices     => [qw/METHOD   choices     Choices/,     undef],
  107.         -state       => [qw/METHOD   state       State         normal/],
  108.         -arrowimage  => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
  109.         -variable    => [ {'-textvariable' => $e} ],
  110.     -colorstate  => [qw/PASSIVE  colorState  ColorState/,  undef],
  111.         -command     => '-browsecmd',
  112.         -options     => '-choices',
  113.     -label       => [qw/PASSIVE  label       Label/,       undef],
  114.     -labelPack   => [qw/PASSIVE  labelPack   LabelPack/,   undef],
  115.             #-background  => [$e, qw/background Background/,   undef],
  116.             #-foreground  => [$e, qw/foreground Foreground/,   undef],
  117.     -buttontakefocus => [{-takefocus => $b}, 'buttonTakefocus',
  118.                  'ButtonTakefocus', 1],
  119.         DEFAULT      => [$e] );
  120. }
  121.  
  122. sub SetBindings {
  123.     my ($w) = @_;
  124.  
  125.     my $e = $w->Subwidget('entry');
  126.     my $b = $w->Subwidget('arrow');
  127.  
  128.     # set bind tags
  129.     $w->bindtags([$w, 'Tk::BrowseEntry', $w->toplevel, 'all']);
  130.     # as we don't bind $e here leave its tags alone ...
  131.     # $e->bindtags([$e, ref($e), $e->toplevel, 'all']);
  132.  
  133.     # bindings for the button and entry
  134.     $b->bind('<1>',[$w,'BtnDown']);
  135.     $b->toplevel->bind('<ButtonRelease-1>',[$w,'ButtonHack']);
  136.     $b->bind('<space>',[$w,'space']);
  137.  
  138.     # bindings for listbox
  139.     my $sl = $w->Subwidget('slistbox');
  140.     my $l = $sl->Subwidget('listbox');
  141.     $l->bind('<ButtonRelease-1>',[$w,'ListboxRelease',Ev('x'),Ev('y')]);
  142.     $l->bind('<Escape>' => [$w,'LbClose']);
  143.     $l->bind('<Return>' => [$w,'Return',$l]);
  144.  
  145.     # allow click outside the popped up listbox to pop it down.
  146.     $w->bind('<1>','BtnDown');
  147. }
  148.  
  149. sub space
  150. {
  151.  my $w = shift;
  152.  $w->BtnDown;
  153.  $w->{'_BE_savefocus'} = $w->focusCurrent;
  154.  $w->Subwidget('slistbox')->focus;
  155. }
  156.  
  157.  
  158. sub ListboxRelease
  159. {
  160.  my ($w,$x,$y) = @_;
  161.  $w->ButtonHack;
  162.  $w->LbChoose($x, $y);
  163. }
  164.  
  165. sub Return
  166. {
  167.  my ($w,$l) = @_;
  168.  my($x, $y) = $l->bbox($l->curselection);
  169.  $w->LbChoose($x, $y)
  170. }
  171.  
  172.  
  173. sub BtnDown {
  174.     my ($w) = @_;
  175.     return if $w->cget( '-state' ) eq 'disabled';
  176.  
  177.     if ($w->{'_BE_popped'}) {
  178.     $w->Popdown;
  179.     $w->{'_BE_buttonHack'} = 0;
  180.     } else {
  181.     $w->PopupChoices;
  182.     $w->{'_BE_buttonHack'} = 1;
  183.     }
  184. }
  185.  
  186. sub PopupChoices {
  187.     my ($w) = @_;
  188.  
  189.     if (!$w->{'_BE_popped'}) {
  190.     $w->Callback(-listcmd => $w);
  191.     my $e = $w->Subwidget('entry');
  192.     my $c = $w->Subwidget('choices');
  193.     my $s = $w->Subwidget('slistbox');
  194.     my $a = $w->Subwidget('arrow');
  195.     my $y1 = ($w->{_BE_Style} eq 'MSWin32'
  196.           ? $a->rooty + $a->height
  197.           : $e->rooty + $e->height + 3
  198.          );
  199.     my $bd = $c->cget(-bd) + $c->cget(-highlightthickness);
  200.     # using the real listbox reqheight rather than the
  201.     # container frame one, which does not change after resizing the
  202.     # listbox
  203.     my $ht = $s->Subwidget("scrolled")->reqheight + 2 * $bd;
  204.     my $x1 = ($w->{_BE_Style} eq 'MSWin32'
  205.           ? $e->Subwidget("entry")->rootx
  206.           : $e->rootx
  207.          );
  208.     my ($width, $x2);
  209.     if (defined $w->cget(-listwidth)) {
  210.         $width = $w->cget(-listwidth);
  211.         $x2 = $x1 + $width;
  212.     } else {
  213.         $x2 = $a->rootx + $a->width;
  214.         $width = $x2 - $x1;
  215.     }
  216.         my $rw = $c->reqwidth;
  217.         if ($rw < $width) {
  218.             $rw = $width
  219.         } else {
  220.             if ($rw > $width * 3) {
  221.             $rw = $width * 3;
  222.             }
  223.             if ($rw > $w->vrootwidth) {
  224.             $rw = $w->vrootwidth;
  225.             }
  226.         }
  227.         $width = $rw;
  228.  
  229.     # if listbox is too far right, pull it back to the left
  230.     #
  231.     if ($x2 > $w->vrootwidth) {
  232.         $x1 = $w->vrootwidth - $width;
  233.     }
  234.  
  235.     # if listbox is too far left, pull it back to the right
  236.     #
  237.     if ($x1 < 0) {
  238.         $x1 = 0;
  239.     }
  240.  
  241.     # if listbox is below bottom of screen, pull it up.
  242.     # check the Win32 taskbar, if possible
  243.     my $rootheight;
  244.     if ($Tk::platform eq 'MSWin32' and $^O eq 'MSWin32') {
  245.         eval {
  246.         require Win32Util; # XXX should not use a non-CPAN widget
  247.         $rootheight = (Win32Util::screen_region($w))[3];
  248.         };
  249.     }
  250.     if (!defined $rootheight) {
  251.         $rootheight = $w->vrootheight;
  252.     }
  253.  
  254.     my $y2 = $y1 + $ht;
  255.     if ($y2 > $rootheight) {
  256.         $y1 = $y1 - $ht - ($e->height - 5);
  257.     }
  258.     $c->geometry(sprintf('%dx%d+%d+%d', $rw, $ht, $x1, $y1));
  259.     $c->deiconify;
  260.     $c->raise;
  261.     $e->focus;
  262.     $w->{'_BE_popped'} = 1;
  263.  
  264.     # highlight current selection
  265.     my $current_sel = $e->get;
  266.     if (defined $current_sel) {
  267.         my $i = 0;
  268.         foreach my $str ($s->get(0, "end")) {
  269.         if ($str eq $current_sel) {
  270.             $s->selectionClear(0, "end");
  271.             $s->selectionSet($i);
  272.             last;
  273.         }
  274.         $i++;
  275.         }
  276.     }
  277.  
  278.     $c->configure(-cursor => 'arrow');
  279.     $w->{'_BE_grabinfo'} = $w->grabSave;
  280.     $w->grabGlobal;
  281.     }
  282. }
  283.  
  284. # choose value from listbox if appropriate
  285. sub LbChoose {
  286.     my ($w, $x, $y) = @_;
  287.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  288.     if ((($x < 0) || ($x > $l->Width)) ||
  289.         (($y < 0) || ($y > $l->Height))) {
  290.         # mouse was clicked outside the listbox... close the listbox
  291.         $w->LbClose;
  292.     } else {
  293.         # select appropriate entry and close the listbox
  294.         $w->LbCopySelection;
  295.     $w->Callback(-browsecmd, $w, $w->Subwidget('entry')->get());
  296.     $w->Callback(-browse2cmd => $w, $w->LbIndex);
  297.     }
  298. }
  299.  
  300. # close the listbox after clearing selection
  301. sub LbClose {
  302.     my ($w) = @_;
  303.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  304.     $l->selection('clear', 0, 'end');
  305.     $w->Popdown;
  306. }
  307.  
  308. # copy the selection to the entry and close listbox
  309. sub LbCopySelection {
  310.     my ($w) = @_;
  311.     my $index = $w->LbIndex;
  312.     if (defined $index) {
  313.     $w->{'_BE_curIndex'} = $index;
  314.     my $l = $w->Subwidget('slistbox')->Subwidget('listbox');
  315.         my $var_ref = $w->cget( '-textvariable' );
  316.         $$var_ref = $l->get($index);
  317.     if ($w->{'_BE_popped'}) {
  318.         $w->Popdown;
  319.     }
  320.     }
  321.     $w->Popdown;
  322. }
  323.  
  324. sub LbIndex {
  325.     my ($w, $flag) = @_;
  326.     my ($sel) = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection;
  327.     if (defined $sel) {
  328.     return int($sel);
  329.     } else {
  330.     if (defined $flag && ($flag eq 'emptyOK')) {
  331.         return undef;
  332.     } else {
  333.         return 0;
  334.     }
  335.     }
  336. }
  337.  
  338. # pop down the listbox
  339. sub Popdown {
  340.     my ($w) = @_;
  341.     if ($w->{'_BE_savefocus'} && Tk::Exists($w->{'_BE_savefocus'})) {
  342.     $w->{'_BE_savefocus'}->focus;
  343.     delete $w->{'_BE_savefocus'};
  344.     }
  345.     if ($w->{'_BE_popped'}) {
  346.     my $c = $w->Subwidget('choices');
  347.     $c->withdraw;
  348.     $w->grabRelease;
  349.     if (ref $w->{'_BE_grabinfo'} eq 'CODE') {
  350.         $w->{'_BE_grabinfo'}->();
  351.         delete $w->{'_BE_grabinfo'};
  352.     }
  353.     $w->{'_BE_popped'} = 0;
  354.     }
  355. }
  356.  
  357. # This hack is to prevent the ugliness of the arrow being depressed.
  358. #
  359. sub ButtonHack {
  360.     my ($w) = @_;
  361.     my $b = $w->Subwidget('arrow');
  362.     if ($w->{'_BE_buttonHack'}) {
  363.     $b->butUp;
  364.     }
  365. }
  366.  
  367. sub choices
  368. {
  369.  my ($w,$choices) = @_;
  370.  if (@_ > 1)
  371.   {
  372.    $w->delete( qw/0 end/ );
  373.    my %hash;
  374.    my $var = $w->cget('-textvariable');
  375.    my $old = $$var;
  376.    foreach my $val (@$choices)
  377.     {
  378.      $w->insert( 'end', $val);
  379.      $hash{$val} = 1;
  380.     }
  381.    $old = $choices->[0]
  382.     if defined $old && not exists $hash{$old} && defined $choices->[0];
  383.    $$var = $old;
  384.   }
  385.  else
  386.   {
  387.    return( $w->get( qw/0 end/ ) );
  388.   }
  389. }
  390.  
  391. sub _set_edit_state {
  392.     my( $w, $state ) = @_;
  393.  
  394.     my $entry  = $w->Subwidget( 'entry' );
  395.     my $button = $w->Subwidget( 'arrow' );
  396.  
  397.     if ($w->cget( '-colorstate' )) {
  398.     my $color;
  399.     if( $state eq 'normal' ) {                  # Editable
  400.         $color = 'gray95';
  401.     } else {                                    # Not Editable
  402.         $color = $w->cget( -background ) || 'lightgray';
  403.     }
  404.     $entry->Subwidget( 'entry' )->configure( -background => $color );
  405.     }
  406.  
  407.     if( $state eq 'readonly' ) {
  408.         $entry->configure( -state => 'disabled' );
  409.         $button->configure( -state => 'normal' );
  410.     if ($w->{_BE_Style} eq 'MSWin32') {
  411.         $entry->bind('<1>',[$w,'BtnDown']);
  412.         $w->{_BE_OriginalCursor} = $entry->cget( -cursor );
  413.         $entry->configure( -cursor => 'left_ptr' );
  414.     }
  415.     } else {
  416.         $entry->configure( -state => $state );
  417.     if (exists $w->{_BE_OriginalCursor}) {
  418.         $entry->configure(-cursor => delete $w->{_BE_OriginalCursor});
  419.     }
  420.         $button->configure( -state => $state );
  421.     if ($w->{_BE_Style} eq 'MSWin32') {
  422.         $entry->bind('<1>',['Button1',Tk::Ev('x')]);
  423.     }
  424.     }
  425. }
  426.  
  427. sub state {
  428.     my $w = shift;
  429.     unless( @_ ) {
  430.         return( $w->{Configure}{-state} );
  431.     } else {
  432.         my $state = shift;
  433.         $w->{Configure}{-state} = $state;
  434.         $w->_set_edit_state( $state );
  435.     }
  436. }
  437.  
  438. sub _max {
  439.     my $max = shift;
  440.     foreach my $val (@_) {
  441.         $max = $val if $max < $val;
  442.     }
  443.     return( $max );
  444. }
  445.  
  446. sub shrinkwrap {
  447.     my( $w, $size ) = @_;
  448.  
  449.     unless( defined $size ) {
  450.         $size = _max( map( length, $w->get( qw/0 end/ ) ) ) || 0;;
  451.     }
  452.  
  453.     my $lb = $w->Subwidget( 'slistbox' )->Subwidget( 'listbox' );
  454.     $w->configure(  -width => $size );
  455.     $lb->configure( -width => $size );
  456. }
  457.  
  458. sub limitheight {
  459.     my $w = shift;
  460.     my $choices_number = shift || $w->Subwidget('slistbox')->index("end");
  461.     $choices_number = 10 if $choices_number > 10;
  462.     $w->configure(-listheight => $choices_number) if ($choices_number > 0);
  463. }
  464.  
  465. sub insert {
  466.     my $w = shift;
  467.     $w->Subwidget("slistbox")->insert(@_);
  468.     if ($w->cget(-autolimitheight)) {
  469.     $w->limitheight;
  470.     }
  471.     if ($w->cget(-autolistwidth)) {
  472.     $w->updateListWidth(@_[1..$#_]);
  473.     }
  474. }
  475.  
  476. sub delete {
  477.     my $w = shift;
  478.     $w->Subwidget("slistbox")->delete(@_);
  479.     if ($w->cget(-autolimitheight)) {
  480.     $w->limitheight;
  481.     }
  482.     if ($w->cget(-autolistwidth)) {
  483.     $w->updateListWidth();
  484.     }
  485. }
  486.  
  487. sub updateListWidth {
  488.     my $w = shift;
  489.     my @ins = @_;
  490.     if (!@ins) {
  491.     @ins = $w->get(0, "end");
  492.     }
  493.  
  494.     my $max_width = 0;
  495.     foreach my $ins (@ins) {
  496.     my $new_width = $w->fontMeasure($w->cget(-font), $ins);
  497.     if ($new_width > $max_width) {
  498.         $max_width = $new_width;
  499.     }
  500.     }
  501.     if ($max_width > 20) { # be sane
  502.     $w->configure(-listwidth => $max_width + 32); # XXX for scrollbar
  503.     }
  504. }
  505.  
  506. 1;
  507.  
  508. __END__
  509.  
  510.