r782 - in packages: . libtk-splashscreen-perl libtk-splashscreen-perl/branches libtk-splashscreen-perl/branches/upstream libtk-splashscreen-perl/branches/upstream/current
Carlo Segre
segre-guest@costa.debian.org
Mon, 14 Mar 2005 07:38:45 +0100
Author: segre-guest
Date: 2005-03-14 07:38:45 +0100 (Mon, 14 Mar 2005)
New Revision: 782
Added:
packages/libtk-splashscreen-perl/
packages/libtk-splashscreen-perl/branches/
packages/libtk-splashscreen-perl/branches/upstream/
packages/libtk-splashscreen-perl/branches/upstream/current/
packages/libtk-splashscreen-perl/branches/upstream/current/MANIFEST
packages/libtk-splashscreen-perl/branches/upstream/current/Makefile.PL
packages/libtk-splashscreen-perl/branches/upstream/current/README
packages/libtk-splashscreen-perl/branches/upstream/current/Splashscreen.pm
packages/libtk-splashscreen-perl/branches/upstream/current/splashscreen.pl
packages/libtk-splashscreen-perl/branches/upstream/current/test.pl
packages/libtk-splashscreen-perl/branches/upstream/current/waitVariableX.pm
packages/libtk-splashscreen-perl/tags/
Log:
[svn-inject] Installing original source of libtk-splashscreen-perl
Added: packages/libtk-splashscreen-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libtk-splashscreen-perl/branches/upstream/current/MANIFEST 2005-03-14 06:32:10 UTC (rev 781)
+++ packages/libtk-splashscreen-perl/branches/upstream/current/MANIFEST 2005-03-14 06:38:45 UTC (rev 782)
@@ -0,0 +1,7 @@
+MANIFEST
+Makefile.PL
+README
+Splashscreen.pm
+test.pl
+waitVariableX.pm
+splashscreen.pl
Added: packages/libtk-splashscreen-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libtk-splashscreen-perl/branches/upstream/current/Makefile.PL 2005-03-14 06:32:10 UTC (rev 781)
+++ packages/libtk-splashscreen-perl/branches/upstream/current/Makefile.PL 2005-03-14 06:38:45 UTC (rev 782)
@@ -0,0 +1,12 @@
+
+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)',
+);
Added: packages/libtk-splashscreen-perl/branches/upstream/current/README
===================================================================
--- packages/libtk-splashscreen-perl/branches/upstream/current/README 2005-03-14 06:32:10 UTC (rev 781)
+++ packages/libtk-splashscreen-perl/branches/upstream/current/README 2005-03-14 06:38:45 UTC (rev 782)
@@ -0,0 +1,13 @@
+
+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
Added: packages/libtk-splashscreen-perl/branches/upstream/current/Splashscreen.pm
===================================================================
--- packages/libtk-splashscreen-perl/branches/upstream/current/Splashscreen.pm 2005-03-14 06:32:10 UTC (rev 781)
+++ packages/libtk-splashscreen-perl/branches/upstream/current/Splashscreen.pm 2005-03-14 06:38:45 UTC (rev 782)
@@ -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
Added: packages/libtk-splashscreen-perl/branches/upstream/current/splashscreen.pl
===================================================================
--- packages/libtk-splashscreen-perl/branches/upstream/current/splashscreen.pl 2005-03-14 06:32:10 UTC (rev 781)
+++ packages/libtk-splashscreen-perl/branches/upstream/current/splashscreen.pl 2005-03-14 06:38:45 UTC (rev 782)
@@ -0,0 +1,31 @@
+#!/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;
Property changes on: packages/libtk-splashscreen-perl/branches/upstream/current/splashscreen.pl
___________________________________________________________________
Name: svn:executable
+
Added: packages/libtk-splashscreen-perl/branches/upstream/current/test.pl
===================================================================
--- packages/libtk-splashscreen-perl/branches/upstream/current/test.pl 2005-03-14 06:32:10 UTC (rev 781)
+++ packages/libtk-splashscreen-perl/branches/upstream/current/test.pl 2005-03-14 06:38:45 UTC (rev 782)
@@ -0,0 +1,44 @@
+#!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;
Added: packages/libtk-splashscreen-perl/branches/upstream/current/waitVariableX.pm
===================================================================
--- packages/libtk-splashscreen-perl/branches/upstream/current/waitVariableX.pm 2005-03-14 06:32:10 UTC (rev 781)
+++ packages/libtk-splashscreen-perl/branches/upstream/current/waitVariableX.pm 2005-03-14 06:38:45 UTC (rev 782)
@@ -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