File Coverage

blib/lib/Tk/JDialog.pm
Criterion Covered Total %
statement 12 14 85.7
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 17 19 89.4


line stmt bran cond sub pod time code
1             package Tk::JDialog;
2              
3 1     1   20779 use 5.006;
  1         4  
4 1     1   5 use strict;
  1         2  
  1         19  
5 1     1   5 use warnings;
  1         10  
  1         98  
6              
7             =head1 NAME
8              
9             Tk::JDialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on John Stoffel's idea).
10              
11             =head1 VERSION
12              
13             Version 1.01
14              
15             =cut
16              
17             our $VERSION = '1.1';
18              
19              
20             =head1 SYNOPSIS
21              
22             use Tk::JDialog;
23              
24             my $Dialog = $mw->JDialog( -option => value, ... );
25             ...
26             my $button_label = $Dialog->Show;
27              
28             =head1 DESCRIPTION
29              
30             This is an OO implementation of `tk_dialog'. First, create all your Dialog
31             objects during program initialization. When it's time to use a dialog,
32             invoke the `show' method on a dialog object; the method then displays
33             the dialog, waits for a button to be invoked, and returns the text
34             label of the selected button.
35              
36             A Dialog object essentially consists of two subwidgets: a Label widget for
37             the bitmap and a Label wigdet for the text of the dialog. If required, you
38             can invoke the `configure' method to change any characteristic of these
39             subwidgets.
40              
41             Because a Dialog object is a Toplevel widget all the 'composite' base class
42             methods are available to you.
43              
44             =head1 EXAMPLE
45              
46             #!/usr/bin/perl
47              
48             use Tk::JDialog;
49              
50             my $mw = MainWindow->new;
51             my $Dialog = $mw->JDialog(
52             -title => 'Choose!', #DISPLAY A WINDOW TITLE
53             -text => 'Press Ok to Continue', #DISPLAY A CAPTION
54             -bitmap => 'info', #DISPLAY BUILT-IN info BITMAP.
55             -default_button => '~Ok',
56             -escape_button => '~Cancel',
57             -buttons => ['~Ok', '~Cancel', '~Quit'], #DISPLAY 3 BUTTONS
58             -images => ['/tmp/ok.xpm', '', ''], #EXAMPLE WITH IMAGE FILE
59             );
60             my $button_label = $Dialog->Show( );
61             print "..You pressed [$button_label]!\n";
62             exit(0);
63              
64             =head1 OPTIONS
65              
66             =over 4
67              
68             =item -title
69              
70             (string) - Title to display in the dialog's decorative window frame.
71             Default: ''.
72              
73             =item -text
74              
75             (string) - Message to display in the dialog widget. Default: ''.
76              
77             =item -bitmap
78              
79             (string) - Bitmap to display in the dialog.
80             If non-empty, specifies a bitmap to display in the top portion of
81             the Dialog, to the left of the text. If this is an empty string
82             then no bitmap is displayed in the Dialog.
83             There are several built-in Tk bitmaps: 'error', 'hourglass', 'info',
84             'questhead', 'question', 'warning', 'Tk', and 'transparent'.
85             You can also use a bitmap file name, ie. '@/path/to/my/bitmap'
86             Default: ''.
87              
88             =item -default_button
89              
90             (string) - Text label of the button that is to display the
91             default border and is to be selected if the user presses [Enter].
92             (''signifies no default button). Default: ''.
93              
94             =item -escape_button
95              
96             (string) - Text label of the button that is to be invoked when the
97             user presses the key. Default: ''.
98              
99             =item -button_labels
100              
101             (Reference) - A reference to a list of one or more strings to
102             display in buttons across the bottom of the dialog. These strings
103             (labels) are also returned by the Show() method corresponding to
104             the button selected. NOTE: A tilde ("~") can be placed before a
105             letter in a label string to indicate the > that
106             the user can also press to select the button, for example:
107             "~Ok" means select this button if the user presses >.
108             The tilde is not displayed for the button text. The text is also
109             not displayed if an image file is specified in the corresponding
110             optional -images array, but is returned if the button is pressed.
111             If this option is not given, a single button labeled "OK" is created.
112              
113             =item -images
114              
115             (Reference) - Specify the optional path and file id for an image
116             for each button to display an image in lieu of the label text
117             ('' if a corresponding button is to use text). NOTE: button
118             will use text if the image file is not found. Also the
119             "-button_labels" option MUST ALWAYS be specified anyway to provide
120             the required return string.
121              
122             =item -noballoons
123              
124             (boolean) - if true (1) then no balloon displaying the "button_labels"
125             label text value will be displayed when the mouse hovers over the
126             corresponding buttons which display imiages. If false (0), then
127             text balloons will be displayed when hovering. Default: 0.
128              
129             =back
130              
131             =head1 METHODS
132              
133             =over 4
134              
135             =item Show ( [ -global | -nograb ] )
136              
137             $answer = $dialog->B( [ -global | -nograb ] );
138              
139             This method displays the Dialog box, waits for the user's response, and
140             stores the text string of the selected Button in $answer. This allows
141             the programmer to determine which button the user selected.
142            
143             NOTE: Execution goes into a wait-loop here until the the user makes a
144             selection!
145            
146             If -global is specified a global (rather than local) grab is
147             performed (No other window or widget can be minipulated via the keyboard
148             or mouse until a button is selected) making the dialog "modal".
149             Default: "-nograb" (the dialog is "non-modal" while awaiting input).
150              
151             The actual Dialog is shown using the Popup method. Any other
152             options supplied to Show are passed to Popup, and can be used to
153             position the Dialog on the screen. Please read L for
154             details.
155              
156             =item Populate ( -option => value, ... )
157              
158             (Constructor) - my $Dialog = $mw->JDialog( -option => value, ... );
159              
160             =back
161              
162             =head1 ADVERTISED WIDGETS
163              
164             Tk::JDialog inherits all the Tk::Dialog exposed widgets and methods plus
165             the following two subwidgets:
166            
167             =over 4
168              
169             =item message
170              
171             The dialog's Label widget containing the message text.
172            
173             =item bitmap
174              
175             The dialog's Label widget containing the bitmap image.
176              
177             =back
178              
179             =head1 AUTHOR
180              
181             Jim Turner, C<< >>
182              
183             =head1 BUGS
184              
185             Please report any bugs or feature requests to C, or through
186             the web interface at L. I will be notified,
187             and then you'll automatically be notified of progress on your bug as I make changes.
188              
189             =head1 SUPPORT
190              
191             You can find documentation for this module with the perldoc command.
192              
193             perldoc Tk::JDialog
194              
195              
196             You can also look for information at:
197              
198             =over 4
199              
200             =item * RT: CPAN's request tracker (report bugs here)
201              
202             L
203              
204             =item * AnnoCPAN: Annotated CPAN documentation
205              
206             L
207              
208             =item * CPAN Ratings
209              
210             L
211              
212             =item * Search CPAN
213              
214             L
215              
216             =back
217              
218              
219             =head1 ACKNOWLEDGEMENTS
220              
221             Tk::JDialog derived from the L wiget from Tcl/Tk to TkPerl (based on
222             John Stoffel's idea). It addes the options: -escape_button, images,
223              
224             =head1 LICENSE AND COPYRIGHT
225              
226             Copyright 2015 Jim Turner.
227              
228             This program is free software; you can redistribute it and/or
229             modify it under the terms of the GNU Lesser General Public
230             License as published by the Free Software Foundation; either
231             version 2.1 of the License, or (at your option) any later version.
232              
233             This program is distributed in the hope that it will be useful,
234             but WITHOUT ANY WARRANTY; without even the implied warranty of
235             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
236             Lesser General Public License for more details.
237              
238             You should have received a copy of the GNU Lesser General Public
239             License along with this program; if not, write to the Free
240             Software Foundation, Inc.,
241             51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
242              
243             =head1 SEE ALSO
244              
245             L, L, L, L
246              
247             =cut
248              
249             # JDialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on
250             # John Stoffel's idea).
251             #
252             # Modified 2/13/97 by Jim Turner of Computer Sciences Corporation to
253             # add underline character (alt-key) activation of buttons, fix bug in the
254             # bindings for key where default button always activated even if
255             # another button had the keyboard focus. Now, the default button starts
256             # with the input focus!!!
257             #
258             # Jim Turner also added the "escape_button" option on 2/14/97 to allow
259             # programmer to specify a button to invoke if user presses the key!
260             # Jim Turner also added the "images" option on 2/14/97 to allow programmer
261             # to specify gifs in leu of text for the buttons.
262             #
263             # Jim Turner also removed the "wraplength" option on 2/19/97 to allow
264             # longer label strings (>3") to not be broken. User can specify -wraplength!
265             # Stephen O. Lidie, Lehigh University Computing Center. 94/12/27
266             # lusol@Lehigh.EDU
267             #
268             # 04/22/97 Jim Turner fixed bug where screen completely locks up if the calling
269             # script invokes a Motif app (ie. xv or another Perl/Tk app) shortly after
270             # calling this dialog box. Did not seem to adversely effect keyboard focus.
271             # fixed by commenting out 1 line of code (&$old_focus);
272             #
273             # This is an OO implementation of `tk_dialog'. First, create all your Dialog
274             # objects during program initialization. When it's time to use a dialog,
275             # invoke the `show' method on a dialog object; the method then displays the
276             # dialog, waits for a button to be invoked, and returns the text label of the
277             # selected button.
278             #
279             # A Dialog object essentially consists of two subwidgets: a Label widget for
280             # the bitmap and a Label wigdet for the text of the dialog. If required, you
281             # can invoke the `configure' method to change any characteristic of these
282             # subwidgets.
283             #
284             # Because a Dialog object is a Toplevel widget all the 'composite' base class
285             # methods are available to you.
286              
287 1     1   4 use Carp;
  1         1  
  1         92  
