File Coverage

blib/lib/Tk/JBrowseEntry.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             #
2             # Tk::JBrowseEntry is an enhanced version of the Tk::BrowseEntry widget.
3            
4             =head1 NAME
5            
6             Tk::JBrowseEntry - Full-featured "Combo-box" (Text-entry combined with drop-down listbox)
7             derived from Tk::BrowseEntry with many additional features and options.
8            
9             =head1 SYNOPSIS
10            
11             use Tk;
12             use Tk::JBrowseEntry;
13            
14             my $mw = MainWindow->new;
15             my $var;
16            
17             my $widget = $mw->JBrowseEntry(
18             -label => 'Normal:',
19             -variable => \$var,
20             -state => 'normal',
21             -choices => [qw(pigs cows foxes goats)],
22             -width => 12
23             )->pack(
24             -side => 'top',
25             -pady => '10',
26             -anchor => 'w');
27            
28             MainLoop;
29            
30             =head1 DESCRIPTION
31            
32             Tk::JBrowseEntry is a derived widget from Tk::BrowseEntry, but adds numerous
33             features and options. Among them are hash lists (one set of values is displayed
34             for the user, but another is used as data), ability to disable either the text
35             entry widget or the listbox, ability to allow user to delete items from the list,
36             additional keyboard bindings, and much more.
37            
38             JBrowseEntry widgets allow one to specify a full combo-box, a "readonly"
39             box (text field allows user to type the 1st letter of an item to search for,
40             but user may only ultimately select one of the items in the list), or a
41             "textonly" version (drop-down list disabled), or a completely disabled
42             widget.
43            
44             This widget is similar to other combo-boxes, ie. JComboBox, but has good
45             keyboard bindings and allows for quick lookup/search within the listbox.
46             pressing in entry field displays the dropdown box with the
47             first entry most closly matching whatever's in the entry field highlighted.
48             Pressing or in the listbox
49             selects the highlighted entry and copies it to the text field and removes the
50             listbox. removes the listbox from view.
51             and arrows work the listbox as well as pressing a key, which will
52             move the highlight to the next item starting with that letter/number, etc.
53             and arrows pressed within the entry field circle through the
54             various list options as well (unless "-state" is set to 'textonly').
55             Set "-state" to "text" to disable the dropdown list, but allow and
56             to cycle among the choices. Setting "-state" to 'textonly' completely
57             hides the choices list from the user - he must type in his choice just like
58             a normal entry widget.
59            
60             One may also specify whether or not the button which activates the
61             dropdown list via the mouse can take focus or not (-btntakesfocus) or
62             whether the widget itself can take focus or is skipped in the focusing
63             order. The developer can also specify alternate bitmap images for the
64             button (-arrowimage and -farrowimage). The developer can also specify the
65             maximum length of the dropdown list such that if more than that number of
66             items is added, a vertical scrollbar is automatically added (-height).
67             A fixed width in characters (-width) can be specified, or the widget can be
68             allowed to resize itself to the width of the longest string in the list. The
69             listbox and text entry field are automatically kept to the same width.
70            
71             One can optionally specify a label (-label), similar to the "LabEntry" widget.
72             By default, the label appears packed to the left of the widget. The
73             positioning can be specified via the "-labelPack" option. For example, to
74             position the label above the widget, use "-labelPack => [-side => 'top']".
75            
76             =head1 EXAMPLES
77            
78             It is easiest to illustrate this widget's capabilities via examples:
79            
80             use Tk;
81             use Tk::JBrowseEntry;
82            
83             $MainWin = MainWindow->new;
84            
85             #SET UP SOME DEFAULT VALUES.
86            
87             $dbname1 = 'cows';
88             $dbname2 = 'foxes';
89             $dbname3 = 'goats';
90             $dbname5 = 'default';
91            
92             #HERE'S A NORMAL COMBO-BOX.
93            
94             $jb1 = $MainWin->JBrowseEntry(
95             -label => 'Normal:',
96             -variable => \$dbname1,
97             -state => 'normal',
98             -choices => [qw(pigs cows foxes goats)],
99             -width => 12);
100             $jb1->pack(
101             -side => 'top', -pady => '10', -anchor => 'w');
102            
103             #THIS ONE HAS THE DROPDOWN LIST DISABLED.
104            
105             $jb2 = $MainWin->JBrowseEntry(
106             -label => 'TextOnly:',
107             -variable => \$dbname2,
108             -state => 'text',
109             -choices => [qw(pigs cows foxes goats)],
110             -width => 12);
111             $jb2->pack(
112             -side => 'top', -pady => '10', -anchor => 'w');
113            
114             #THIS ONE'S "READONLY" (USER MUST PICK FROM THE LIST, TEXT BOX ALLOWS QUICK
115             #SEARCH.
116            
117             $jb3 = $MainWin->JBrowseEntry(
118             -label => 'ReadOnly:',
119             -variable => \$dbname3,
120             -choices => [qw(pigs cows foxes goats)],
121             -state => 'readonly',
122             -width => 12);
123             $jb3->pack(
124             -side => 'top', -pady => '10', -anchor => 'w');
125            
126             #THIS ONE'S COMPLETELY DISABLED!
127            
128             $jb4 = $MainWin->JBrowseEntry(
129             -label => 'Disabled:',
130             -variable => \$dbname3,
131             -state => 'disabled',
132             -choices => [qw(pigs cows foxes goats)],
133             -width => 12);
134             $jb4->pack(
135             -side => 'top', -pady => '10', -anchor => 'w');
136            
137             #HERE'S ONE WITH A SCROLLBAR (NOTE THE "-height" ATTRIBUTE).
138            
139             $jb5 = $MainWin->JBrowseEntry(
140             -label => 'Scrolled List:',
141             -width => 12,
142             -default => $dbname5,
143             -height => 4,
144             -variable => \$dbname5,
145             -browsecmd => sub {print "-browsecmd!\n";},
146             -listcmd => sub {print "-listcmd!\n";},
147             -state => 'normal',
148             -choices => [qw(pigs cows foxes goats horses sheep dogs cats ardvarks default)]);
149             $jb5->pack(
150             -side => 'top', -pady => '10', -anchor => 'w');
151            
152             #HERE'S ONE THAT THE BUTTON TAKES KEYBOARD FOCUS.
153            
154             $jb6 = $MainWin->JBrowseEntry(
155             -label => 'Button Focus:',
156             -btntakesfocus => 1,
157             -arrowimage => $MainWin->Getimage('balArrow'), #SPECIFY A DIFFERENT BUTTON IMAGE.
158             -farrowimage => $MainWin->Getimage('cbxarrow'), #OPTIONAL 2ND IMAGE FOR BUTTON WHEN FOCUSED.
159             -width => 12,
160             -height => 4,
161             -variable => \$dbname6,
162             -browsecmd => sub {print "-browsecmd!\n";},
163             -listcmd => sub {print "-listcmd!\n";},
164             -state => 'normal',
165             -choices => [qw(pigs cows foxes goats horses sheep dogs cats ardvarks default)]);
166             $jb6->pack(
167             -side => 'top', -pady => '10', -anchor => 'w');
168            
169             #HERE'S ONE THAT DOWS NOT TAKE KEYBOARD FOCUS.
170            
171             $jb7 = $MainWin->JBrowseEntry(
172             -label => 'Skip Focus:',
173             -takefocus => 0,
174             -width => 12,
175             -height => 4,
176             -variable => \$dbname7,
177             -browsecmd => sub {print "-browsecmd!\n";},
178             -listcmd => sub {print "-listcmd!\n";},
179             -state => 'normal',
180             -choices => [qw(pigs cows foxes goats horses sheep dogs cats ardvarks default)]);
181             $jb7->pack(
182             -side => 'top', -pady => '10', -anchor => 'w');
183            
184             $jb7->choices([qw(First Second Fifth Sixth)]); #REPLACE LIST CHOICES!
185             $jb7->insert(2, 'Third', 'Fourth'); #ADD MORE AFTER 1ST 2.
186             $jb7->insert('end', [qw(Seventh Oops Eighth)]); #ADD STILL MORE AT END.
187             $jb7->delete(7); #REMOVE ONE.
188            
189             $b = $MainWin->Button(-text => 'Quit', -command => sub {exit(); });
190             $b->pack(-side => 'top');
191             $jb1->focus; #PICK ONE TO START WITH KEYBOARD FOCUS.
192            
193             MainLoop;
194            
195             =head1 SEE ALSO
196            
197             L L L L
198            
199             =head1 WIDGET-SPECIFIC OPTIONS
200            
201             =over 4
202            
203             =item B<-state> => I
204            
205             Default: B
206            
207             JBrowseEntry supports 5 different states:
208            
209             =over 4
210            
211             I: Default operation -- Both text entry field and dropdown list button function normally.
212            
213             I: Dropdown list functions normally. When text entry field has focus, user may type in a letter, and the dropdown list immediately drops down and the first/ next matching item becomes highlighted. The user must ultimately select from the list of valid entries and may not enter anything else.
214            
215             I: Text entry functions normally, but dropdown list button is disabled. User must type in an entry or use the up and down arrows to choose from among the list items.
216            
217             I: Similar to "text": Text entry functions normally, but dropdown list button is disabled. User must type in an entry. The list choices are completely hidden from the user.
218            
219             I: Widget is completely disabled and greyed out. It will not activate or take focus.
220            
221             =back
222            
223             =item B<-altbinding>
224            
225             Allows one to specify alternate binding schema for certain keys. Currently valid values are "Return=Next" (which causes pressing the [Return] key to advance the focus to the next widget in the main window); and "Down=Popup", which causes the [Down-arrow] key to pop up the selection listbox.
226            
227             =item B<-btntakesfocus>
228            
229             The dropdown list button is normally activated with the mouse and is skipped in the focusing circuit. If this option is set, then the button will take keyboard focus. Pressing , , or will cause the list to be dropped down, repeating causes the list to be removed again. Normally, the text entry widget receives the keyboard focus. This option can be used in combination with "-takefocus" so that either the text entry widget, the button, or both or neither receive keyboard focus. If both options are set, the entry field first receives focus, then pressing causes the button to be focused.
230            
231             =item B<-deleteitemsok>
232            
233             If set, allows user to delete individual items in the drop-down list by pressing the key to delete the current (active) item.
234            
235             =item B<-farrowimage>
236            
237             Allows one to specify a second alternate bitmap for the image on the button which activates the dropdown list when the button has the keyboard focus. The default is to use the "-arrowimage" image. This option should only be specified if the "-arrowimage" option is also specified. See the "-arrowimage" option under Standard BrowseEntry options for more details.
238            
239             =item B<-height>
240            
241             Specify the maximum number of items to be displayed in the listbox before a vertical scrollbar is automatically added. Default is infinity (listbox will not be given a scrollbar regardless of the number of items added).
242            
243             =item B<-labelPack>
244            
245             Specify alternate packing options for the label. The default is: "[-side => 'left', -anchor => 'e']". The argument is an arrayref. Note: if no label is specified, none is packed or displayed.
246            
247             =item B<-labelrelief>
248            
249             Default B<"flat">
250            
251             Allow relief of the label portion of the widget to be specified.
252            
253             =item B<-listfont>
254            
255             Specify an alternate font for the text in the listbox. Use "-font" to change the text of the text entry field. For best results, "-font" and "-listfont" should specify fonts of similar size.
256            
257             =item B<-noselecttext>
258            
259             Normally, when the widget has the focus, the current value is "selected" (highlighted and in the cut-buffer). Some consider this unattractive in appearance, particularly with the "readonly" state, which appears as a raised button in Unix, similar to an "Optionmenu". Setting this option will cause the text to not be selected.
260            
261             =item B<-width>
262            
263             The number of characters (average if proportional font used) wide to make the entry field. The dropdown list will be set the same width as the entry widget plus the width of the button. If not specified, the default is to calculate the width to the width of the longest item in the choices list and if items are later added or removed the width will be recalculated.
264            
265             =item B<-nobutton>
266            
267             Default B<0>
268            
269             Prevents dropdown list button from being displayed.
270            
271             =back
272            
273             =head1 INHERITED OPTIONS
274            
275             =over 4
276            
277             =item B<-arrowimage>
278            
279             Specifies the image to be used in the arrow button beside the entry widget. The default is an downward arrow image in the file cbxarrow.xbm
280            
281             =item B<-browsecmd>
282            
283             Specifies a function to call when a selection is made in the popped up listbox. It is passed the widget and the text of the entry selected. This function is called after the entry variable has been assigned the value.
284            
285             =item B<-choices>
286            
287             Specifies the list of choices to pop up. This is a reference to an array of strings specifying the choices.
288            
289             =item B<-colorstate>
290            
291             Depreciated -- Appears to force the background of the entry widget on the Unix version to "grey95" if state is normal and a "-background" color is not specified.
292            
293             =item B<-listcmd>
294            
295             Specifies the function to call when the button next to the entry is pressed to popup the choices in the listbox. This is called before popping up the listbox, so can be used to populate the entries in the listbox.
296            
297             =item B<-listrelief>
298            
299             Specifies relief for the dropdown list (default is "sunken").
300            
301             =item B<-listwidth>
302            
303             Specifies the width of the popup listbox.
304            
305             =item B<-maxwidth>
306            
307             Specifies the maximum width the entry and listbox widgets can expand to in characters. The default is zero, meaning expand to the width to accomodate the widest string in the list.
308            
309             =item B<-state>
310            
311             Specifies one of four states for the widget: "normal", "readonly", "textonly", or "disabled". If the widget is "disabled" then the value may not be changed and the arrow button won't activate. If the widget is "readonly", the entry may not be edited, but it may be changed by choosing a value from the popup listbox. "textonly" means the listbox will not activate. "normal" is the default.
312            
313             =item B<-tabcomplete>
314            
315             If set to "1", pressing the "" key will cause the string in the entry field to be "auto-completed" to the next matching item in the list. If there is no match, the typed text is not changed. If it already matches a list item, then the listbox is removed from view and keyboard focus transfers to the next widget. If set to "2" and there is no match in the list, then entry is set to the default value or empty string.
316            
317             =item B<-variable>
318            
319             Specifies the variable in which the entered value is to be stored.
320            
321             =back
322            
323             =head1 WIDGET METHODS
324            
325             =over 4
326            
327             =item $widget->B(index)
328            
329             activate() invokes the activate() option on the listbox to make the item with the
330             index specified by the first argument "active". Unless a second argument is
331             passed containing a false value, the value of the "-textvariable" variable is also
332             set to this now active value.
333            
334             =item $widget->B([listref])
335            
336             Sets the dropdown list listbox to the list of values referenced by I, if
337             specified. Returns the current list of choices in the listbox if no arguments
338             provided.
339            
340             =item $widget->B()
341            
342             Returns the currently-selected element in the listbox, if any, otherwise, B.
343            
344             =item $widget->B(first [, last])
345            
346             Deletes one or more elements of the listbox. First and last are indices specifying
347             the first and last elements in the range to delete. If last isn't specified it
348             defaults to first, i.e. a single element is deleted.
349            
350             =item $widget->B(hashkey)
351            
352             Deletes one or more elements of the listbox. "hashkey" specifies the element to
353             be deleted by the value visible to the user.
354            
355             =item $widget->B(hashkey)
356            
357             Returns the actual option key value that corresponds to the choice value displayed
358             in the listbox. (undef if there is none). (Opposite of dereference() and
359             dereferenceOnly().
360            
361             =item $widget->B(hashkey)
362            
363             Returns the value (displayed in the listbox) that corresponds to the choice key
364             specified by "hashkey". If the key is not one of the valid choices or the choices
365             are a list instead of a hash, then "hashkey" is returned.
366            
367             =item $widget->B(hashkey)
368            
369             Returns 1 if the key specified by "hashkey" is one of the valid choices and the list
370             of choices is a hash, otherwise B is returned.
371            
372             =item $widget->B()
373            
374             Returns a reference to the current hash of choices (keyed by the option visable to
375             the user) if the choice list is a hash (reversed from the hash passed to choices()),
376             otherwise, B is returned.
377            
378             =item $widget->B()
379            
380             Returns a reference to the current hash of choices (keyed by actual option value)
381             if the choice list is a hash (same as the hash passed to choices()),
382             otherwise, B is returned.
383            
384             =item $widget->B([first [, last])
385            
386             get() with no arguments returns the current value of the "-textvariable" variable.
387             If any arguments are passed, they are passed directly to the listbox->get()
388             function, ie. "0", "end" to return all values of the listbox.
389            
390             =item $widget->B(hashkey)
391            
392             Returns the index number in the list (zero-based) that can be used by get() of
393             the value specified by "hashkey".
394            
395             =item $widget->B(hashkey)
396            
397             Returns the value (displayed in the listbox) that corresponds to the choice key
398             specified by "hashkey". If the key is not one of the valid choices or the choices
399             are a list instead of a hash, then B is returned.
400            
401             =item $widget->B(index)
402            
403             Invokes and returns the result of the listbox->index() function.
404            
405             =item $widget->B(index, [item | list | listref | hashref])
406            
407             Inserts one or more elements in the list just before the element given by index.
408             If I is specified as "end" then the new elements are added to the end of the list.
409             List can be a reference to a list (I). If a hash reference is specified,
410             then the values are displayed to the user in the dropdown list, but the values
411             returned by the "-textvariable" variable or the get() function are the corresponding
412             hash key(s).
413            
414             =item $widget->B()
415            
416             Invokes and returns the result of the listbox size() function (the number of items in
417             the list.
418            
419             =item $widget->B([normal | readonly | text | textonly | disabled])
420            
421             Get or set the state of the widget.
422            
423            
424             =back
425            
426             =head1 AUTHOR
427            
428             Jim Turner, C<< >>
429            
430             =head1 COPYRIGHT
431            
432             Copyright 2001-2011 (c) Jim Turner .
433             All rights reserved.
434            
435             This program is free software; you can redistribute
436             it and/or modify it under the same terms as Perl itself.
437            
438             This is a derived work from Tk::BrowseEntry. Tk::BrowseEntry is
439             copyrighted by Rajappa Iyer
440            
441             =cut
442            
443             package Tk::JBrowseEntry;
444            
445 1     1   2695 use vars qw($VERSION);
  1         2  
  1         61  
446             $VERSION = '4.8';
447            
448 1     1   1838 use Tk;
  0            
  0            
449             use Carp;
450             use strict;
451            
452             require Tk::Frame;
453             require Tk::LabEntry;
454            
455             use base qw(Tk::Frame);
456             Construct Tk::Widget 'JBrowseEntry';
457            
458             my ($BITMAP, $FOCUSEDBITMAP);
459            
460             sub ClassInit
461             {
462             my($class,$mw) = @_;
463            
464             unless(defined($BITMAP))
465             {
466             $BITMAP = __PACKAGE__ . "::downarrwow";
467            
468             if ($Tk::platform =~ /Win32/)
469             {
470             my $bits = pack("b10"x10,
471             "..........",
472             "..........",
473             "..........",
474             ".#########",
475             "..#######.",
476             "...#####..",
477             "....###...",
478             ".....#....",
479             "..........",
480             ".........."
481             );
482             $mw->DefineBitmap($BITMAP => 10,10, $bits);
483             }
484             else
485             {
486             my $bits = pack("b11"x12,
487             "....###....",
488             "....###....",
489             "....###....",
490             "....###....",
491             ".#########.",
492             "..#######..",
493             "...#####...",
494             "....###....",
495             ".....#.....",
496             "...........",
497             ".#########.",
498             ".#########."
499             );
500             $mw->DefineBitmap($BITMAP => 11,12, $bits);
501             }
502             $FOCUSEDBITMAP = __PACKAGE__ . "::fdownarrow";
503            
504             if ($Tk::platform =~ /Win32/)
505             {
506             my $bits = pack("b10"x10,
507             ".#.#.#.#.#",
508             ".#.......#",
509             "..........",
510             ".#########",
511             "..#######.",
512             ".#.#####.#",
513             "....###...",
514             ".#...#...#",
515             "..........",
516             ".##.#.#.##"
517             );
518             $mw->DefineBitmap($FOCUSEDBITMAP => 10,10, $bits);
519             }
520             }
521             }
522            
523             sub Populate
524             {
525             my ($w, $args) = @_;
526             $w->{btntakesfocus} = 0;
527             $w->{btntakesfocus} = delete ($args->{-btntakesfocus}) if (defined($args->{-btntakesfocus}));
528             $w->{arrowimage} = $args->{-arrowimage} if (defined($args->{-arrowimage}));
529             $w->{farrowimage} = delete ($args->{-farrowimage}) if (defined($args->{-farrowimage}));
530             $w->{arrowimage} ||= $w->{farrowimage} if ($w->{farrowimage});
531             $w->{mylistcmd} = $args->{-listcmd} if (defined($args->{-listcmd}));
532             $w->{takefocus} = 1;
533             $w->{takefocus} = delete ($args->{-takefocus}) if (defined($args->{-takefocus}));
534             $w->{-listwidth} = $args->{-width} if (defined($args->{-width}));
535             $w->{-maxwidth} = delete($args->{-maxwidth}) if (defined($args->{-maxwidth}));
536             $w->{-foreground} = $args->{-foreground} if (defined($args->{-foreground}));
537             $w->{-background} = $w->parent->cget(-background) || 'gray';
538             $w->{-background} = $args->{-background} if (defined($args->{-background}));
539             $w->{-textbackground} = delete($args->{-textbackground}) if (defined($args->{-textbackground}));
540             $w->{-textforeground} = delete($args->{-textforeground}) if (defined($args->{-textforeground}));
541             #unless ($^O =~ /Win/i) #FOR SOME REASON, THIS IS NEEDED IN LINUX?
542             {
543             $w->{-disabledbackground} = delete($args->{-disabledbackground}) if (defined($args->{-disabledbackground}));
544             $w->{-disabledforeground} = delete($args->{-disabledforeground}) if (defined($args->{-disabledforeground}));
545             }
546             $w->{-foreground} = $w->parent->cget(-foreground);
547             #$w->{-borderwidth} = 2;
548             # $w->{-borderwidth} = delete($args->{-borderwidth}) if (defined($args->{-borderwidth})); #CHGD. TO NEXT 20070904 FROM WOLFRAM HUMANN.
549             $w->{-borderwidth} = defined($args->{-borderwidth}) ? delete($args->{-borderwidth}) : 2;
550             $w->{-relief} = 'sunken';
551             $w->{-relief} = delete($args->{-relief}) if (defined($args->{-relief}));
552             $w->{-listrelief} = 'sunken';
553             $w->{-listrelief} = delete($args->{-listrelief}) if (defined($args->{-listrelief}));
554             $w->{-listfont} = delete($args->{-listfont}) if (defined($args->{-listfont}));
555             $w->{-noselecttext} = delete($args->{-noselecttext}) if (defined($args->{-noselecttext}));
556             $w->{-browse} = 0;
557             $w->{-browse} = delete($args->{-browse}) if (defined($args->{-browse}));
558             $w->{-tabcomplete} = 0;
559             $w->{-tabcomplete} = delete($args->{-tabcomplete}) if (defined($args->{-tabcomplete}));
560             $w->{-altbinding} = 0; #NEXT 2 ADDED 20050112 TO SUPPORT ALTERNATE KEY-ACTION MODELS.
561             $w->{-altbinding} = delete($args->{-altbinding}) if (defined($args->{-altbinding}));
562             #NEXT LINE ADDED 20060429 TO SUPPORT OPTION FOR USER DELETION OF LISTBOX ITEMS.
563             $w->{-deleteitemsok} = delete($args->{-deleteitemsok}) if (defined($args->{-deleteitemsok}));
564             $w->{-framehighlightthickness} = defined($args->{-framehighlightthickness})
565             ? delete($args->{-framehighlightthickness}) : 1;
566             #NEXT 2 OPTIONS ADDED 20070904 BY JWT:
567             $w->{-buttonborderwidth} = defined($args->{-buttonborderwidth})
568             ? delete($args->{-buttonborderwidth}) : 1;
569             $w->{-entryborderwidth} = defined($args->{-entryborderwidth})
570             ? delete($args->{-entryborderwidth}) : 0;
571             $w->{-nobutton} = defined($args->{-nobutton})
572             ? delete($args->{-nobutton}) : 0;
573             $w->{-labelrelief} = defined($args->{-labelrelief})
574             ? delete($args->{-labelrelief}) : 'flat';
575             my $lpack = delete $args->{-labelPack}; #MOVED ABOVE SUPER:POPULATE 20050120.
576             $w->SUPER::Populate($args);
577            
578             # ENTRY WIDGET AND ARROW BUTTON
579            
580             unless (defined $lpack)
581             {
582             $lpack = [-side => "left", -anchor => "e"];
583             }
584             my $labelvalue = $args->{-label};
585            
586             my $ll = $w->Label(-relief => $w->{-labelrelief}, -text => delete $args->{-label});
587             # my $tf = $w->Frame(-borderwidth => ($w->{-borderwidth} || 2), -highlightthickness => 1,
588             # -relief => ($w->{-relief} || 'sunken')); #CHGD. TO NEXT 2 20070904 FROM WOLFRAM HUMANN.
589             my $tf = $w->Frame(-borderwidth => $w->{-borderwidth}, -highlightthickness => $w->{-framehighlightthickness},
590             -relief => $w->{-relief});
591            
592             # my $e = $tf->LabEntry(-borderwidth => 0, -relief => 'flat');
593             my $e = $tf->LabEntry(-borderwidth => $w->{-entryborderwidth}, -relief => 'flat');
594             # FOR SOME REASON, E HAS TO BE A LABENTRY, JUST PLAIN ENTRY WOULDN'T TAKE KEYBOARD EVENTS????
595             $w->ConfigSpecs(DEFAULT => [$e]);
596             # my $b = $tf->Button(-borderwidth => 1, -takefocus => $w->{btntakesfocus}, #CHGD. TO NEXT 20070904 - JWT:
597             my $b = $tf->Button(-borderwidth => $w->{-buttonborderwidth}, -takefocus => $w->{btntakesfocus},
598             -bitmap => $BITMAP);
599             if ($labelvalue)
600             {
601             $ll->pack(@$lpack);
602             }
603             else
604             {
605             $ll->packForget(); # REMOVE LABEL, IF NO VALUE SPECIFIED.
606             }
607             $w->Advertise("entry" => $e); #TEXT PART.
608             $w->Advertise("arrow" => $b); #ARROW BUTTON PART.
609             $w->Advertise("frame" => $tf); #SURROUNDING FRAME PART.
610             my ($ee) = $w->Subwidget("entry");
611             $w->Advertise("textpart" => $ee); #TEXT COMPONENT OF LABENTRY WIDGET.
612             $tf->pack(-side => "right", -padx => 0, -pady => 0, -fill => 'x', -expand => 1);
613             $b->pack(-side => "right", -padx => 0, -pady => 0, -fill => 'y') unless ($w->{-nobutton} == 1);
614             $e->pack(-side => "right", -fill => 'x', -padx => 0, -pady => 0, -expand => 1); #, -padx => 1);
615            
616             # POPUP SHELL FOR LISTBOX WITH VALUES.
617            
618             my $c = $w->Toplevel(-bd => 2, -relief => "raised");
619             $c->overrideredirect(1);
620             $c->withdraw;
621             my $sl = $c->Scrolled( qw/Listbox -selectmode browse -scrollbars oe/ );
622            
623             # PROPOGATE FORE & BACKGROUND COLORS TO ALL WIDGETS, IF SPECIFIED.
624            
625             if (defined($w->{-foreground}))
626             {
627             $e->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
628             $tf->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
629             $sl->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
630             $b->configure(-foreground => $w->{-foreground}, -highlightcolor => $w->{-foreground});
631             }
632             if (defined($w->{-listrelief}))
633             {
634             $sl->configure(-relief => ($w->{-listrelief}||'sunken'));
635             }
636             if (defined($w->{-background}) || defined($w->{-textbackground}))
637             {
638             $e->configure(-background => ($w->{-textbackground}||$w->{-background}), -highlightbackground => $w->{-background});
639             $tf->configure(-background => $w->{-background}, -highlightbackground => $w->{-background});
640             $sl->configure(-background => $w->{-background}, -highlightbackground => $w->{-background});
641             $b->configure(-background => $w->{-background}, -highlightbackground => $w->{-background});
642             }
643             elsif ($^O =~ /Win/i) # SET BACKGROUND TO WINDOWS DEFAULTS (IF NOT SPECIFIED)
644             {
645             $sl->configure( -background => 'SystemWindow' );
646             }
647             if ($^O =~ /Win/i)
648             {
649             $sl->configure( -borderwidth => 1);
650             $c->configure( -borderwidth => ($w->{-borderwidth}||0), -relief => 'ridge' );
651             }
652             if (defined($w->{-disabledforeground})) #THIS ERRS ON LINUX SOMETIMES?!
653             {
654             eval { $e->Subwidget("entry")->configure(-disabledforeground => $w->{-disabledforeground}); };
655             }
656             if (defined($w->{-disabledbackground}))
657             {
658             eval { $e->configure(-disabledbackground => $w->{-disabledbackground}); };
659             }
660             $sl->configure(-font => $w->{-listfont}) if ($w->{-listfont});
661             $w->Advertise("choices" => $c); #LISTBOX POPUP MAIN WINDOW PART.
662             $w->Advertise("slistbox" => $sl); #ACTUAL LISTBOX ITSELF.
663             $sl->pack(-expand => 1, -fill => "both");
664            
665             # OTHER INITIALIZATIONS.
666            
667             $w->SetBindings;
668             $w->{"popped"} = 0;
669             $w->Delegates('insert' => $sl, 'delete' => $sl, get => $sl, DEFAULT => $e);
670             $w->ConfigSpecs(
671             -listwidth => [qw/PASSIVE listWidth ListWidth/, undef],
672             -maxwidth => [qw/PASSIVE maxWidth MaxWidth/, undef],
673             -height => [qw/PASSIVE height Height/, undef],
674             -listcmd => [qw/CALLBACK listCmd ListCmd/, undef],
675             -browsecmd => [qw/CALLBACK browseCmd BrowseCmd/, undef],
676             -choices => [qw/METHOD choices Choices/, undef],
677             -state => [qw/METHOD state State normal/],
678             -arrowimage => [ {-image => $b}, qw/arrowImage ArrowImage/, undef],
679             -variable => "-textvariable",
680             -colorstate => [qw/PASSIVE colorState ColorState/, undef],
681             -default => "-textvariable",
682             -imgname => '',
683             -img0 => '',
684             -img1 => '',
685             DEFAULT => [$e] );
686            
687             my $var_ref = $w->cget( "-textvariable" );
688            
689             #SET UP DUMMY SO IT DISPLAYSS IF NO VARIABLE SPECIFIED.
690            
691             unless (defined($var_ref) && ref($var_ref))
692             {
693             $var_ref = '';
694             $w->configure(-textvariable => \$var_ref);
695             }
696            
697             eval { $w->{'default'} = $_[1]->{'-default'} || ${$_[1]->{-variable}}; };
698             }
699            
700             sub focus
701             {
702             my ($w) = shift;
703             my ($state) = $w->cget( "-state" );
704            
705             if ($state eq 'disabled') #MOVE FOCUS ON TO NEXT WIDGET (DON'T TAKE FOCUS).
706             {
707             eval {$w->focusNext->focus; };
708             }
709             else
710             {
711             if ($w->{'savefocus'} && Tk::Exists($w->{'savefocus'}))
712             {
713             $w->{'savefocus'}->focus;
714             }
715             elsif ($state eq 'readonly') #FRAME GETS FOCUS IF READONLY.
716             {
717             $w->Subwidget("frame")->focus;
718             }
719             else #OTHERWISE, TEXT ENTRY COMPONENT DOES.
720             {
721             $w->Subwidget("entry")->focus;
722             }
723             delete $w->{'savefocus'};
724            
725             #BUTTON GETS FOCUS IF BUTTON TAKES FOCUS, BUT WIDGET ITSELF DOESN'T.
726            
727             $w->Subwidget("arrow")->focus if (!$w->{takefocus} && $w->{btntakesfocus});
728             $w->Subwidget("entry")->icursor('end');
729             unless ($w->{-noselecttext} || !$w->Subwidget("entry")->index('end'))
730             {
731             $w->Subwidget("entry")->selectionRange(0,'end'); # unless ($state eq 'readonly' && $w->{btntakesfocus});
732             }
733             }
734             }
735            
736             sub SetBindings
737             {
738             my ($w) = @_;
739            
740             my $e = $w->Subwidget("entry");
741             my $f = $w->Subwidget("frame");
742             my $b = $w->Subwidget("arrow");
743             my $sl = $w->Subwidget("slistbox");
744             my $l = $sl->Subwidget("listbox");
745            
746             local *returnFn = sub #HANDLES RETURN-KEY PRESSED IN ENTRY AREA.
747             {
748             shift;
749             my $keyModifier = shift || '';
750             $keyModifier .= '-' if ($keyModifier =~ /\S/o);
751             my $altbinding = $w->{-altbinding};
752             #print "returnFn0: alt=$altbinding= modifier=$keyModifier=\n";
753             if ($altbinding =~ /Return\=Next/io)
754             {
755             #print "returnFn1: popped=".$w->{"popped"}."=\n";
756             $w->Popdown if ($w->{"popped"}); #UNDISPLAYS LISTBOX.
757             $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get, "entry.${keyModifier}return.browse")
758             if ($w->{-browse} == 1);
759             eval { shift->focusNext->focus; };
760             Tk->break;
761             }
762             elsif ($altbinding =~ /Return\=Go/io)
763             {
764             $w->Popdown if ($w->{"popped"}); #UNDISPLAYS LISTBOX.
765             $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get, "entry.${keyModifier}return.go");
766             Tk->break;
767             }
768             my ($state) = $w->cget( "-state" );
769            
770             &LbFindSelection($w);
771             #print "returnFn2: popped=".$w->{"popped"}."=\n";
772             unless ($w->{"popped"})
773             {
774             $w->BtnDown;
775             return if ($state =~ /text/o || $state eq 'disabled');
776             $w->{'savefocus'} = $w->focusCurrent;
777             $w->Subwidget("slistbox")->focus;
778             }
779             else
780             {
781             $w->LbCopySelection(0,'entry.enter');
782             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
783             $e->icursor('end');
784             Tk->break;
785             }
786             };
787            
788             local *rightFn = sub
789             {
790             Tk->break if ($e->index('insert') < $e->index('end')
791             || $w->{-altbinding} =~ /Right=NoSearch/io);
792             my ($state) = $w->cget( "-state" );
793             return if ($state eq 'textonly' || $state eq 'disabled');
794             my $srchPattern = $w->cget( "-textvariable" );
795             &LbFindSelection($w, $srchPattern);
796             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
797             my (@listsels) = $l->get('0','end');
798             my $index = $w->LbIndex;
799             if (&LbFindSelection($w) == 1 && &LbFindSelection($w, $srchPattern))
800             {
801             $index += 1;
802             $index = 0 if ($index > $#listsels);
803             }
804             my $var_ref = $w->cget( "-textvariable" );
805             $$var_ref = $listsels[$index];
806             $e->icursor('end');
807             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
808             };
809            
810             local *downFn = sub #HANDLES DOWN-ARROW PRESSED IN ENTRY AREA.
811             {
812             my $altbinding = $w->{-altbinding};
813             #print STDERR "-downFn: altbinding=$altbinding/$w->{-altbinding}= w=$w=\n";
814             my ($state) = $w->cget( "-state" );
815             return if ($state eq 'textonly' || $state eq 'disabled');
816             &LbFindSelection($w);
817             if ($altbinding =~ /Down\=Popup/io) #MAKE DOWN-ARROW POP UP DD-LIST.
818             {
819             unless ($w->{"popped"})
820             {
821             $w->BtnDown;
822             return if ($state =~ /text/o || $state eq 'disabled');
823             $w->{'savefocus'} = $w->focusCurrent;
824             $w->Subwidget("slistbox")->focus;
825             }
826             else
827             {
828             $w->LbCopySelection(0,'entry.down');
829             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
830             $e->icursor('end');
831             Tk->break;
832             }
833             return;
834             }
835             if ($w->{"popped"})
836             {
837             return if ($state eq 'text');
838             &LbFindSelection($w);
839             $w->{'savefocus'} = $w->focusCurrent;
840             $w->Subwidget("slistbox")->focus;
841             }
842             else
843             {
844             &LbFindSelection($w);
845             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
846             my (@listsels) = $l->get('0','end');
847             my $index = $w->LbIndex;
848             if (&LbFindSelection($w) == 1)
849             {
850             $index += 1;
851             $index = 0 if ($index > $#listsels);
852             }
853             my $var_ref = $w->cget( "-textvariable" );
854             $$var_ref = $listsels[$index];
855             $l->activate($index); #ADDED 20070904 PER PATCH FROM WOLFRAM HUMANN.
856             $e->icursor('end');
857             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
858             }
859             };
860            
861             local *upFn = sub #HANDLES UP-ARROW PRESSED IN ENTRY AREA.
862             {
863             my ($state) = $w->cget( "-state" );
864             return if ($state eq 'textonly' || $state eq 'disabled');
865             if ($w->{"popped"})
866             {
867             return if ($state eq 'text');
868             &LbFindSelection($w);
869             $w->{'savefocus'} = $w->focusCurrent;
870             $w->Subwidget("slistbox")->focus;
871             }
872             else
873             {
874             &LbFindSelection($w);
875             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
876             my (@listsels) = $l->get('0','end');
877             my $index = $w->LbIndex - 1;
878             $index = $#listsels if ($index < 0);
879             my $var_ref = $w->cget( "-textvariable" );
880             $$var_ref = $listsels[$index];
881             $l->activate($index); #ADDED 20070904 PER PATCH FROM WOLFRAM HUMANN.
882             $e->icursor('end');
883             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
884             }
885             };
886            
887             local *escapeFn = sub #HANDLES ESCAPE-KEY PRESSED IN ENTRY AREA.
888             {
889             if ($w->{"popped"})
890             {
891             $w->Popdown;
892             }
893             else
894             {
895             my $var_ref = $w->cget( "-textvariable" );
896             #if ($$var_ref eq $w->{'default'} && $w->cget( "-state" ) ne "readonly")
897             #CHGD. TO NEXT 20030531 PER PATCH BY FRANK HERRMANN.
898             if (defined $w->{'default'} and $$var_ref eq $w->{'default'}
899             and $w->cget( "-state" ) ne "readonly")
900             {
901             $$var_ref = '';
902             }
903             else
904             {
905             $$var_ref = $w->{'default'};
906             }
907             $e->icursor('end');
908             }
909             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end')); #ADDED 20020716
910             Tk->break;
911             };
912            
913             local *spacebarFn = sub #HANDLES SPACEBAR PRESSED IN ENTRY AREA.
914             {
915             my ($state) = $w->cget( "-state" );
916            
917             if ($state eq 'readonly')
918             {
919             my $res = &LbFindSelection($w);
920             unless ($w->{"popped"})
921             {
922             $w->BtnDown;
923             unless ($res) #ADDED 20090320 TO CAUSE DROPDOWN LIST TO POP DOWN W/ACTIVE CURSOR IN RIGHT PLACE (INSTEAD OF BOTTOM) IF ENTRY FIELD EMPTY.
924             {
925             $l->selectionClear('0','end');
926             $l->activate(0);
927             $l->selectionSet(0);
928             $l->update();
929             $l->see(0);
930             }
931             return if ($state =~ /text/o || $state eq 'disabled');
932             $w->{'savefocus'} = $w->focusCurrent;
933             $w->Subwidget("slistbox")->focus;
934             }
935             else
936             {
937             $w->LbCopySelection(0,'entry.space');
938             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
939             $e->icursor('end');
940             Tk->break;
941             }
942             }
943             };
944            
945             # SET BIND TAGS
946            
947             $w->bindtags([$w, 'Tk::JBrowseEntry', $w->toplevel, "all"]);
948             $e->bindtags([$e, $e->toplevel, "all"]);
949            
950             # IF USER-SPECIFIED IMAGE(S), CHANGE BUTTON IMAGE WHEN GETTING/LOSING FOCUS.
951            
952             $b->bind("", sub
953             {
954             $b = shift;
955             my ($state) = $w->cget( "-state" );
956             my $img = $w->{farrowimage} || $b->cget('-image');
957             if ($img)
958             {
959             unless ($w->{img0})
960             {
961             $w->{img0} = $img;
962             }
963             $b->configure(-image => $w->{img0});
964             }
965             elsif ($^O =~ /Win/io)
966             {
967             $w->{img0} = $FOCUSEDBITMAP;
968             $b->configure(-bitmap => $w->{img0});
969             }
970             $w->{imgname} = 'cbfarrow';
971             $w->{savehl} = $f->cget(-highlightcolor);
972             my $framehlcolor;
973             if ($^O =~ /Win/io)
974             {
975             $framehlcolor = $w->{-background} || 'SystemButtonFace';
976             }
977             else
978             {
979             $framehlcolor = $w->{-background} || $e->cget( -background );
980             }
981             $f->configure(-highlightcolor => $framehlcolor);
982             }
983             );
984            
985             $b->bind("", sub
986             {
987             $b = shift;
988             my ($state) = $w->cget( "-state" );
989             my $img = $w->{arrowimage} || $b->cget('-image');
990             if ($img)
991             {
992             unless ($w->{img1})
993             {
994             $w->{img1} = $img;
995             }
996             $b->configure(-image => $w->{img1});
997             }
998             elsif ($^O =~ /Win/io)
999             {
1000             $w->{img1} = $BITMAP;
1001             $b->configure(-bitmap => $w->{img1});
1002             }
1003             $w->{imgname} = 'cbxarrow';
1004             $f->configure(-highlightcolor => $w->{savehl}) if ($w->{savehl});
1005             }
1006             );
1007            
1008             $b->bind('<1>', sub #MOUSE CLICKED ON BUTTON.
1009             {
1010             my ($state) = $b->cget( "-state" );
1011             unless ($state eq 'disabled')
1012             {
1013             &LbFindSelection($w) if ($w->{popped});
1014             $w->BtnDown; #POPS UP LISTBOX!
1015             if ($w->{popped})
1016             {
1017             my $index = $w->LbIndex;
1018             $index = 0 if (!defined($index) || $index < 0);
1019             $l->focus;
1020             $l->activate($index); #THIS UNDERLINES IT.
1021             $l->selectionClear(0,'end'); #THIS HIGHLIGHTS IT (NEEDED 1ST TIME?!)
1022             $l->selectionSet($index); #THIS HIGHLIGHTS IT (NEEDED 1ST TIME?!)
1023             }
1024             $w->LbCopySelection(1,'buttondown.button1');
1025             }
1026             Tk->break;
1027             }
1028             );
1029            
1030             $b->bind("", sub {
1031             my ($state) = $b->cget( "-state" );
1032             if ($state ne 'disabled' && $w->{'popped'}) #LISTBOX IS SHOWING
1033             {
1034             $w->LbCopySelection(1,'buttonup.button1');
1035             }
1036             Tk->break;
1037             }
1038             );
1039            
1040             $b->bind("", sub
1041             {
1042             my ($state) = $w->cget( "-state" );
1043             return if ($state =~ /text/o || $state eq 'disabled');
1044            
1045             &LbFindSelection($w);
1046             $w->BtnDown;
1047             $w->{'savefocus'} = $b || $w->focusCurrent;
1048             $w->Subwidget("slistbox")->focus;
1049             }
1050             );
1051            
1052             $b->bind("", sub
1053             {
1054             my ($state) = $w->cget( "-state" );
1055             return if ($state =~ /text/o || $state eq 'disabled');
1056            
1057             &LbFindSelection($w);
1058             $w->BtnDown;
1059             $w->{'savefocus'} = $b || $w->focusCurrent;
1060             $w->Subwidget("slistbox")->focus;
1061             Tk->break;
1062             }
1063             );
1064            
1065             $b->bind("", sub
1066             {
1067             my ($state) = $w->cget( "-state" );
1068             return if ($state =~ /text/ || $state eq 'disabled');
1069            
1070             &LbFindSelection($w);
1071             $w->BtnDown;
1072             $w->{'savefocus'} = $b || $w->focusCurrent;
1073             $w->Subwidget("slistbox")->focus;
1074             Tk->break;
1075             }
1076             );
1077            
1078             $e->bind("", [\&returnFn, 'mod.Shift']);
1079             $f->bind("", [\&returnFn, 'mod.Shift']);
1080             $e->bind("", [\&returnFn, 'mod.Control']);
1081             $f->bind("", [\&returnFn, 'mod.Control']);
1082             $e->bind("", [\&returnFn, 'mod.Alt']);
1083             $f->bind("", [\&returnFn, 'mod.Alt']);
1084             $e->bind("", \&returnFn);
1085             $f->bind("", \&returnFn);
1086            
1087             $e->bind("", \&downFn);
1088             $f->bind("", \&downFn);
1089            
1090             $e->bind("", \&spacebarFn);
1091             $f->bind("", \&spacebarFn);
1092            
1093             $e->bind("", \&upFn);
1094             $f->bind("", \&upFn);
1095            
1096             $e->bind('' => \&escapeFn);
1097             $f->bind('' => \&escapeFn);
1098            
1099             $e->bind("", sub {Tk->break;});
1100             #$e->bind("", sub {Tk->break;});
1101             $e->bind("", \&rightFn);
1102             $f->bind("", sub {Tk->break;});
1103             #$f->bind("", sub {Tk->break;});
1104             $f->bind("", \&rightFn);
1105            
1106             $e->bind("<>", sub #ADDED 20070904 PER PATCH FROM WOLFRAM HUMANN.
1107             {
1108             my ($state) = $w->cget( "-state" );
1109             $w->Popdown if ($w->{"popped"});
1110             $w->focusPrev if ($state =~ /only/o);
1111             $w->focusCurrent->focusPrev;
1112             $w->focusCurrent->focusPrev unless ($state =~ /only/o);
1113             Tk->break;
1114             });
1115            
1116             $e->bind("", sub
1117             {
1118             my $same = 1;
1119             #NEXT LINE ADDED 20030531 PER PATCH BY FRANK HERRMANN.
1120             $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get, 'entry.tab')
1121             if ($w->{-browse} == 1);
1122             if ($w->{-tabcomplete})
1123             {
1124             my $var_ref = $w->cget( "-textvariable" );
1125             if (&LbFindSelection($w))
1126             {
1127             my @listsels = $l->get('0','end');
1128             my $index = $w->LbIndex;
1129             unless ($$var_ref eq $listsels[$index])
1130             {
1131             $$var_ref = $listsels[$index];
1132             $e->icursor('end');
1133             $same = 0;
1134             }
1135             }
1136             elsif ($w->{-tabcomplete} == 2)
1137             {
1138             #THIS CODE FORCES TAB TO CHANGE TEXT ENTERED TO A LIST ITEM!
1139             #THIS SUCKS IF THERE IS NO LIST OR USER WISHES TO OVERRIDE!
1140             unless ($$var_ref eq ((defined $w->{'default'}) ? $w->{'default'} : ''))
1141             {
1142             if (defined $w->{'default'})
1143             {
1144             $$var_ref = $w->{'default'};
1145             }
1146             else
1147             {
1148             $$var_ref = '';
1149             }
1150             $e->icursor('end');
1151             $same = 0;
1152             }
1153             }
1154             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
1155             }
1156             if ($w->{"popped"}) #UNDISPLAYS LISTBOX.
1157             {
1158             $w->Popdown;
1159             }
1160             eval { shift->focusNext->focus; } if ($same);
1161             Tk->break;
1162             }
1163             );
1164            
1165             $f->bind("", sub
1166             {
1167             #NEXT LINE ADDED 20030531 PER PATCH BY FRANK HERRMANN.
1168             $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get, 'frame.tab')
1169             if ($w->{-browse} == 1);
1170             $w->Popdown if ($w->{"popped"});
1171             eval { shift->focusNext->focus; };
1172             }
1173             );
1174            
1175             # KEYBOARD BINDINGS FOR LISTBOX
1176            
1177             $l->configure(-selectmode => 'browse');
1178             $l->configure(-takefocus => 1);
1179             $l->bind("", sub
1180             {
1181             $w->ButtonHack;
1182             LbChoose($w, $l->XEvent->x, $l->XEvent->y);
1183             Tk->break; #ADDED 20050210.
1184             }
1185             );
1186             $l->bind('' => sub
1187             {
1188             $w->LbClose;
1189             Tk->break;
1190             }
1191             );
1192             $l->bind('' => sub
1193             {
1194             $w->LbCopySelection(0,'listbox.enter');
1195             #$e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
1196             #$e->icursor('end');
1197             Tk->break;
1198             }
1199             );
1200             $l->bind('' => sub
1201             {
1202             my ($state) = $w->cget( "-state" );
1203             $w->LbCopySelection(0,'listbox.space');
1204             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
1205             $e->icursor('end');
1206             $w->{'savefocus'} = $w->focusCurrent; #ADDED 20060621 TO ALLOW JFILEDIALOG TO SET FOCUS TO ANOTHER WIDGET WHEN USER SELECTS VIA SPACEBAR.
1207             Tk->break;
1208             }
1209             );
1210            
1211             $l->bind('' => sub
1212             {
1213             my ($state) = $w->cget( "-state" );
1214             $w->Popdown if ($^O !~ /Win/i && !$w->{takefocus}); #WINDUHS LOWERS LISTBOX BEHIND CALLER (HIDES IT)!
1215             $w->Popdown if ($^O =~ /Win/i || $state eq 'readonly'); #WINDUHS LOWERS LISTBOX BEHIND CALLER (HIDES IT)!
1216             $e->focus() unless ($state eq 'readonly'); #SO WE'LL POP IT DOWN FIRST! (RAISE WOULDN'T WORK :-()
1217             $w->BtnDown if ($^O =~ /Win/i && $state ne 'readonly' && $w->{takefocus});
1218             if ($w->{-tabcomplete})
1219             {
1220             &LbFindSelection($w);
1221             my @listsels = $l->get('0','end');
1222             my $index = $w->LbIndex;
1223             my $var_ref = $w->cget( "-textvariable" );
1224             unless ($$var_ref eq $listsels[$index])
1225             {
1226             $$var_ref = $listsels[$index];
1227             $e->icursor('end');
1228             }
1229             $e->selectionRange(0,'end') unless ($w->{-noselecttext} || !$e->index('end'));
1230             }
1231             Tk->break;
1232             }
1233             );
1234             $l->bind('' => sub { $w->delete($w->LbIndex) }) #ADDED 20060429 TO SUPPORT OPTION FOR USER DELETION OF LISTBOX ITEMS.
1235             if ($w->{-deleteitemsok});
1236             $l->bind('' => [\&keyFn,$w,$e,$l,1]);
1237             #if $w->cget( "-state" ) eq "readonly";
1238             $e->bind('' => [\&keyFn,$w,$e,$l]);
1239             $f->bind('' => [\&keyFn,$w,$e,$l]);
1240             #unless $w->cget( "-state" ) eq "readonly";
1241             $e->bind('<1>' => sub {
1242             my ($state) = $w->cget( "-state" );
1243             if ($state eq 'readonly')
1244             {
1245             my $res = &LbFindSelection($w);
1246             if ($w->{"popped"})
1247             {
1248             $w->Popdown(1);
1249             }
1250             else
1251             {
1252             unless ($res) #ADDED 20090320 TO CAUSE DROPDOWN LIST TO POP DOWN W/ACTIVE CURSOR IN RIGHT PLACE (INSTEAD OF BOTTOM) IF ENTRY FIELD EMPTY.
1253             {
1254             $l->selectionClear('0','end');
1255             $l->activate(0);
1256             $l->selectionSet(0);
1257             $l->update();
1258             $l->see(0);
1259             }
1260             $w->BtnDown;
1261             }
1262             $w->{'savefocus'} = $w->focusCurrent;
1263             $w->Subwidget("slistbox")->focus;
1264             Tk->break;
1265             }
1266             else
1267             {
1268             if ($w->{"popped"})
1269             {
1270             $w->Popdown(1);
1271             }
1272             $e->focus;
1273             Tk->break;
1274             }
1275             });
1276            
1277             #NEXT 3 LINES ADDED 20030531 PER PATCH BY FRANK HERRMANN.
1278             $e->bind('<2>' => sub {
1279             $e->focus;
1280             });
1281            
1282             # ALLOW CLICK OUTSIDE THE POPPED UP LISTBOX TO POP IT DOWN.
1283            
1284             $w->bind("<1>", sub {$w->BtnDown; Tk->break});
1285             $w->parent->bind("<1>", sub
1286             {
1287             if ($w->{"popped"})
1288             {
1289             $w->Popdown(1);
1290             }
1291             }
1292             );
1293             $w->bind("", \&focus);
1294             $w->bind('', sub {print "-focus=".$w->focusCurrent()."=\n";});
1295             $w->bind('', sub {print "-focus=".$w->focusCurrent()."=\n";});
1296             }
1297            
1298             sub keyFn #JWT: TRAP LETTERS PRESSED AND ADJUST SELECTION ACCORDINGLY.
1299             {
1300             my ($x,$w,$e,$l,$flag) = @_;
1301             my $mykey = $x->XEvent->A;
1302            
1303             #NEXT LINE ADDED 20030531 PER PATCH BY FRANK HERRMANN.
1304             $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get, "key.$mykey")
1305             if ($w->{-browse} == 1);
1306            
1307             if ($w->cget( "-state" ) eq "readonly") #ADDED 20020711 TO ALLOW TYPING 1ST LETTER TO SELECT NEXT VALID ITEM!
1308             {
1309             &LbFindSelection($w,$mykey) if ($mykey); #JUMP TO 1ST ITEM STARTING WITH THIS KEY
1310             # $w->LbCopySelection(1,'key.$mykey'); #CHGD. TO NEXT 20100803 - I THINK THIS IS WRONG - HOPE IT DOESN'T BREAK ANYTHING!
1311             $w->LbCopySelection(1,"key.$mykey");
1312             $w->Subwidget("entry")->selectionRange(0,'end') unless ($w->{"popped"}
1313             || $w->{-noselecttext} || !$w->Subwidget("entry")->index('end'));
1314             $e->icursor('end');
1315             }
1316             elsif (defined $flag and $flag == 1) #LISTBOX HAS FOCUS.
1317             {
1318             &LbFindSelection($w,$mykey) if ($mykey); #JUMP TO 1ST ITEM STARTING WITH THIS KEY
1319             }
1320             else #TEXT FIELD HAS FOCUS.
1321             {
1322             &LbFindSelection($w) if ($mykey); #JUMP TO 1ST ITEM MATCHING TEXT FIELD.
1323             }
1324            
1325             }
1326            
1327             sub BtnDown
1328             {
1329             my ($w) = @_;
1330             my ($state) = $w->cget( "-state" );
1331            
1332             return if ($state =~ /text/ || $state eq 'disabled');
1333            
1334             #JWT: NEXT 2 LINES PREVENT POPPING EMPTY LIST!
1335            
1336             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
1337             return unless ($l->get('0','end'));
1338            
1339             if ($w->{"popped"})
1340             {
1341             $w->Popdown(1);
1342             $w->{"buttonHack"} = 0;
1343             }
1344             else
1345             {
1346             $w->PopupChoices;
1347             $w->{"buttonHack"} = 1;
1348             }
1349             }
1350            
1351             sub PopupChoices
1352             {
1353             my ($w) = @_;
1354            
1355             # my $first; -- REMOVED 20070904 PER PATCH BY WOLFRAM HUMANN (PROBABLY OBSOLETED BY FRANK HERRMANN PATCHES
1356            
1357             if (!$w->{"popped"})
1358             {
1359             my $x = $w->Callback(-listcmd, $w);
1360             return undef if ($x =~ /nolist/io); #IF -listcmd CALLBACK RETURNS 'nolist',
1361             my $e = $w->Subwidget("entry"); #THEN DON'T DISPLAY THE DROP-DOWN LIST!
1362             my $c = $w->Subwidget("choices");
1363             my $s = $w->Subwidget("slistbox");
1364             my $a = $w->Subwidget("arrow");
1365            
1366             my $wheight = $w->cget("-height");
1367             my (@hh);
1368             $hh[0]=$w->height;
1369             $hh[1]=$w->reqheight;
1370             $hh[2]=$e->height;
1371             $hh[3]=$e->reqheight;
1372             $hh[4]=$c->height;
1373             $hh[5]=$c->reqheight;
1374             $hh[6]=$s->height;
1375             $hh[7]=$s->reqheight;
1376            
1377             my $sll = $s->Subwidget("listbox");
1378             my $rw = $c->width;
1379             # $first = 1 if ($rw <= 1); -- REMOVED 20070904 PER PATCH BY WOLFRAM HUMANN
1380             my ($itemcnt) = $sll->index('end');
1381             $wheight = 10 unless ($wheight);
1382             $wheight = $itemcnt if ($itemcnt < $wheight);
1383             $wheight = $itemcnt unless ($wheight);
1384             $wheight = $itemcnt unless ($wheight || $itemcnt > 10);
1385             if ($wheight)
1386             {
1387             $sll->configure(-height => ($wheight * $w->height));
1388             $w->update;
1389             }
1390            
1391             my $y1 = $e->rooty + $e->height + 3;
1392             #my $bd = $c->cget(-bd) + $c->cget(-highlightthickness); #CHGD. TO NEXT 20050120.
1393             my $bd = $c->cget(-bd);
1394             my ($unitpixels, $ht, $x1, $ee, $width, $x2);
1395             if ($^O =~ /Win/i)
1396             {
1397             $y1 -= 3 - ($w->{-borderwidth} || 2);
1398             #$unitpixels = $e->height + 1; #CHGD. TO NEXT 20040827 - WINBLOWS XP SEEMS TO NOT BEVEL THE HIGHLIGHT CURSOR,
1399             $unitpixels = $e->height - 1; #SO THE WIDTH OF EACH ITEM IS NOW 2 PIXELS SMALLER! (USE OLD LINE, IF BEVELLED)!
1400             $ht = ($wheight * $unitpixels) + (2 * $bd) + 4;
1401             $ee = $w->Subwidget("frame");
1402             $x1 = $ee->rootx;
1403             $x2 = $a->rootx + $a->width;
1404             $width = $x2 - $x1;
1405             #$rw = $width + $w->{-borderwidth};
1406             #CHGD. TO NEXT 20030531 PER PATCH BY FRANK HERRMANN.
1407             $rw = ($width || 0) + ($w->{-borderwidth} || 0);
1408             $x1 += 1; #FUDGE MORE FOR WINDOWS (THINNER BORDER) TO MAKE DROPDOWN LINE UP VERTICALLY W/ENTRY&BUTTON.
1409             }
1410             else
1411             {
1412             $y1 -= 3 - ($w->{-borderwidth} || 2);
1413             #$unitpixels = $e->height - 1; #CHGD. TO NEXT 2 20050120.
1414             $unitpixels = $e->height - (2*$w->cget(-highlightthickness));
1415             $unitpixels += 1;
1416             $ht = ($wheight * $unitpixels) + (2 * $bd) + 6;
1417             $ee = $w->Subwidget("frame");
1418             $x1 = $ee->rootx;
1419             $x2 = $a->rootx + $a->width;
1420             $width = $x2 - $x1;
1421             # if ($rw < $width) #NEXT 10 LINES REPLACED BY FOLLOWING LINE 20020815.
1422             # {
1423             # $rw = $width;
1424             # }
1425             # else
1426             # {
1427             # $rw = $width * 3 if ($rw > $width * 3);
1428             # $rw = $w->vrootwidth if ($rw > $w->vrootwidth);
1429             # }
1430             # $width = $rw; #REMOVED 20020815 - UNNECESSARY!
1431             $rw = $width; #ADDED 20020815 TO CAUSE LISTBOX TO ADJUST WIDTH TO SAME AS VARYING ENTRY FIELD!
1432             # if ($first) -- REMOVED 20070904 PER PATCH BY WOLFRAM HUMANN
1433             {
1434             #NEXT LINE ADDED 20030531 PER PATCH BY FRANK HERRMANN.
1435             $w->{-borderwidth} = 0 unless(defined $w->{-borderwidth}); # XXX
1436             # $rw += 1 + int($w->{-borderwidth} / 2); -- CHGD. TO NEXT 20070904 - SEEMS TO WORK BETTER!
1437             $rw += $w->{-borderwidth};
1438             # $first = 0; -- REMOVED 20070904 PER PATCH BY WOLFRAM HUMANN
1439             #THANKS, WOLFRAM!
1440             }
1441            
1442             # IF LISTBOX IS TOO FAR RIGHT, PULL IT BACK TO THE LEFT
1443            
1444             if ($x2 > $w->vrootwidth)
1445             {
1446             $x1 = $w->vrootwidth - $width;
1447             }
1448             $x1 += 1; #FUDGE MORE FOR WINDOWS (THINNER BORDER) TO MAKE DROPDOWN LINE UP VERTICALLY W/ENTRY&BUTTON.
1449             }
1450            
1451             # IF LISTBOX IS TOO FAR LEFT, PULL IT BACK TO THE RIGHT
1452            
1453             if ($x1 < 0)
1454             {
1455             $x1 = 0;
1456             }
1457            
1458             # IF LISTBOX IS BELOW BOTTOM OF SCREEN, PULL IT UP.
1459            
1460             my $y2 = $y1 + $ht;
1461             if ($y2 > $w->vrootheight)
1462             {
1463             $y1 = $y1 - $ht - ($e->height - 5);
1464             }
1465             $c->geometry(sprintf("%dx%d+%d+%d", $rw, $ht, $x1, $y1));
1466             $c->deiconify;
1467             $c->raise;
1468             $w->focus;
1469             $w->{"popped"} = 1;
1470            
1471             &LbFindSelection;
1472             $c->configure(-cursor => "arrow");
1473             $w->grabGlobal;
1474             }
1475             }
1476            
1477             # CHOOSE VALUE FROM LISTBOX IF APPROPRIATE.
1478            
1479             sub LbChoose
1480             {
1481             my ($w, $x, $y) = @_;
1482             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
1483             $l->configure(-selectmode => 'browse');
1484             if ((($x < 0) || ($x > $l->Width)) ||
1485             (($y < 0) || ($y > $l->Height)))
1486             {
1487             # MOUSE WAS CLICKED OUTSIDE THE LISTBOX... CLOSE THE LISTBOX
1488             $w->LbClose;
1489             }
1490             else
1491             {
1492             # SELECT APPROPRIATE ENTRY AND CLOSE THE LISTBOX
1493             $w->LbCopySelection(0,'listbox.button1');
1494             }
1495             }
1496            
1497             # CLOSE THE LISTBOX AFTER CLEARING SELECTION.
1498            
1499             sub LbClose
1500             {
1501             my ($w) = @_;
1502             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
1503             $l->configure(-selectmode => 'browse');
1504             $l->selection("clear", 0, "end");
1505             $w->Popdown;
1506             }
1507            
1508             # COPY THE SELECTION TO THE ENTRY, AND CLOSE LISTBOX (UNLESS JUSTCOPY SET).
1509            
1510             sub LbCopySelection
1511             {
1512             my ($w, $justcopy, $action) = @_;
1513             my $index = $w->LbIndex;
1514             if (defined $index)
1515             {
1516             $w->{"curIndex"} = $index;
1517             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
1518             $l->configure(-selectmode => 'browse');
1519             my $var_ref = $w->cget( "-textvariable" );
1520             $$var_ref = $l->get($index);
1521             my $e = $w->Subwidget("entry");
1522             $e->icursor('end');
1523             }
1524             #$w->Popdown if ($w->{"popped"} && !$justcopy);
1525             if ($w->{"popped"} && !$justcopy)
1526             {
1527             my $altbinding = $w->{-altbinding};
1528             $w->Popdown;
1529             if ($altbinding =~ /NoListbox\=([^\;]+)/io) {
1530             my @noActions = split(/\,/o, $1);
1531             foreach my $i (@noActions) {
1532             return if ($i =~ /^$action$/io);
1533             }
1534             }
1535             $w->Callback(-browsecmd => $w, $w->Subwidget('entry')->get, $action);
1536             }
1537             }
1538            
1539             # GRAB TEXT TYPED IN AND FIND NEAREST ENTRY IN LISTBOX AND SELECT IT.
1540             # LETTERSEARCH SET MEANS SEARCH FOR *NEXT* MATCH OF SPECIFIED LETTER,
1541             # CLEARED MEANS SEARCH FOR *1ST* ITEM STARTING WITH CURRENT TEXT ENTRY VALUE.
1542            
1543             sub LbFindSelection
1544             {
1545             my ($w, $srchval) = @_;
1546            
1547             my $lettersearch = 0;
1548             if ($srchval)
1549             {
1550             $lettersearch = 1;
1551             }
1552             else
1553             {
1554             my $var_ref = $w->cget( "-textvariable" );
1555             # $srchval = $$var_ref; #CHGD. TO NEXT 20091019:
1556             $srchval = (defined($var_ref) && ref($var_ref) && defined($$var_ref))
1557             ? $$var_ref : '';
1558             }
1559             my $l = $w->Subwidget("slistbox")->Subwidget("listbox");
1560             $l->configure(-selectmode => 'browse');
1561             my (@listsels) = $l->get('0','end');
1562             unless ($lettersearch || !defined($srchval))
1563             {
1564             foreach my $i (0..$#listsels) #SEARCH FOR TRUE EQUALITY.
1565             {
1566             if ($listsels[$i] eq $srchval)
1567             {
1568             $l->selectionClear('0','end');
1569             $l->activate($i);
1570             $l->selectionSet($i);
1571             $l->update();
1572             $l->see($i);
1573             return 1;
1574             }
1575             }
1576             }
1577             my $index = $w->LbIndex; #ADDED 20020711 TO ALLOW WRAPPING IF SAME LETTER PRESSED AGAIN!
1578            
1579             foreach my $i (0..$#listsels) #SEARCH W/O REGARD TO CASE, START W/CURRENT SELECTION.
1580             {
1581             ++$index;
1582             $index = 0 if ($index > $#listsels);
1583             #if ($listsels[$index] =~ /^$srchval/i)
1584             #CHGD. TO NEXT 20030531 PER PATCH BY FRANK HERRMANN.
1585             # if (defined $srchval && $listsels[$index] =~ /^$srchval/i) #CHGD TO NEXT 20060429 TO PREVENT TK-ERROR ON "("!
1586             if (defined $srchval && $listsels[$index] =~ /^\Q$srchval\E/i)
1587             {
1588             $l->selectionClear('0','end');
1589             $l->activate($index);
1590             $l->selectionSet($index);
1591             $l->update();
1592             $l->see($index);
1593             return -1;
1594             }
1595             }
1596             return 0;
1597             }
1598            
1599             sub LbIndex
1600             {
1601             my ($w, $flag) = @_;
1602             my $sel = $w->Subwidget("slistbox")->Subwidget("listbox")->curselection
1603             || $w->Subwidget("slistbox")->Subwidget("listbox")->index('active');
1604             $sel = $w->Subwidget("slistbox")->Subwidget("listbox")->index('active')
1605             unless ($sel =~ /^\d+$/); #JWT: ADDED 20040819 'CAUSE CURSELECTION SEEMS TO RETURN "ARRAY(XXXX)" NOW?!?!?!
1606             if (defined $sel)
1607             {
1608             return int($sel);
1609             }
1610             else
1611             {
1612             if (defined $flag && ($flag eq "emptyOK"))
1613             {
1614             return undef;
1615             }
1616             else
1617             {
1618             return 0;
1619             }
1620             }
1621             }
1622            
1623             # POP DOWN THE LISTBOX
1624            
1625             sub Popdown
1626             {
1627             my ($w, $flag) = @_;
1628             my ($state) = $w->cget( "-state" );
1629             if ($w->{"popped"})
1630             {
1631             my $c = $w->Subwidget("choices");
1632             $c->withdraw;
1633             $w->grabRelease;
1634             $w->{"popped"} = 0;
1635             ########$w->Subwidget("entry")->focus; # unless ($flag);
1636             $w->Subwidget("entry")->selectionRange(0,'end')
1637             unless ($w->{-noselecttext} || !$w->Subwidget("entry")->index('end'));
1638             }
1639            
1640             if ($w->{'savefocus'} && Tk::Exists($w->{'savefocus'}))
1641             {
1642             $w->{'savefocus'}->focus;
1643             #delete $w->{'savefocus'};
1644             }
1645             else
1646             {
1647             $w->Subwidget("entry")->focus; # unless ($flag);
1648             }
1649             }
1650            
1651             # THIS HACK IS TO PREVENT THE UGLINESS OF THE ARROW BEING DEPRESSED.
1652            
1653             sub ButtonHack
1654             {
1655             my ($w) = @_;
1656             my $b = $w->Subwidget("arrow");
1657            
1658             #JWT: NEXT 6 LINES ADDED TO UNPOP MENU IF BUTTON PRESSED OUTSIDE OF LISTBOX.
1659            
1660             my $s = $w->Subwidget("slistbox");
1661             my $e = $s->XEvent;
1662             unless (defined($e))
1663             {
1664             $w->LbClose;
1665             }
1666            
1667             if ($w->{"buttonHack"})
1668             {
1669             $b->butUp;
1670             }
1671             }
1672            
1673             sub choices
1674             {
1675             my $w = shift;
1676             unless( @_ ) #NO ARGS, RETURN CURRENT CHOICES.
1677             {
1678             return( $w->Subwidget("slistbox")->get( qw/0 end/ ) );
1679             }
1680             else #POPULATE DROPDOWN LIST WITH THESE CHOICES.
1681             {
1682             my $choices = shift;
1683             if ($choices)
1684             {
1685             $w->delete( qw/0 end/ );
1686             $w->{hashref} = {} if (defined $w->{hashref}); #ADDED 20050125.
1687             $w->{hashref_bydesc} = {} if (defined $w->{hashref_bydesc}); #ADDED 20110226.
1688             $w->insert($choices);
1689             }
1690            
1691             #NO WIDTH SPECIFIED, CALCULATE TEXT & LIST WIDTH BASED ON LONGEST CHOICE.
1692            
1693             unless ($w->{-listwidth})
1694             {
1695             my @l = $w->Subwidget("slistbox")->get(0, 'end');
1696             my $width = 0;
1697             for (my $i=0;$i<=$#l;$i++)
1698             {
1699             $width = length($l[$i]) if ($width < length($l[$i]));
1700             }
1701             $width = $w->{-maxwidth} if ($width > $w->{-maxwidth} && $w->{-maxwidth} > 0);
1702             $w->Subwidget("entry")->configure(-width => $width);
1703             $w->Subwidget("choices")->configure(-width => $width);
1704             $w->Subwidget("slistbox")->configure(-width => $width);
1705             }
1706             $w->state($w->cget(-state));
1707             return( "" );
1708             }
1709             }
1710            
1711             # INSERT NEW ITEMS INTO DROPDOWN LIST.
1712            
1713             sub insert
1714             {
1715             my $w = shift;
1716             my ($pos);
1717             if ($_[1])
1718             {
1719             $pos = shift;
1720             }
1721             else
1722             {
1723             $pos = 'end';
1724             }
1725             #my $pos = shift || 'end'; #POSITION IN LIST TO INSERT.
1726             my $item = shift; #POINTER TO OR LIST OF ITEMS TO INSERT.
1727             my $res;
1728             if (ref($item))
1729             {
1730             if (ref($item) eq 'HASH')
1731             {
1732             my @choiceKeys = ();
1733             @choiceKeys = sort { $item->{$a} cmp $item->{$b} } keys(%$item);
1734             my @choiceVals = sort values(%$item);
1735             $w->Subwidget('slistbox')->insert($pos, @choiceVals);
1736             my $choiceHashRef = (defined $w->{hashref}) ? $w->{hashref}
1737             : {}; #ADDED 20050125.
1738             my $choiceReverseHashRef = (defined $w->{hashref_bydesc}) ? $w->{hashref_bydesc}
1739             : {}; #ADDED 20110226.
1740             for (my $i=0;$i<=$#choiceKeys;$i++) #ADDED 20050125.
1741             {
1742             $choiceHashRef->{$choiceKeys[$i]} = $choiceVals[$i];
1743             $choiceReverseHashRef->{$choiceVals[$i]} = $choiceKeys[$i];
1744             }
1745             $w->{hashref_bydesc} = $choiceReverseHashRef;
1746             $w->{hashref} = $choiceHashRef;
1747             }
1748             else
1749             {
1750             $res = $w->Subwidget("slistbox")->insert($pos, @$item);
1751             }
1752             }
1753             else
1754             {
1755             $res = $w->Subwidget("slistbox")->insert($pos, $item, @_);
1756             }
1757            
1758             #NO WIDTH SPECIFIED, (RE)CALCULATE TEXT & LIST WIDTH BASED ON LONGEST CHOICE.
1759            
1760             unless ($w->{-listwidth})
1761             {
1762             my @l = $w->Subwidget("slistbox")->get(0, 'end');
1763             my $width = 0;
1764             for (my $i=0;$i<=$#l;$i++)
1765             {
1766             $width = length($l[$i]) if ($width < length($l[$i]));
1767             }
1768             $width = $w->{-maxwidth} if ($width > $w->{-maxwidth} && $w->{-maxwidth} > 0);
1769             $w->Subwidget("entry")->configure(-width => $width);
1770             $w->Subwidget("choices")->configure(-width => $width);
1771             $w->Subwidget("slistbox")->configure(-width => $width);
1772             }
1773             $w->state($w->state());
1774             return $res;
1775             }
1776            
1777             sub delete
1778             {
1779             my $w = shift;
1780             if (defined $w->{hashref}) #ADDED 20050125.
1781             {
1782             my ($key, $val);
1783             foreach my $i (@_)
1784             {
1785             $val = $w->get($i);
1786             $key = $w->{hashref_bydesc}->{$val};
1787             #print "*** DELETE: i=$i= val=$val= key=$key= 1=".$w->{hashref_bydesc}->{$val}."= 2=".$w->{hashref}->{$key}."=\n";
1788             next unless ($val);
1789             delete $w->{hashref_bydesc}->{$val} if (defined $w->{hashref_bydesc}->{$val});
1790             delete $w->{hashref}->{$key} if (defined $w->{hashref}->{$key});
1791             }
1792             }
1793             my $res = $w->Subwidget("slistbox")->delete(@_);
1794             unless ($w->Subwidget("slistbox")->size > 0 || $w->{mylistcmd})
1795             {
1796             my $button = $w->Subwidget( "arrow" );
1797             $button->configure( -state => "disabled", -takefocus => 0);
1798             }
1799             return $res;
1800             }
1801            
1802             sub delete_byvalue
1803             {
1804             my $w = shift;
1805             return undef unless (@_);
1806            
1807             my @keys = $w->get(0, 'end');
1808             my $v;
1809             my $delThisValue;
1810             my $delCnt = 0;
1811             while (@_)
1812             {
1813             $delThisValue = shift;
1814             if (defined $w->{hashref}) #ADDED 20050125.
1815             {
1816             for (my $k=0;$k<=$#keys;$k++)
1817             {
1818             if ($keys[$k] eq $delThisValue)
1819             {
1820             $v = $w->{hashref_bydesc}->{$keys[$k]};
1821             delete $w->{hashref_bydesc}->{$keys[$k]} if (defined $w->{hashref_bydesc}->{$keys[$k]});
1822             delete $w->{hashref}->{$v} if (defined $w->{hashref}->{$v});
1823             $w->Subwidget("slistbox")->delete($k);
1824             #print "-!!!- deleting k=$k= v=$v= keys=$keys[$k]=\n";
1825             $delCnt++;
1826             last;
1827             }
1828             }
1829             }
1830             }
1831             return $delCnt;
1832             }
1833            
1834             sub curselection #RETURN CURRENT LISTBOX SELECTION.
1835             {
1836             return shift->Subwidget("slistbox")->curselection;
1837             }
1838            
1839             # CHANGE APPEARANCES BASED ON CHANGES IN "-STATE" OPTION.
1840            
1841             sub _set_edit_state
1842             {
1843             my( $w, $state ) = @_;
1844             $state ||= 'normal'; #JWT: HAD TO ADD THIS IN TK804...
1845             my $entry = $w->Subwidget( "entry" );
1846             my $frame = $w->Subwidget( "frame" );
1847             my $button = $w->Subwidget( "arrow" );
1848             my ($color, $txtcolor, $framehlcolor, $texthlcolor); # MAKE ENTRY FIELDS LOOK WINDOSEY!
1849            
1850             unless ($w->{-background})
1851             {
1852             if ($^O =~ /Win/i) # SET BACKGROUND TO WINDOWS DEFAULTS (IF NOT SPECIFIED)
1853             {
1854             #if ($state eq 'disabled' || $state eq 'readonly')
1855             if ($state eq 'disabled')
1856             {
1857             $color = "SystemButtonFace";
1858             }
1859             else
1860             {# Not Editable
1861             $color = $w->cget( -background );
1862             $color = 'SystemWindow' if ($color eq 'SystemButtonFace');
1863             }
1864             $entry->configure( -background => $color );
1865             }
1866             else #UNIX.
1867             {
1868             #THIS APPEARS TO FORCE THE TEXT BACKGROUND TO GREY, IF THE PALETTE
1869             #IS SOMETHING ELSE BUT USER HAS NOT SPECIFIED A BACKGROUND.
1870             if ($w->cget( "-colorstate" )) #NOT SURE WHAT POINT OF THIS IS.
1871             {
1872             if( $state eq "normal" || $state =~ /text/ )
1873             {# Editable
1874             $color = "gray95";
1875             }
1876             else
1877             {# Not Editable
1878             $color = $w->cget( -background ) || "lightgray";
1879             }
1880             $entry->configure( -background => $color);
1881             }
1882             }
1883             }
1884            
1885             $txtcolor = $w->{-foreground} || $w->cget( -foreground ) unless ($state eq "disabled");
1886             $texthlcolor = $w->{-background} || $entry->cget( -background );
1887             $framehlcolor = $w->{-foreground} || $entry->cget( -foreground );
1888             if( $state eq "readonly" )
1889             {
1890             $framehlcolor = $w->{-foreground} || $entry->cget( -foreground );
1891             $entry->configure( -state => "disabled", -takefocus => 0,
1892             -foreground => $txtcolor, -highlightcolor => $texthlcolor);
1893             if ($^O =~ /Win/i)
1894             {
1895             $button->configure( -state => "normal", -takefocus => $w->{btntakesfocus}, -relief => 'raised');
1896             $frame->configure(-relief => ($w->{-relief} || 'groove'),
1897             -takefocus => (1 & $w->{takefocus}), -highlightcolor => $framehlcolor);
1898             }
1899             else
1900             {
1901             $button->configure( -state => "normal", -takefocus => $w->{btntakesfocus}, -relief => 'raised');
1902             $frame->configure(-relief => ($w->{-relief} || 'raised'),
1903             -takefocus => (1 & $w->{takefocus}), -highlightcolor => $framehlcolor);
1904             }
1905             }
1906             elsif ($state =~ /text/ )
1907             {
1908             $framehlcolor = $w->{-background} || 'SystemButtonFace'
1909             if ($^O =~ /Win/i);
1910             $button->configure( -state => "disabled", -takefocus => 0,
1911             -relief => 'flat');
1912             $frame->configure(-relief => ($w->{-relief} || 'sunken'),
1913             -takefocus => 0, -highlightcolor => $framehlcolor);
1914             $entry->configure( -state => 'normal',
1915             -takefocus => (1 & ($w->{takefocus} || $w->{btntakesfocus})),
1916             -foreground => $txtcolor, -highlightcolor => $texthlcolor);
1917             }
1918             elsif ($state eq "disabled" )
1919             {
1920             $entry->configure( -state => "disabled", -takefocus => 0,
1921             -foreground => ($button->cget('-disabledforeground')||'gray30'), -highlightcolor => $texthlcolor);
1922             #-foreground => 'gray30', -highlightcolor => $texthlcolor);
1923             if ($^O =~ /Win/i)
1924             {
1925             $framehlcolor = $w->{-background} || 'SystemButtonFace';
1926             $button->configure(-state => "disabled", -takefocus => 0,
1927             -relief => 'flat');
1928             $frame->configure(-relief => ($w->{-relief} || 'sunken'),
1929             -takefocus => 0, -highlightcolor => $framehlcolor);
1930             }
1931             else
1932             {
1933             $frame->configure(-relief => ($w->{-relief} || 'groove'),
1934             -takefocus => 0, -highlightcolor => $framehlcolor);
1935             }
1936             $button->configure(-state => "disabled", -takefocus => 0,
1937             -relief => 'raised');
1938             }
1939             else #NORMAL.
1940             {
1941             $framehlcolor = $w->{-background} || 'SystemButtonFace'
1942             if ($^O =~ /Win/i);
1943             #$entry->configure( -state => $state, -takefocus => (1 & $w->{takefocus}),
1944             $entry->configure( -state => $state, -takefocus => 0,
1945             -foreground => $txtcolor, -highlightcolor => $texthlcolor);
1946             $button->configure( -state => $state, -relief => 'raised',
1947             -takefocus => $w->{btntakesfocus});
1948             $frame->configure(-relief => ($w->{-relief} || 'sunken'),
1949             -takefocus => (1 & $w->{takefocus}),
1950             -highlightcolor => $framehlcolor);
1951             }
1952             $entry->configure( -background => $w->{-textbackground}) if ($w->{-textbackground});
1953             $entry->configure( -foreground => $w->{-textforeground}) if ($w->{-textforeground});
1954             #print "-???- listcmd=".$w->{mylistcmd}."=\n";
1955             unless ($w->Subwidget("slistbox")->size > 0 || $w->{mylistcmd})
1956             {
1957             $button->configure( -state => "disabled", -takefocus => 0);
1958             }
1959             }
1960            
1961             sub state
1962             {
1963             my $w = shift;
1964             unless( @_ )
1965             {
1966             return( $w->{Configure}{-state} );
1967             }
1968             else
1969             {
1970             my $state = shift;
1971             $w->{Configure}{-state} = $state;
1972             $w->_set_edit_state( $state );
1973             }
1974             }
1975            
1976             sub _max
1977             {
1978             my $max = shift;
1979             foreach my $val (@_)
1980             {
1981             $max = $val if $max < $val;
1982             }
1983             return( $max );
1984             }
1985            
1986             sub dereference #USER-CALLABLE FUNCTION, ADDED 20050125.
1987             {
1988             my $w = shift;
1989             return undef unless (defined $_[0]);
1990             my $userValue = shift;
1991             return (defined($w->{hashref_bydesc}) && defined($w->{hashref_bydesc}->{$userValue}))
1992             ? $w->{hashref_bydesc}->{$userValue} : $userValue;
1993             }
1994            
1995             sub dereferenceOnly #USER-CALLABLE FUNCTION, ADDED 20050125.
1996             {
1997             my $w = shift;
1998             return undef unless (defined $_[0]);
1999             my $userValue = shift;
2000             return (defined($w->{hashref_bydesc}) && defined($w->{hashref_bydesc}->{$userValue}))
2001             ? $w->{hashref_bydesc}->{$userValue} : undef;
2002             }
2003            
2004             sub reference #USER-CALLABLE FUNCTION, ADDED 20110227, v. 4.8:
2005             {
2006             my $w = shift;
2007             return undef unless (defined $_[0]);
2008             my $userValue = shift;
2009             return (defined($w->{hashref}) && defined($w->{hashref}->{$userValue}))
2010             ? $w->{hashref}->{$userValue} : '';
2011             }
2012            
2013             sub hasreference #USER-CALLABLE FUNCTION, ADDED 20050125.
2014             {
2015             my $w = shift;
2016             return undef unless (defined $_[0]);
2017             my $userValue = shift;
2018             return (defined($w->{hashref_bydesc}) && defined($w->{hashref_bydesc}->{$userValue}))
2019             ? 1 : undef;
2020             }
2021            
2022             sub get_hashref_byname #USER-CALLABLE FUNCTION, ADDED 20110227, v. 4.8:
2023             {
2024             my $w = shift;
2025             return (defined $w->{hashref_bydesc}) ? $w->{hashref_bydesc} : undef;
2026             }
2027            
2028             sub fetchhash #DEPRECIATED, RENAMED get_hashref_byname():
2029             {
2030             my $w = shift;
2031             return $w->get_hashref_byname;
2032             }
2033            
2034             sub get_hashref_byvalue #USER-CALLABLE FUNCTION, ADDED 20110227, v. 4.8:
2035             {
2036             my $w = shift;
2037             return (defined $w->{hashref}) ? $w->{hashref} : undef;
2038             }
2039            
2040             sub get #USER-CALLABLE FUNCTION, ADDED 20090210 v4.72
2041             {
2042             my $w = shift;
2043             if ( @_ ) #NO ARGS, RETURN CURRENT CHOICES.
2044             {
2045             return $w->Subwidget("slistbox")->get( @_ );
2046             }
2047             else #RETURN CHOICES:
2048             {
2049             my $var_ref = $w->cget( "-textvariable" );
2050             return $$var_ref;
2051             }
2052             }
2053            
2054             sub get_index #USER-CALLABLE FUNCTION, ADDED 20110227, v. 4.8:
2055             {
2056             my $w = shift;
2057             return undef unless (@_);
2058             my $val = shift;
2059             my @keys = $w->get(0, 'end');
2060             for (my $k=0;$k<=$#keys;$k++)
2061             {
2062             return $k if ($keys[$k] eq $val);
2063             }
2064             return undef;
2065             }
2066            
2067             sub activate #USER-CALLABLE FUNCTION, ADDED 20090210 v4.72
2068             {
2069             my $w = shift;
2070             my $indx = shift;
2071             my $initx = shift || 1;
2072             my $res = $w->Subwidget("slistbox")->Subwidget("listbox")->activate($indx);
2073             if ($initx)
2074             {
2075             my $var_ref = $w->cget( "-textvariable" );
2076             $$var_ref = $w->Subwidget("slistbox")->Subwidget("listbox")->get($indx);
2077             }
2078             return $res;
2079             }
2080            
2081             sub index
2082             {
2083             my $w = shift;
2084             return $w->Subwidget("slistbox")->Subwidget("listbox")->index(@_);
2085             }
2086            
2087             sub size
2088             {
2089             my $w = shift;
2090             return $w->Subwidget("slistbox")->Subwidget("listbox")->size(@_);
2091             }
2092            
2093             1
2094            
2095             __END__