File Coverage

blib/lib/Tk/FastSplash.pm

Criterion	Covered	Total	%
statement	10	72	13.8
branch	2	38	5.2
condition			n/a
subroutine	1	9	11.1
pod	0	4	0.0
total	13	123	10.5

# -*- perl -*-

#
# $Id: FastSplash.pm,v 1.20 2005/08/25 22:14:45 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 1999,2003,2005 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: [e-mail]
# WWW:  http://www.rezic.de/eserte/
#

package Tk::FastSplash;
#use strict;use vars qw($TK_VERSION $VERSION);
$VERSION = $VERSION = "0.15";
$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; # hide from indexer
	require DynaLoader;
	eval q{ require Tk::Event };
	@Tk::ISA = qw(DynaLoader);
	bootstrap Tk;
	sub TranslateFileName { $_[0] }
	sub SplitString { split /\s+/, $_[0] } # rough approximation

	if (Tk::FontRankInfo->can("encoding")) {
	    $Tk::FastSplash::TK_VERSION = 804;
	}

	if ($Tk::FastSplash::TK_VERSION < 804) {
	    package
		Tk::Photo; # hide from indexer
	    @Tk::Photo::ISA = qw(DynaLoader);
	    bootstrap Tk::Photo;
	}

	if ($Tk::FastSplash::TK_VERSION >= 804) {
	    *Tk::getEncoding = \&Tk::FastSplash::getEncoding;
	}

	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) });
    }
}

# Taken from Tk.pm (Tk804.025_beta6)
sub getEncoding
{
 my ($class,$name) = @_;

 eval { require Encode };
 if ($@)
  {
   require Tk::DummyEncode;
   return Tk::DummyEncode->getEncoding($name);
  }

 $Tk::encodeStopOnError = Encode::FB_QUIET();
 $Tk::encodeFallback    = Encode::FB_PERLQQ(); # Encode::FB_DEFAULT();

 $name = $Tk::font_encoding{$name} if exists $Tk::font_encoding{$name};
 my $enc = Encode::find_encoding($name);

 unless ($enc)
  {
   $enc = Encode::find_encoding($name) if ($name =~ s/[-_]\d+$//)
  }
# if ($enc)
#  {
#   print STDERR "Lookup '$name' => ".$enc->name."\n";
#  }
# else
#  {
#   print STDERR "Failed '$name'\n";
#  }
 unless ($enc)
  {
   if ($name eq 'X11ControlChars')
    {
     require Tk::DummyEncode;
     $Encode::encoding{$name} = $enc = Tk::DummyEncode->getEncoding($name);
    }
  }
 return $enc;
}




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 fast loading splash screen for Perl/Tk programs.
It uses lowlevel Perl/Tk stuff, so upward compatibility is not given
(the module should work at least for Tk800.015, .022, .024, .025 and
Tk804.025, but does not work with newer ActivePerl versions).

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. I<$width> and I<$height>
may be left undefined. If I<$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.

I<$image> should be one of the core Perl/Tk image types (gif, ppm,
bmp). For jpegs and pngs, a C or C prior to
the call of the C method would be necessary, but calling one of
these two would slurp the whole Tk module in, making the point of
BSplash useless.

=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
L or a vanilla L window.

=head1 BUGS

Probably many.

If used with newer ActivePerl (e.g. build 811), then it is possible
that the application becomes unusable by using strange characters.

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).

XXX Avoid Win32 raise/lower problem with this code (maybe)?

    # Windows constants
    my ($ONTOP, $NOTOP, $TOP) = (-1, -2, 0);
    my ($SWP_NOMOVE, $SWP_NOSIZE) = (2, 1);

    my $SetWindowPos        = new Win32::API("user32", "SetWindowPos", 'NNNNNNN', 'N');
    my $FindWindow          = new Win32::API("user32", "FindWindow", 'PP', 'N');

    # Reestablish Z order
    my $class = "TkTopLevel";
    my $topHwnd = $FindWindow->Call($class, $w->title);
    $topHwnd and $SetWindowPos->Call($topHwnd, $ONTOP, 0, 0, 0, 0, $SWP_NOMOVE | $SWP_NOSIZE);


=head1 AUTHOR

Slaven Rezic ([e-mail])

=head1 SEE ALSO

L, L, L,
L.

=cut

__END__