288             #use strict qw(vars);
289             our $useBalloon;
290 1     1   524 use Tk ":eventtypes";
  0            
  0            
291             use Tk::Balloon; $useBalloon = 1;
292             require Tk::Toplevel;
293              
294             @Tk::JDialog::ISA = qw(Tk::Toplevel);
295              
296             Tk::Widget->Construct('JDialog');
297              
298             sub Populate
299             {
300             # Dialog object constructor. Uses `new' method from base class
301             # to create object container then creates the dialog toplevel.
302              
303             my($cw, $args) = @_;
304              
305             $cw->SUPER::Populate($args);
306              
307             my ($w_bitmap,$w_but,$pad1,$pad2,$underlinepos,$mychar,$blshow,$i);
308             my ($btnopt,$undopt,$balloon);
309              
310             my $buttons = delete $args->{'-buttons'};
311             my $images = delete $args->{'-images'};
312             $buttons = ['OK'] unless (defined $buttons);
313             my $default_button = delete $args->{-default_button};
314             my $escape_button = delete $args->{-escape_button};
315             my $noballoons = delete $args->{-noballoons};
316             $useBalloon = 0 if ($noballoons);
317             $default_button = $buttons->[0] unless (defined $default_button);
318              
319             # Create the Toplevel window and divide it into top and bottom parts.
320              
321             $cw->{'selected_button'} = '';
322             my (@pl) = (-side => 'top', -fill => 'both');
323             ($pad1, $pad2) =
324             ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']);
325              
326             $cw->withdraw;
327             $cw->iconname('JDialog');
328             $cw->protocol('WM_DELETE_WINDOW' => sub {});
329             #????????????????? $cw->transient($cw->toplevel) unless ($^O =~ /Win/i);
330              
331             my $w_top = $cw->Frame(Name => 'top',-relief => 'raised', -borderwidth => 1);
332             my $w_bot = $cw->Frame(Name => 'bot',-relief => 'raised', -borderwidth => 1);
333             $w_top->pack(@pl);
334             $w_bot->pack(@pl);
335              
336             # Fill the top part with the bitmap and message.
337              
338             @pl = (-side => 'left');
339              
340             $w_bitmap = $w_top->Label(Name => 'bitmap');
341             $w_bitmap->pack(@pl, @$pad1);
342             my $w_msg = $w_top->Label(
343             #-wraplength => '3i', --!!! Removed 2/19 by Jim Turner
344             -justify => 'left'
345             );
346              
347             $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1);
348              
349             # Create a row of buttons at the bottom of the dialog.
350              
351             my ($w_default_button, $bl) = (undef, '');
352             $cw->{'default_button'} = undef;
353             $cw->{'escape_button'} = undef;
354             $i = 0;
355             foreach $bl (@$buttons) {
356             $blshow = $bl;
357             $underlinepos = ($blshow =~ s/^(.*)~/$1/) ? length($1): undef;
358             if (defined($$images[$i]) && $$images[$i] gt ' ' && -e $$images[$i]) {
359             $cw->Photo($blshow, -file => $$images[$i]);
360             $btnopt = '-image';
361             } else {
362             $btnopt = '-text';
363             }
364             if (defined($underlinepos)) {
365             $mychar = substr($blshow,$underlinepos,1);
366             $w_but = $w_bot->Button(
367             $btnopt => $blshow,
368             -underline => $underlinepos,
369             -command => [
370             sub {
371             $_[0]->{'selected_button'} = $_[1];
372             }, $cw, $bl,
373             ]
374             );
375             $cw->bind("", [$w_but => "Invoke"]);
376             $cw->bind("", [$w_but => "Invoke"]);
377             } else {
378             $w_but = $w_bot->Button(
379             $btnopt => $blshow,
380             -command => [
381             sub {
382             $_[0]->{'selected_button'} = $_[1];
383             }, $cw, $bl,
384             ]
385             );
386             }
387             if ($useBalloon && $btnopt eq '-image') {
388            
389             $balloon = $cw->Balloon();
390             $balloon->attach($w_but, -state => 'balloon', -balloonmsg => $blshow);
391             }
392             if ($bl eq $default_button) {
393             $w_default_button = $w_bot->Frame(
394             -relief => 'sunken',
395             -borderwidth => 1
396             );
397             $w_but->raise($w_default_button);
398             $w_default_button->pack(@pl, -expand => 1, @$pad2);
399             $w_but->pack(-in => $w_default_button, -padx => '2m',
400             -pady => '2m'
401             );
402              
403             $cw->{'default_button'} = $w_but;
404             goto JWT_SKIP1;
405             $cw->bind(
406             '' => [
407             sub {
408             $_[1]->flash;
409             $_[2]->{'selected_button'} = $_[3];
410             }, $w_but, $cw, $bl,
411             ]
412             );
413             JWT_SKIP1:
414             } else {
415             $w_but->pack(@pl, -expand => 1, @$pad2);
416             $cw->{'default_button'} = $w_but unless(defined($cw->{'default_button'}));
417             }
418             if ($bl eq $escape_button) {
419             $cw->{'escape_button'} = $w_but;
420             $cw->bind('' => [$w_but => "Invoke"]);
421             }
422             ++$i;
423             } # end for all buttons
424              
425             $cw->Advertise(message => $w_msg);
426             $cw->Advertise(bitmap => $w_bitmap );
427             #!!!$cw->{'default_button'} = $w_default_button;
428             if ($^O =~ /Win/i) {
429             $cw->ConfigSpecs(
430             -image => ['bitmap',undef,undef,undef],
431             -bitmap => ['bitmap',undef,undef,undef],
432             -fg => ['ADVERTISED','foreground','Foreground','black'],
433             -foreground => ['ADVERTISED','foreground','Foreground','black'],
434             -bg => ['DESCENDANTS','background','Background',undef],
435             -background => ['DESCENDANTS','background','Background',undef],
436             DEFAULT => ['message',undef,undef,undef]
437             );
438             } else {
439             $cw->ConfigSpecs(
440             -image => ['bitmap',undef,undef,undef],
441             -bitmap => ['bitmap',undef,undef,undef],
442             -fg => ['ADVERTISED','foreground','Foreground','black'],
443             -foreground => ['ADVERTISED','foreground','Foreground','black'],
444             -bg => ['DESCENDANTS','background','Background',undef],
445             -background => ['DESCENDANTS','background','Background',undef],
446             # JWT for TNT! -font => ['message','font','Font','-*-Times-Medium-R-Normal-*-180-*-*-*-*-*-*'],
447             -font => ['message','font','Font','-adobe-helvetica-bold-r-normal--17-120-100-100-p-92-iso8859-1'],
448             DEFAULT => ['message',undef,undef,undef]
449             );
450             }
451             } # end Dialog constructor
452              
453             sub Show { # Dialog object public method - display the dialog.
454              
455             my ($cw, $grab_type) = @_;
456              
457             croak "Dialog: `show' method requires at least 1 argument"
458             if scalar @_ < 1 ;
459              
460             my $old_focus = $cw->focusSave; # don't need (Jim Turner) after fixing BUG!
461             my $old_grab = $cw->grabSave;
462              
463             # Update all geometry information, center the dialog in the display
464             # and deiconify it
465              
466             $cw->Popup();
467              
468             # set a grab and claim the focus.
469             if (defined $cw->{'default_button'}) {
470             $cw->{'default_button'}->focus;
471             } else {
472             $cw->focus;
473             }
474             unless (!defined($ENV{DESKTOP_SESSION}) || $ENV{DESKTOP_SESSION} =~ /kde/o) {
475             if ($ENV{DESKTOP_SESSION} =~ /AfterStep version 2.2.1[2-9]/io) { #JWT:ADDED 20140606 B/C TO GET AFTERSTEP TO GIVE "TRANSIENT" WINDOWS THE FOCUS?!
476             Tk::Event::DoOneEvent(ALL_EVENTS);
477             select(undef, undef, undef, 0.25); #FANCY QUICK-NAP FUNCTION!
478             }
479             if (defined $grab_type && length $grab_type) {
480             $cw->grab($grab_type) if ($grab_type !~ /no/io); #JWT: ADDED 20010517 TO ALLOW NON-GRABBING!
481             } else {
482             $cw->grab;
483             }
484             }
485             ############## $cw->waitVisibility; #SEEMS TO HANG ON NEWER TK'S.
486             $cw->update;
487              
488             # Wait for the user to respond, restore the focus and grab, withdraw
489             # the dialog and return the label of the selected button.
490              
491             $cw->waitVariable(\$cw->{'selected_button'});
492             $cw->grabRelease;
493             $cw->withdraw;
494             &$old_focus if (defined($ENV{DESKTOP_SESSION}) && $ENV{DESKTOP_SESSION} =~ /AfterStep version 2.2.1[2-9]/io); #FIXED BUG CAUSING COMPLETE SCREEN LOCKUP IF ANOTHER
495             #MOTIF APP (WINDOW) IS POPPED UP SHORTLY AFTERWARDS!
496             &$old_grab;
497             return $cw->{'selected_button'};
498              
499             } # end Dialog show method
500              
501             1; # End of Tk::JDialog