libtk-splashscreen-perl-1.0/0000755000175100017510000000000007541206214017314 5ustar gustavogustavo00000000000000libtk-splashscreen-perl-1.0/Makefile.PL0000644000175100017510000000071707541202501021266 0ustar gustavogustavo00000000000000 use Tk::MMutil; Tk::MMutil::TkExtMakefile( NAME => "Tk::Splashscreen", DISTNAME => "Tk-Splashscreen", VERSION_FROM => "Splashscreen.pm", PM => {"Splashscreen.pm" => "\$(INST_LIBDIR)/Splashscreen.pm", "waitVariableX.pm" => "\$(INST_LIBDIR)/waitVariableX.pm"}, dist => {COMPRESS => 'gzip', SUFFIX => 'gz'}, ABSTRACT => 'Splashscreen widget', AUTHOR => 'Steve Lidie (sol0@lehigh.edu)', ); libtk-splashscreen-perl-1.0/MANIFEST0000644000175100017510000000012507541205012020436 0ustar gustavogustavo00000000000000MANIFEST Makefile.PL README Splashscreen.pm test.pl waitVariableX.pm splashscreen.pl libtk-splashscreen-perl-1.0/README0000644000175100017510000000071107541201111020162 0ustar gustavogustavo00000000000000 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. Steve Lidie 2002/09/14 sol0@lehigh.edu libtk-splashscreen-perl-1.0/splashscreen.pl0000755000175100017510000000131107541205221022337 0ustar gustavogustavo00000000000000#!/usr/local/bin/perl -w use Tk; use lib './blib/lib'; use Tk::Splashscreen; use Tk::widgets qw/Photo Animation/; use strict; my $mw = MainWindow->new; $mw->withdraw; $mw->Button(-text => 'Quit', -command => \&exit)->pack; my $splash = $mw->Splashscreen(-milliseconds => 5000); my $animate; my $gif89 = Tk->findINC('anim.gif'); $animate = $splash->Animation(-format => 'gif', -file => $gif89); $splash->Label(-image => $animate)->pack; $animate->set_image(0); $animate->start_animation(500); $splash->Splash; # show Splashscreen $mw->after(1000); $| = 1; print STDOUT "Waiting for Splashscreen to finish ...\n"; $splash->Destroy; # tear down Splashscreen $mw->deiconify; # show calculator MainLoop; libtk-splashscreen-perl-1.0/Splashscreen.pm0000644000175100017510000001064007541206014022303 0ustar gustavogustavo00000000000000$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('' => [$self => 'b3prs', Ev('x'), Ev('y')]); $self->bind('' => [$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]); If B 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]); If B 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 Notifies the Splashscreen to set a mark for an impending move. =head2 Moves the Splashscreen from the mark to the cursor's current position. =head1 ADVERTISED WIDGETS Component subwidgets can be accessed via the B 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 libtk-splashscreen-perl-1.0/test.pl0000644000175100017510000000217107541202647020637 0ustar gustavogustavo00000000000000#!perl -w use Test; use strict; BEGIN { plan tests => 11 }; eval { require Tk; }; ok($@, "", "loading Tk module"); my $mw; eval {$mw = Tk::MainWindow->new();}; ok($@, "", "can't create MainWindow"); ok(Tk::Exists($mw), 1, "MainWindow creation failed"); eval { $mw->geometry('+10+10'); }; my $w; my $class = 'Splashscreen'; eval "require Tk::$class;"; ok($@, "", "Error loading Tk::$class"); eval { $w = $mw->$class(); }; ok($@, "", "can't create $class widget"); skip($@, Tk::Exists($w), 1, "$class instance does not exist"); if (Tk::Exists($w)) { # eval { $w->pack; }; # ok ($@, "", "Can't pack a $class widget"); eval { $mw->update; }; ok ($@, "", "Error during 'update' for $class widget"); eval { my @dummy = $w->configure; }; ok ($@, "", "Error: configure list for $class"); eval { $mw->update; }; ok ($@, "", "Error: 'update' after configure for $class widget"); eval { $w->destroy; }; ok($@, "", "can't destroy $class widget"); ok(!Tk::Exists($w), 1, "$class: widget not really destroyed"); } else { for (1..5) { skip (1,1,1, "skipped because widget couldn't be created"); } } 1; libtk-splashscreen-perl-1.0/waitVariableX.pm0000644000175100017510000000414007541206040022410 0ustar gustavogustavo00000000000000$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