summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2008-06-17 23:07:58 +0000
committerNorbert Preining <preining@logic.at>2008-06-17 23:07:58 +0000
commit683d9376a407c004e77e92ee76ec94a333d618c8 (patch)
treebce4fb08ee2ccedc080c1636b36bc93b377e601c /Master/tlpkg/tlperl
parent8da45047a3fbff79bf9244f0faf24a43496f3903 (diff)
tlmgrgui: splash screen for staring and loading, hope it works on win32
git-svn-id: svn://tug.org/texlive/trunk@8820 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Splashscreen.pm185
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/waitVariableX.pm80
2 files changed, 265 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Splashscreen.pm b/Master/tlpkg/tlperl/lib/Tk/Splashscreen.pm
new file mode 100644
index 00000000000..3148c6b1131
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Splashscreen.pm
@@ -0,0 +1,185 @@
+$Tk::Splashscreen::VERSION = '1.0';
+
+package Tk::Splashscreen;
+
+use Tk qw/Ev/;
+use Tk qw/:eventtypes/;
+use Tk::waitVariableX;
+use Tk::widgets qw/Toplevel/;
+use base qw/Tk::Toplevel/;
+
+Construct Tk::Widget 'Splashscreen';
+
+sub Populate {
+ my ($self, $args) = @_;
+
+ $self->withdraw;
+ $self->overrideredirect(1);
+
+ $self->SUPER::Populate($args);
+
+ $self->{ofx} = 0; # X offset from top-left corner to cursor
+ $self->{ofy} = 0; # Y offset from top-left corner to cursor
+ $self->{tm0} = 0; # microseconds time widget was Shown
+
+ $self->ConfigSpecs(
+ -milliseconds => [qw/PASSIVE milliseconds Milliseconds 0/],
+ );
+
+ $self->bind('<ButtonPress-3>' => [$self => 'b3prs', Ev('x'), Ev('y')]);
+ $self->bind('<ButtonRelease-3>' => [$self => 'b3rls', Ev('X'), Ev('Y')]);
+
+} # end Populate
+
+# Object methods.
+
+sub Destroy {
+
+
+ my ($self, $millis) = @_;
+
+ $millis = $self->cget(-milliseconds) unless defined $millis;
+ my $t = Tk::timeofday;
+ $millis = $millis - ( ($t - $self->{tm0}) * 1000 );
+ $millis = 0 if $millis < 0;
+
+ my $destroy_splashscreen = sub {
+ $self->update;
+ $self->after(100); # ensure 100% of PB seen
+ $self->destroy;
+ };
+
+ do { &$destroy_splashscreen; return } if $millis == 0;
+
+ while ( $self->DoOneEvent (DONT_WAIT | TIMER_EVENTS)) {}
+
+ $self->waitVariableX( [$millis, $destroy_splashscreen] );
+
+} # end Destroy
+
+sub Splash {
+
+ my ($self, $millis) = @_;
+
+ $millis = $self->cget(-milliseconds) unless defined $millis;
+ $self->{tm0} = Tk::timeofday;
+ $self->configure(-milliseconds => $millis);
+ $self->Popup;
+
+} # end_splash
+
+# Private methods.
+
+sub b3prs {
+ my ($self, $x, $y) = @_;
+ $self->{ofx} = $x;
+ $self->{ofy} = $y;
+} # end b3prs
+
+sub b3rls {
+ my($self, $X, $Y) = @_;
+ $X -= $self->{ofx};
+ $Y -= $self->{ofy};
+ $self->geometry("+${X}+${Y}");
+} # end b3rls
+
+1;
+__END__
+
+=head1 NAME
+
+Tk::Splashscreen - display a Splashscreen during program initialization.
+
+=head1 SYNOPSIS
+
+ $splash = $parent->Splashscreen(-opt => val, ... );
+
+=head1 DESCRIPTION
+
+For programs that require large load times, it's a common practice to
+display a Splashscreen that occupies the user's attention. This
+Toplevel mega widget provides all the display, destroy and timing
+events. All you do it create the Splashscreen mega widget, populate
+it as you see fit, then invoke Splash() to display it and Destroy() to
+tear it down.
+
+Important note: be sure to sprinkle update() calls throughout your
+initialization code so that any Splashscreen events are handled.
+Remember, the screen may be animated, or the user may be simply moving
+the Splashscreen about.
+
+=head1 OPTIONS
+
+The following option/value pairs are supported:
+
+=over 4
+
+=item B<-milliseconds>
+
+The minimum number of milliseconds the Splashscreen should remain on
+the screen. Default is 0, which means that the Splashscreen is
+destroyed as soon as Destroy() is called. Otherwise, Destroy() waits
+for the specified time interval to elapse before destroying the
+Splashscreen.
+
+=back
+
+=head1 METHODS
+
+=head2 $splash->Splash([B<milliseconds>]);
+
+If B<milliseconds> is specified, it's the minimum number of
+milliseconds the Splashscreen should remain on the screen.
+This value takes precedence over that specified on the
+Splashscreen constructor call.
+
+=head2 $splash->Destroy([B<milliseconds>]);
+
+If B<milliseconds> is specified, it's the minimum number of
+milliseconds the Splashscreen should remain on the screen.
+This value takes precedence over that specified on the
+Splash() call, which takes precedence over that specified
+during Splashscreen construction.
+
+=head1 BINDINGS
+
+=head2 <ButtonPress-3>
+
+Notifies the Splashscreen to set a mark for an impending move.
+
+=head2 <ButtonRelease-3>
+
+Moves the Splashscreen from the mark to the cursor's current position.
+
+=head1 ADVERTISED WIDGETS
+
+Component subwidgets can be accessed via the B<Subwidget> method.
+This mega widget has no advertised subwidgets. Instead, treat the
+widget reference as a Toplevel and populate it as desired.
+
+=head1 EXAMPLE
+
+ $splash = $mw->Splashscreen;
+
+ ... populate the Splashscreen toplevel as desired ...
+
+ $splash->Splash(4000);
+
+ ... program initialization ...
+
+ $splash->Destroy;
+
+=head1 AUTHOR
+
+Stephen.O.Lidie@Lehigh.EDU
+
+Copyright (C) 2001 - 2002, Steve Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 KEYWORDS
+
+Splashscreen, Toplevel
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Tk/waitVariableX.pm b/Master/tlpkg/tlperl/lib/Tk/waitVariableX.pm
new file mode 100644
index 00000000000..29dbae9cea5
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/waitVariableX.pm
@@ -0,0 +1,80 @@
+$Tk::waitVariableX::VERSION = '1.0';
+
+package Tk::waitVariableX;
+
+use Carp;
+use Exporter;
+
+use base qw/Exporter/;
+@EXPORT = qw/waitVariableX/;
+use strict;
+
+sub waitVariableX {
+
+ use Tie::Watch;
+
+ my ($parent, $millis) = (shift, shift); # @_ has list of var refs
+
+ croak "waitVariableX: no milliseconds." unless defined $millis;
+ my ($callback, $st, $tid, @watch, $why);
+
+ if (ref $millis eq 'ARRAY') {
+ $callback = Tk::Callback->new($millis->[1]);
+ $millis = $millis->[0];
+ }
+
+ $st = sub {my $argv = $_[0]->Args('-store'); $why = $argv->[0]};
+ foreach my $vref (@_) {
+ push @watch,
+ Tie::Watch->new(-variable => $vref, -store => [$st, $vref]);
+ }
+ $tid = $parent->after($millis => sub {$why = 0}) unless $millis == 0;
+
+ $parent->waitVariable(\$why); # wait for timer or watchpoint(s)
+
+ $_->Unwatch foreach @watch;
+ $parent->afterCancel($tid);
+ $callback->Call($why) if defined $callback;
+
+ return $why; # why we stopped waiting: 0 or $vref
+
+} # end waitVariableX
+
+1;
+__END__
+
+=head1 NAME
+
+Tk::waitVariableX - a waitVariable with extensions.
+
+=head1 SYNOPSIS
+
+ use Tk::waitVariableX;
+
+ $splash->waitVariableX( [$millis, $destroy_splashscreen], \$v1, \$v2} );
+
+=head1 DESCRIPTION
+
+This subroutine waits for a list of variables, with a timeout - the
+subroutine returns when one of the variables changes value or the timeout
+expires, whichever occurs first.
+
+Although the millisecond parameter is required, it may be zero, which
+effects no timeout. The milliscond paramter may also be an array of
+two elements, the first the millisecond value, and the second a
+normal Per/Tk callback. The callback is invoked just before
+waitVariableX returns.
+
+Callback format is patterned after the Perl/Tk scheme: supply either a
+code reference, or, supply an array reference and pass the callback
+code reference in the first element of the array, followed by callback
+arguments.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000 - 2002 Stephen O. Lidie. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut