(Auto)Timeout option for Tk::DialogBox
[email protected] Wed, 30 May 2007 18:55:36 +0200
| Newsgroups | gmane.comp.lang.perl.tk |
|---|---|
| Message-ID | <[email protected]> |
Hi, i'd like to propose/submit a patch for Dialogbox.pm Reason: a) If using the DialogBox for low-prio infos in an application where there are a lot of different parallel open windows, user sometimes shuffled the normal DBox somewhere in the background and since they did not close the box correctly the app seems to hang b) If the App shall show some transient information (which is only a short time relevant) and a Dialogbox shall be shown to draw users interest Function: The attached patch for the DialogBox will make it either wait for the user to press any of the available buttons as before or after reaching an optional timeout-time the box will silently withdraw by simulating a pressed default button. Please feel free to apply this patch into the current Tk svn repository and/or let me have some feedback. Regards, Michael. -- GMX FreeMail: 1 GB Postfach, 5 E-Mail-Adressen, 10 Free SMS. Alle Infos und kostenlose Anmeldung: http://www.gmx.net/de/go/freemail --++**==--++**==--++**==--++**==--++**==--++**==--++**== ptk mailing list [email protected] https://mailman.stanford.edu/mailman/listinfo/ptk
DialogBox.pm.diff
(text/x-patch, 2.5 KB)
--- /appl/openpkg/lib/perl/site_perl/5.8.8/x86_64-linux/Tk/DialogBox.pm 2003-11-29 14:02:50.000000000 +0100
+++ ./DialogBox.pm 2007-05-09 12:53:54.743842000 +0200
@@ -18,6 +18,14 @@
sub Populate {
my ($cw, $args) = @_;
+ ################################################
+ # Auto-TimeOut Add-On I
+ my $timeout_time = delete $args->{'-timeout_time'} || delete $args->{'-timeout'};
+ my $timeout_text = delete $args->{'-timeout_text'};
+ my $timeout_bcol = delete $args->{'-timeout_background'};
+ my $timeout_font = delete $args->{'-timeout_font'};
+ ################################################
+
$cw->SUPER::Populate($args);
my $buttons = delete $args->{'-buttons'};
$buttons = ['OK'] unless defined $buttons;
@@ -41,6 +49,18 @@
$bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/);
$top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/);
+ ################################################
+ # Auto-TimeOut Add-On II
+ if ($timeout_time) {
+ $cw->{'time_out'} = $timeout_time;
+ $bot->Label(
+ -text => $timeout_text ? $timeout_text : "*** NOTE: This dialog will be AUTO-answered with [" . $default_button. '] after ' .$cw->{'time_out'} . ' seconds! ***',
+ -font => $timeout_font ? $timeout_font : 'Helvetica 7',
+ -background => $timeout_bcol ? $timeout_bcol : 'gold',
+ )->pack(qw/-side top -fill x/);
+ }
+ ################################################
+
# create a row of buttons in the bottom.
my $bl; # foreach my $var: perl > 5.003_08
foreach $bl (@$buttons)
@@ -87,7 +107,26 @@
{
my $cw = shift;
$cw->Callback(-showcommand => $cw);
+
+ ################################################
+ # Auto-TimeOut Add-On III
+ if ($cw->{'time_out'}) {
+ use Tie::Watch;
+ my ($millis, $tid, $watch, $why);
+ $millis = $cw->{'time_out'} * 1000;
+ $watch = Tie::Watch->new(-variable => \$cw->{'selected_button'},
+ -store => sub { my($self, $new_val) = @_; $self->Store(uc $new_val); $why = 1 }
+ );
+ $tid = $cw->after($millis => sub {$why = 2; $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text)}) unless $millis == 0;
+ $cw->waitVariable(\$why);
+ $watch->Unwatch;
+ $cw->afterCancel($tid);
+ }
+ else {
$cw->waitVariable(\$cw->{'selected_button'});
+ }
+ ################################################
+
$cw->grabRelease;
$cw->withdraw;
$cw->Callback(-command => $cw->{'selected_button'});