# -*- perl -*-

#
# Author: Slaven Rezic
#
# Copyright (C) 1999,2003,2005,2014 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.16";
$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

B<Tk::FastSplash> is B<NOT SUPPORTED> anymore. Please use
L<Tk::Splash> instead. Read L</CAVEAT> and L</BUGS>.

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

Arguments for the C<Show> method are the same as for L<Tk::Splash>.

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

The module does not work anymore with new Tk versions (e.g. 804.032).

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
L<Tk::Splash> or a vanilla L<Tk::Toplevel> 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<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).

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 <srezic@cpan.org>

=head1 SEE ALSO

L<Tk::Splash>, L<Tk::ProgressSplash>, L<Tk::Splashscreen>,
L<Tk::mySplashScreen>.

=cut

__END__
