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

3 files changed, 308 insertions, 1 deletions

diff --git a/Master/texmf/scripts/texlive/tlmgrgui/tlmgrgui-real.pl b/Master/texmf/scripts/texlive/tlmgrgui/tlmgrgui-real.pl
index 342ee08097b..6e8d3467084 100755
--- a/Master/texmf/scripts/texlive/tlmgrgui/tlmgrgui-real.pl
+++ b/Master/texmf/scripts/texlive/tlmgrgui/tlmgrgui-real.pl
@@ -35,6 +35,7 @@ use Tk::NoteBook;
 use Tk::BrowseEntry;
 use Tk::ROText;
 use Tk::Balloon;
+use Tk::Splashscreen;
 
 
 
@@ -198,8 +199,46 @@ our @update_function_list;
 
 our $debugmode = 0;
 
+our $mw = MainWindow->new(-title => "tlmgr 2008");
+$mw->withdraw;
+my $splash = $mw->Splashscreen;
+$splash->Label(-text => ___"loadtlpdbwait")->pack;
+$splash->Splash(4000);
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
+$splash->update();
 our $localtlpdb = TeXLive::TLPDB->new ("root" => "$Master");
 die("cannot find tlpdb!") unless (defined($localtlpdb));
+
 our @alllocalpackages = setup_list(0,$localtlpdb->list_packages);
 our @updatepackages;
 setup_programs("$Master/tlpkg/installer", $localtlpdb->option_platform);
@@ -218,7 +257,6 @@ our $tlmediasrc;
 our $tlmediatlpdb;
 our @allpackages;
 
-our $mw = MainWindow->new(-title => "tlmgr 2008");
 our $balloon = $mw->Balloon();
 
 push @update_function_list, \&init_install_media;
@@ -318,10 +356,14 @@ if ($opt_load) {
   run_update_functions();
 }
 
+
 if (defined($opt_screen)) {
   $back->raise("$opt_screen"); 
 } 
 
+$splash->Destroy;
+$mw->deiconify;
+
 Tk::MainLoop();
 
 
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