From 23bcb9b18289a37452f1de2ebb50b6282f766f9f Mon Sep 17 00:00:00 2001 From: milkbone57 Date: Tue, 15 Jul 2003 14:42:28 +0000 Subject: [PATCH] Prepackaged --- lib/Tk/FastSplash.pm | 188 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 188 insertions(+) create mode 100644 lib/Tk/FastSplash.pm diff --git a/lib/Tk/FastSplash.pm b/lib/Tk/FastSplash.pm new file mode 100644 index 0000000..703aa2f --- /dev/null +++ b/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 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 will silently ignore all errors and continue without a +splash screen. The splash screen can be destroyed with the B +method, best short before calling B. + +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 instead. If +your primary concern is speed, then C is for you (and +the primary reason I wrote this module). The splash window of +C should pop up 1 or 2 seconds faster than using +C or a vanilla L window. + +=head1 BUGS + +Probably many. + +You cannot call C 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 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, L, L, +L. + +=cut + +__END__