Prepackaged

lib/Tk/FastSplash.pm

@@ -0,0 +1,188 @@
+# -*- perl -*-
+
+#
+# $Id$
+# Author: Slaven Rezic
+#
+# Copyright (C) 1999,2003 Slaven Rezic. All rights reserved.
+# This package is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Mail: srezic@cpan.org
+# WWW:  http://www.rezic.de/eserte/
+#
+
+package Tk::FastSplash;
+#use strict;use vars qw($TK_VERSION $VERSION);
+$VERSION = $VERSION = 0.11;
+$TK_VERSION = 800 if !defined $TK_VERSION;
+
+sub Show {
+    my($pkg,
+       $image_file, $image_width, $image_height, $title, $override) = @_;
+    $title = $0 if !defined $title;
+    my $splash_screen = {};
+    eval {
+	package Tk;
+	require DynaLoader;
+	eval q{ require Tk::Event };
+	@Tk::ISA = qw(DynaLoader);
+	bootstrap Tk;
+	sub TranslateFileName { $_[0] }
+	sub SplitString { split /\s+/, $_[0] } # rough approximation
+
+	package Tk::Photo;
+	@Tk::Photo::ISA = qw(DynaLoader);
+	bootstrap Tk::Photo;
+
+	package Tk::FastSplash;
+	sub _Destroyed { }
+	$splash_screen = Tk::MainWindow::Create(".", $title);
+	bless $splash_screen, 'Tk::MainWindow';
+	$splash_screen->{"Exists"} = 1;
+
+	if ($override) {
+	    require Tk::Wm;
+	    $splash_screen->overrideredirect(1);
+	}
+
+	my $img = Tk::image($splash_screen, 'create', 'photo', 'splashphoto',
+			    -file => $image_file);
+	bless $img, 'Tk::Image';
+	$splash_screen->{Photo} = $img;
+	$image_width = $img->width if !defined $image_width;
+	$image_height = $img->height if !defined $image_height;
+	my $sw = Tk::winfo($splash_screen, 'screenwidth');
+	my $sh = Tk::winfo($splash_screen, 'screenheight');
+	Tk::wm($splash_screen, "geometry",
+	       "+" . int($sw/2 - $image_width/2) .
+	       "+" . int($sh/2 - $image_height/2));
+
+	$splash_screen->{ImageWidth} = $image_width;
+
+	my(@fontarg) = ($TK_VERSION >= 800
+			# dummy font to satisfy SplitString
+			? (-font => "Helvetica 10")
+			# no font for older Tk's
+			: ());
+	my $l_path = '.splashlabel';
+	my $l = Tk::label($splash_screen, $l_path,
+			  @fontarg,
+			  -bd => 0,
+			  -image => 'splashphoto');
+	if (!ref $l) {
+	    # >= Tk803
+	    $l = Tk::Widget::Widget($splash_screen, $l);
+	}
+	$l->{'_TkValue_'} = $l_path;
+	bless $l, 'Tk::Widget';
+	Tk::pack($l, -fill => 'both', -expand => 1);
+	Tk::update($splash_screen);
+    };
+    warn $@ if $@;
+    bless $splash_screen, $pkg;
+}
+
+sub Raise {
+    my $w = shift;
+    if ($w->{"Exists"}) {
+	Tk::catch(sub { Tk::raise($w) });
+    }
+}
+
+sub Destroy {
+    my $w = shift;
+    if ($w->{Photo}) {
+	$w->{Photo}->delete;
+	undef $w->{Photo};
+    }
+    if ($w->{"Exists"}) {
+	Tk::catch(sub { Tk::destroy($w) });
+    }
+}
+
+1;
+
+=head1 NAME
+
+Tk::FastSplash - create a fast starting splash screen
+
+=head1 SYNOPSIS
+
+    BEGIN {
+        require Tk::FastSplash;
+        $splash = Tk::FastSplash->Show($image, $width, $height, $title,
+                                   $overrideredirect);
+    }
+    ...
+    use Tk;
+    ...
+    $splash->Destroy if $splash;
+    MainLoop;
+
+=head1 DESCRIPTION
+
+This module creates a splash screen for perl/Tk programs. It uses
+lowlevel perk/Tk stuff, so upward compatibility is not given (the
+module should work at least for Tk800.015, .022 and .024). The splash screen
+is created with the B<Show> function. Supplied arguments are: filename
+of the displayed image, width and height of the image and the string
+for the title bar. C<$width> and C<$height> may be left undefined. If
+C<$overrideredirect> is set to a true value, then the splash screen
+will come without window manager decoration. If something goes wrong,
+then B<Show> will silently ignore all errors and continue without a
+splash screen. The splash screen can be destroyed with the B<Destroy>
+method, best short before calling B<MainLoop>.
+
+If you want to run this module on a Tk402.xxx system, then you have to
+set the variable C<$Tk::FastSplash::TK_VERSION> to a value less than
+800.
+
+=head1 CAVEAT
+
+This module does forbidden things e.g. bootstrapping the Tk shared
+object or poking in the Perl/Tk internals. Because of this, this
+module can stop working in a new Perl/Tk release. If you are concerned
+about compatibility, then you should use L<Tk::Splash> instead. If
+your primary concern is speed, then C<Tk::FastSplash> is for you (and
+the primary reason I wrote this module). The splash window of
+C<Tk::FastSplash> should pop up 1 or 2 seconds faster than using
+C<Tk::Splash> or a vanilla L<Tk::Toplevel> window.
+
+=head1 BUGS
+
+Probably many.
+
+You cannot call C<Tk::FastSplash> twice in one application.
+
+The $^W variable should be turned off until the "use Tk" call.
+
+If FastSplash is executed in a BEGIN block (which is recommended for
+full speed), then strange things will happen when using C<perl -c> or
+trying to compile a script: the splash screen will always pop up while
+doing those things. Therefore it is recommended to disable the splash
+screen in check or debug mode:
+
+    BEGIN {
+        if (!$^C && !$^P) {
+            require Tk::FastSplash;
+            $splash = Tk::FastSplash->Show($image, $width, $height, $title,
+                                           $overrideredirect);
+        }
+    }
+
+The -display switch is not honoured (but setting the environment
+variable DISPLAY will work).
+
+=head1 AUTHOR
+
+Slaven Rezic (slaven@rezic.de)
+
+=head1 SEE ALSO
+
+L<Tk::Splash>, L<Tk::ProgressSplash>, L<Tk::Splashscreen>,
+L<Tk::mySplashScreen>.
+
+=cut
+
+__END__