Tk::Wizard - GUI for step-by-step interactive logical process

	use Tk::Wizard ();
	my $wizard = new Tk::Wizard;
	# OR my $wizard = Tk::MainWindow->new -> Wizard();
	$wizard->configure( -property=>'value' );
	$wizard->cget( "-property");
	# $wizard->addPage(
	# ... code-ref to anything returning a Tk::Frame ...
	# );
	$wizard->addPage(
		sub {
			return $wizard->blank_frame(
				-title    => "Page Title",
				-subtitle => "Sub-title",
				-text     => "Some text.",
				-wait     => $milliseconds_b4_proceeding_anyway,
			);
		}
	);
	$wizard->addPage(
		sub { $wizard->blank_frame(@args) },
		-preNextButtonAction  => sub { warn "My -preNextButtonAction  called here" },
		-postNextButtonAction => sub { warn "My -postNextButtonAction called here" },
	);
	$wizard->Show;
	MainLoop;
	exit;

  MainLoop();

  my $subwidget = $wizard->Subwidget('buttonPanel');

	use Tk::Wizard;
	use Tk::Wizard ();
	use Tk::Wizard ':old';
	use Tk::Wizard ':use' => [qw[ Choices FileSystem ]];

	use Tk::Wizard;
	use Tk::Wizard::Tasks;

  my $apps_main_window = $wizard->parent;

  my $frame = wizard>->blank_frame(
    -title    => $sTitle,
    -subtitle  => $sSub,
    -text    => $sStandfirst,
    -wait    => $iMilliseconds
  );

  -background

  $wizard->addPage ($page_code_ref1 ... $page_code_refN)
  $wizard->addPage (@args)
  $wizard->addPage ($page_code_ref, -preNextButtonAction => $x, -postNextButtonAction => $y)

	$wizard->Show();

  $frame->after($x,sub{$wizard->forward});

  my $current_page = $wizard->currentPage()

  backButton nextButton helpButton cancelButton

  $wizard->{backButton}->configure( -state => "disabled" )

package Tk::Wizard;

use strict;
use warnings;
use warnings::register;

use vars '$VERSION';
$VERSION = do { my @r = ( q$Revision: 2.084 $ =~ /\d+/g ); sprintf "%d." . "%03d" x $#r, @r };

use Carp;
use Config;
use Data::Dumper;
use File::Path;
use File::Spec::Functions qw( rootdir );
use Tk;
use Tk::DialogBox;
use Tk::Frame;
use Tk::Font;
use Tk::MainWindow;
use Tk::ROText;
use Tk::Wizard::Image;
use Tk::JPEG;
use Tk::PNG;

use constant DEBUG_FRAME => 0;

use vars qw( @EXPORT @ISA %LABELS );

# use Log4perl if we have it, otherwise stub:
# See Log::Log4perl::FAQ
BEGIN {
	eval { require Log::Log4perl; };

	# No Log4perl so bluff: see Log4perl FAQ
	if($@) {
		no strict qw"refs";
		*{__PACKAGE__."::$_"} = sub { } for qw(TRACE DEBUG INFO WARN ERROR FATAL);
	}

	# Setup log4perl
	else {
		no warnings;
		no strict qw"refs";
		require Log::Log4perl::Level;
		Log::Log4perl::Level->import(__PACKAGE__);
		Log::Log4perl->import(":easy");
		# It took four CPAN uploads and tests to workout why
		# one user was getting syntax errors for TRACE: must
		# be the Mithrasmas spirit (hic):
		if ($Log::Log4perl::VERSION < 1.11){
			*{__PACKAGE__."::TRACE"} = *DEBUG;
		}
	}

    require Exporter;    # Exporting Tk's MainLoop so that
    @ISA    = ( "Exporter", );    # I can just use strict and Tk::Wizard without
    @EXPORT = ("MainLoop");       # having to use Tk
}

use base qw[ Tk::Derived Tk::Toplevel ];
Tk::Widget->Construct('Wizard');

# See INTERNATIONALISATION
%LABELS = (
    # Buttons
    BACK   => "< Back",
    NEXT   => "Next >",
    FINISH => "Finish",
    CANCEL => "Cancel",
    HELP   => "Help",
    OK     => "OK",
);

my $WINDOZE = ($^O =~ m/MSWin32/i);
my @PAGE_EVENT_LIST = qw(
	-preNextButtonAction
	-postNextButtonAction
	-preBackButtonAction
	-postBackButtonAction
);

my $REFRESH_MS = 1000; # Refresh the wizard every REFRESH_MS milliseconds

sub import {
	my $inv = shift;
	# The default `use module ()` messes up the logic below; fix with:
	shift if scalar(@_) and not defined $_[0];

	DEBUG "Enter import for ".$inv;
	if (scalar @_){
		DEBUG "Import list : ", join(",",@_);
	} else {
		DEBUG "No import list";
	}

	# Maintian backwards compatabilty while $VERSION < 3
	if (not scalar(@_) or $_[0] eq ':old'){

		require Tk::Wizard::Choices;
		Tk::Wizard::Choices->import if Tk::Wizard::Choices->can('import');

		require Tk::Wizard::FileSystem;
		Tk::Wizard::FileSystem->import if Tk::Wizard::FileSystem->can('import');

		require Tk::Wizard::Tasks;
		Tk::Wizard::Tasks->import if Tk::Wizard::Tasks->can('import');
	}

	elsif (scalar @_ == 1){
		if ($_[0] eq ':none'){
			DEBUG "Load no modules";
		}
	}

	elsif ($_[0] eq ':use'){
		shift; # drop :use - everything else is a sub-module sub-name
		my $use = shift;
		foreach my $m (ref $use? @$use : $use){
			my $n = 'Tk::Wizard::'.$m.'.pm';
			my $o = $n;
			$n =~ s/::/\//g;
			# require Tk::Wizard::Choices;
			require $n;
			$o->import;
		}
	}

	return @_;
}

# The method is overridden to allow us to supply a MainWindow if one
# is not supplied by the caller.  Not supplying one suits me, but Mr.
# Rothenberg requires one, and he was probably right.

sub new {
    TRACE "Enter new with ", (@_ || 'nothing');
    my $inv = ref( $_[0] ) ? ref( $_[0] ) : $_[0];
    shift;    					# Ignore invocant

    my @args = @_;

    unless (
        ( scalar(@_) % 2 )		# Not a simple list
        and ref $args[0]		# Already got a MainWindow
    ) {
        # Get a main window:
        unshift @args, Tk::MainWindow->new;
        push @args, "-parent" => $args[0];
        push @args, "-kill_parent_on_destroy" => 1;
        $args[0]->optionAdd( '*BorderWidth' => 1 );
    }
    my $self        = $inv->SUPER::new(@args);
    my $sFontFamily = $self->cget( -fontfamily );
    my $iFontSize   = $self->cget( -basefontsize );

    # Font used for &blank_frame titles
    $self->fontCreate(
        'TITLE_FONT',
        -family => $sFontFamily,
        -size   => $iFontSize + 4,
        -weight => 'bold',
    );
    $self->fontCreate(
        'FIXED',
        -family => 'Courier',
        -size   => $iFontSize + 1,
    );

    # Font used in multiple choices for radio title
    $self->fontCreate(
        'RADIO_BOLD',
        -family => $sFontFamily,
        -size   => $iFontSize + 2,
        -weight => 'demi',
    );

    # Fonts used if -style=>"top"
    $self->fontCreate(
        'TITLE_FONT_TOP',
        -family => $sFontFamily,
        -size   => $iFontSize + 4,
        -weight => 'bold',
    );
    $self->fontCreate(
        'SUBTITLE_FONT',
        -family => $sFontFamily,
        -size   => $iFontSize + 2,
    );

    # Font used in licence agreement  XXX REMOVE TO CORRECT MODULE
    $self->fontCreate(
        'SMALL_FONT',
        -family => $sFontFamily,
        -size   => $iFontSize - 1,
    );

    # Font used in all other places
    $self->fontCreate(
        'DEFAULT_FONT',
        -family => $sFontFamily,
        -size   => $iFontSize,
    );
    $self->{defaultFont} = 'DEFAULT_FONT';
    $self->{tagtext}->configure( -font => $self->{defaultFont} );

    if ( !$self->cget('-width') ) {
        # Caller apparently did not supply a -width argument to new():
        $self->configure( -width => $iFontSize * 50 );
    }

    if ( !$self->cget('-height') ) {
        # Caller apparently did not supply a -height argument to new():
        $self->configure( -height => $self->cget( -width ) * 0.75 );
    }
    return $self;
}

sub Populate {
    my ( $self, $args ) = @_;
    TRACE "Enter Populate";
    $self->SUPER::Populate($args);
    $self->withdraw;
    my $sTagTextDefault = 'Perl Wizard';
    my $iFontSize       = $self->_font_size;

    # $composite->ConfigSpecs(-attribute => [where,dbName,dbClass,default]);
    $self->ConfigSpecs(
        -resizable => [ 'SELF', 'resizable', 'Resizable', undef ],

        # Potentially a MainWindow:
        -parent  => [ 'PASSIVE',  undef, undef, undef ],
        -command => [ 'CALLBACK', undef, undef, undef ],

        # -foreground => ['PASSIVE', 'foreground','Foreground', 'black'],
        -background =>
          [ 'METHOD', 'background', 'Background', $WINDOZE? 'SystemButtonFace' : 'gray90' ],
        -style        => [ 'PASSIVE', "style",        "Style",        "top" ],
        -imagepath    => [ 'PASSIVE', 'imagepath',    'Imagepath',    \$Tk::Wizard::Image::LEFT{WizModernImage} ],
        -topimagepath => [ 'PASSIVE', 'topimagepath', 'Topimagepath', \$Tk::Wizard::Image::TOP{WizModernSmallImage} ],

        # event handling references
        -nohelpbutton          => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -preNextButtonAction   => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -postNextButtonAction  => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -preBackButtonAction   => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -postBackButtonAction  => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -preHelpButtonAction   => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -helpButtonAction      => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -postHelpButtonAction  => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -preFinishButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
        -finishButtonAction    => [ 'CALLBACK', undef, undef, sub { $self->withdraw; 1 } ],

        -kill_parent_on_destroy => [ 'PASSIVE',  undef,       undef,      0 ],
        -kill_self_after_finish => [ 'PASSIVE',  undef,       undef,      0 ],
        -debug                  => [ 'PASSIVE',  undef,       undef,      0 ],
        -preCloseWindowAction   => [ 'CALLBACK', undef,       undef,      sub { $self->DIALOGUE_really_quit } ],
        -tag_text               => [ 'PASSIVE',  "tag_text",  "TagText",  $sTagTextDefault ],
        -tag_width              => [ 'PASSIVE',  "tag_width", "TagWidth", 0 ],
        -wizardFrame            => [ 'PASSIVE',  undef,       undef,      0 ],
        -width                  => [ 'PASSIVE',  undef,       undef,      0 ],
        -height                 => [ 'PASSIVE',  undef,       undef,      0 ],
        -basefontsize           => [ 'PASSIVE',  undef,       undef,      $self->_font_size ],
        -fontfamily             => [ 'PASSIVE',  undef,       undef,      $self->_font_family ],
    );

    if ( exists $args->{-imagepath}
    	and not ref($args->{-imagepath}) eq 'SCALAR' and not -e $args->{-imagepath}
    ) {
        Carp::confess "Can't find file at -imagepath: " . $args->{-imagepath};
    }
    if ( exists $args->{-topimagepath}
    	and not ref($args->{-imagepath}) eq 'SCALAR' and not -e $args->{-topimagepath}
    ) {
        Carp::confess "Can't find file at -topimagepath: " . $args->{-topimagepath};
    }
    $self->{-imagepath}            = $args->{-imagepath};
    $self->{-topimagepath}         = $args->{-topimagepath};

    # Here's why we need Page objects
    $self->{_pages}        = [];

    # XXX Events indexed like pages
    $self->{_pages_e}	  = {};
	# $self->{_pages_e}->{ $event_name }->[ $page_idx ];
	$self->{_pages_e}->{$_} = [] foreach @PAGE_EVENT_LIST;

    $self->{-debug}					= $args->{-debug} || $Tk::Wizard::DEBUG || undef;
    $self->{background_userchoice}	= $args->{-background} || $self->ConfigSpecs->{-background}[3];
    $self->{background} 			= $self->{background_userchoice};
    $self->{-style}					= $args->{-style} || "top";
    $self->{_current_page_idx}		= 0;

    # $self->overrideredirect(1); # Removes borders and controls
	CREATE_BUTTON_PANEL: {
        my $buttonPanel = $self->Frame( -background => $self->{background}, )->pack(qw/ -side bottom -fill x/);
        $buttonPanel->configure( -background => 'yellow' ) if DEBUG_FRAME;

        # right margin:
        my $f = $buttonPanel->Frame(
            -width      => 5,
            -background => $self->{background},
        )->pack( -side => "right", -expand => 0 );
        $f->configure( -background => 'red' ) if DEBUG_FRAME;
		$self->Advertise( buttonPanel => $buttonPanel );
    }

	CREATE_TAGLINE: {
        my $tagbox = $self->Frame(
            -height     => 12,
            -background => $self->{background},
        )->pack(qw/-side bottom -fill x/);
        $tagbox->configure( -background => 'magenta' ) if DEBUG_FRAME;

        # This is a new, simpler, accurate-width Label way of doing it:
        $self->{tagtext} = $tagbox->Label(
            -border     => 2,
            -foreground => 'gray50',
            -background => $self->{background},
        );
        $self->{tagtext}->configure( -background => 'red' ) if DEBUG_FRAME;
        $self->_maybe_pack_tag_text;

        # This is the line that extends to the right from the tag text:
        $self->{tagline} = $tagbox->Frame(
            -relief => 'groove',
            -bd     => 1,
            -height => 2,
        )->pack(qw( -side right -fill x -expand 1 ));
        $self->{tagline}->configure( -background => 'yellow' ) if DEBUG_FRAME;
        $self->Advertise( tagLine => $self->{tagline} );
        $self->Advertise( tagBox  => $tagbox );
        $self->Advertise( tagText => $self->{tagtext} );
    }

	# Desktops for dir select: thanks to Slaven Rezic who also suggested SHGetSpecialFolderLocation for Win32. l8r
	# There is a good module for this now
    if ($WINDOZE
    	and exists $ENV{USERPROFILE}
    	and -d "$ENV{USERPROFILE}/Desktop"
    ) {
        $self->{desktop_dir} = "$ENV{USERPROFILE}/Desktop";
    }
	elsif (exists $ENV{HOME}){
		if ( -d "$ENV{HOME}/Desktop" ) {
			$self->{desktop_dir} = "$ENV{HOME}/Desktop";
		}
		elsif ( -d "$ENV{HOME}/.gnome-desktop" ) {
			$self->{desktop_dir} = "$ENV{HOME}/.gnome-desktop";
		}
	}

}

sub parent { return $_[0]->{Configure}{ -parent } || shift }

sub _maybe_pack_tag_text {
	my $self = shift;
	TRACE "Enter _maybe_pack_tag_text";
    return if ( ( $self->{Configure}{-tag_text} || '' ) eq '' );
    $self->{tagtext}->configure( -text => $self->{Configure}{-tag_text} . ' ' );
    $self->{tagtext}->pack(qw( -side left -padx 0 -ipadx 2 ));
}

sub _pack_forget {
    my $self = shift;
    foreach my $o (@_) {
        $o->packForget if Tk::Exists($o);
    }
}

# Private method: returns a font family name suitable for the
# operating system.  (The default system font, if we can determine it)
sub _font_family {
    my $self = shift;

    # Find the default font on this platform:
    my $label = $self->Label;
    my $sFont = $label->cget( -font );
    return $1          if $sFont =~ /{(.+?)}/;
    return 'Helvetica' if $^O    =~ /solaris/i;
    return 'Verdana'   if $WINDOZE;
    return 'Helvetica';
}


# Private method: returns a font size suitable for the operating
# system.  (The default system font size, if we can determine it)
sub _font_size {
    my $self = shift;

    # Find the default font on this platform:
    my $label = $self->Label;
    my $sFont = $label->cget( -font );

    # use Tk::Pretty;
    # DEBUG Tk::Pretty::Pretty($sFont);
    # DEBUG (" III default label font as string: font=%s=\n", $sFont);
    return $1 if $sFont =~ /(\d+)/;
	return 12 if $^O    =~ /solaris/i;
	return 8  if $WINDOZE;
    return 12;    # Linux etc.
}

sub background {
    my $self    = shift;
    my $operand = shift;
    if ( defined($operand) ) {
        $self->{background} = $operand;
    }
    elsif (( $self->{-style} ne '95' )
        && ( $self->_on_first_page || $self->_on_last_page ) )
    {
        $self->{background} = 'white';
    }
    else {
        $self->{background} = $self->{background_userchoice};
    }
    return $self->{background};
}    # background

#
# Sub-class me!
# Called by Show().
#
sub _initial_layout {
    my $self = shift;
    TRACE "Enter _initial_layout";
    return if $self->{_laid_out};

    # Wizard 98/95 style
    if ( $self->_showing_side_banner ) {
        my $im = $self->cget( -imagepath );
        if ( not ref $im ) {
			DEBUG "Load photo from file $im";
			FATAL "No such file as $im" unless -e $im;
			DEBUG $self;
            $self->Photo( "sidebanner", -file => $im );
        }
        else {
            $self->Photo( "sidebanner", -data => $$im );
        }
        my $bg =
            $self->_on_first_page ? 'white'
          : $self->_on_last_page  ? 'white'
          :                         $self->{background};
        $self->{left_object} = $self->Label(
            -image      => "sidebanner",
            -anchor     => "n",
            -background => $bg,
          )->pack(
            -anchor => "n",
            -fill   => 'y',
          );
        $self->{left_object}->configure( -background => 'blue' ) if DEBUG_FRAME;
    }    # end if 95 or first page

	# Wizard 2k style - builds the left side of the wizard
    else {
        my $im = $self->cget( -topimagepath );
        if ( ref $im ) {
            $self->Photo( "topbanner", -data => $$im );
        }
        else {
            $self->Photo( "topbanner", -file => $im );
        }
        $self->{left_object} = $self->Label( -image => "topbanner" )->pack( -side => "top", -anchor => "e", );
    }
    $self->Advertise( imagePane => $self->{left_object} );
    $self->{_laid_out}++;
}

#
# Maybe sub-class me
#
sub _render_current_page {
    my $self = shift;
    TRACE "Enter _render_current_page $self->{_current_page_idx}";
    my %frame_pack = ( -side => "top" );

    $self->_pack_forget( $self->{tagtext} );

    if ( !$self->_showing_side_banner ) {
        $self->_maybe_pack_tag_text;
    }

    if ( $self->_on_first_page or $self->_on_last_page ) {
        $self->{left_object}->pack( -side => "left", -anchor => "n", -fill => 'y' );
        if ( $self->{-style} ne '95' ) {
            $frame_pack{-expand} = 1;
            $frame_pack{-fill}   = 'both';
        }
    }

    elsif ( $self->cget( -style ) eq 'top' ) {
        $self->_pack_forget( $self->{left_object} );
    }

	# Take page-event from the store and apply to the object.
	# These compromises are getting silly, and indicative of the
	# need for a slight refactoring.
	# warn "Page == $self->{_current_page_idx}";
	foreach my $e (@PAGE_EVENT_LIST){
	#	warn "E = $e";
	#	warn Dumper $self->{_pages_e};
		my $code = $self->{_pages_e}->{$e}->[ $self->{_current_page_idx} ] || undef;
	#	warn $code if $code;
		if (defined $code){
			$self->configure( $e => $code )
		} else {
			# $self->configure( $e => undef )
		}
	}

	######################################
    ### $self->_repack_buttons now below;

    # Process button events and re-rendering
    my $panel = $self->Subwidget('buttonPanel');
    my %hssPackArgs = (
        -side   => "right", -expand => 0, -pady   => 5, -padx   => 5, -ipadx  => 8,
    );
    $self->_pack_forget(
		@{ $self->{_button_spacers} },
        $self->{cancelButton},
        $self->{nextButton}, $self->{backButton}, $self->{helpButton},
    );

	# No cancel button on the last page
    unless ($self->_on_last_page ) {
        $self->{cancelButton} = $panel->Button(
            -font    => $self->{defaultFont},
            -text    => $LABELS{CANCEL},
            -command => [ \&_CancelButtonEventCycle, $self, $self ],
        )->pack(%hssPackArgs);

        # Set the cancel button a little apart from the next button:
        my $f1 = $panel->Frame(
            -width      => 8,
            -background => $panel->cget( "-background" ),
        )->pack( -side => "right" );

        $f1->configure( -background => 'black' ) if DEBUG_FRAME;
        push @{ $self->{_button_spacers} }, $f1;
        $self->Advertise( cancelButton => $self->{cancelButton} );
    }

    $self->{nextButton} = $panel->Button(
        -font => $self->{defaultFont},
        -text => $self->_on_last_page ? $LABELS{FINISH} : $LABELS{NEXT},
        -command => [ \&_NextButtonEventCycle, $self ],
    )->pack(%hssPackArgs);
    $self->Advertise( nextButton => $self->{nextButton} );

    $self->{backButton} = $panel->Button(
        -font    => $self->{defaultFont},
        -text    => $LABELS{BACK},
        -command => [ \&_BackButtonEventCycle, $self ],
        -state   => $self->_on_first_page ? 'disabled' : 'normal',
    )->pack(%hssPackArgs);
    $self->Advertise( backButton => $self->{backButton} );

	# Optional help button:
    unless ($self->cget( -nohelpbutton ) ) {
        $self->{helpButton} = $panel->Button(
            -font    => $self->{defaultFont},
            -text    => $LABELS{HELP},
            -command => [ \&_HelpButtonEventCycle, $self ],
          )->pack(
            -side   => 'left', -anchor => 'w',
            -pady   => 10, -padx   => 10,
            -ipadx  => 8,
          );
        $self->Advertise( helpButton => $self->{helpButton} );
    }


	########################################

    $self->configure( -background => $self->cget("-background") );
    $self->_pack_forget( $self->{wizardFrame} );

    if (not @{ $self->{_pages} } ) {
        Carp::croak '_render_current_page called without any frames: did you add frames to the wizard?';
    }
    my $page = $self->{_pages}->[ $self->{_current_page_idx} ];

    if (not ref $page){
        Carp::croak '_render_current_page() called for a non-existent frame: did you add frames to the wizard?';
    }

    my $frame = $page->();
    if (not Tk::Exists($frame) ) {
        Carp::croak '_render_current_page() called for a non-frame: did your coderef argument to addPage() return something other than a Tk::Frame? '.Dumper($page);
    }

    $self->{wizardFrame} = $frame->pack(%frame_pack);
    $self->{wizardFrame}->update;

    # Update the wizard every 1000 seconds
    $self->{_refresh_event_id} = $self->{wizardFrame}->repeat(
		$REFRESH_MS,
		sub { $self->{wizardFrame}->update }
	) if not $self->{_refresh_event_id};

    $self->Advertise( wizardFrame => $self->{wizardFrame} );

    # $self->_resize_window;
    $self->{nextButton}->focus();
    TRACE "Leave _render_current_page $self->{_current_page_idx}";
}

sub update {
	my $self = shift;
	$self->{wizardFrame}->update if $self->{wizardFrame};
	return 1;
}

sub _resize_window {
    my $self = shift;
    return;
    if ( Tk::Exists( $self->{wizardFrame} ) ) {
        if ( $self->{frame_sizes}->[ $self->{_current_page_idx} ] ) {
            my ( $iW, $iH ) = @{ $self->{frame_sizes}->[ $self->{_current_page_idx} ] };
            DEBUG "Resize frame: -width => $iW, -height => $iH\n";
            $self->{wizardFrame}->configure(
                -width  => $iW,
                -height => $iH,
            );
            $self->{wizardFrame}->update;
            # $self->update;
        }
    }
}

#
# Sub-class me:
#  accept the args in the POD and return a Tk::Frame
#
sub blank_frame {
    my $self = shift;
    my $args = {@_};
    TRACE "Enter blank_frame";
    DEBUG "self.bg = $self->{background}";

    my $wrap = $args->{-wraplength} || 375;
    if (not defined( $args->{-height} ) ) {
        $args->{-height} = $self->cget( -height );
    }

    if (not defined( $args->{-width} ) ) {
        $args->{-width} = $self->cget( -width );
        $args->{-width} += $self->{left_object}->width
          if !$self->_showing_side_banner;
    }

    $self->{frame_sizes}->[ $self->{_current_page_idx} ] = [ $args->{-width}, $args->{-height} ];
    $self->{frame_titles}->[ $self->{_current_page_idx} ] = $args->{-title}
      || 'no title given';

    DEBUG "blank_frame setting width/height to $args->{-width}/$args->{-height}";

    # This is the main content frame:
    my $frame = $self->Frame(
        -width      => $args->{-width},
        -height     => $args->{-height},
        -background => $self->{background},
    );
    $frame->configure( -background => 'green' ) if DEBUG_FRAME;

    # Do not let the content (body) frame auto-resize when we pack its
    # contents:
    $frame->packPropagate(0);
    $args->{-title} ||= '';

    # We force the title to be one line (sorry):
    $args->{-title} =~ s/[\n\r\f]/ /g;
    $args->{-subtitle} ||= '';

    # We don't let the subtitle get pushed down away from the title:
    $args->{-subtitle} =~ s/^[\n\r\f]*//;
    my ( $lTitle, $lSub, $lText );
    if ( !$self->_showing_side_banner ) {

        # For 'top' style pages other than first and last
        my $top_frame = $frame->Frame( -background => 'white', )->pack(
            -fill   => 'x',
            -side   => 'top',
            -anchor => 'e'
        );
        my $p = $top_frame->Frame( -background => 'white' );
        my $photo = $self->cget( -topimagepath );
        if ( ref $photo ) {
            $p->Photo( "topimage", -data => $$photo );
        }
        else {
            $p->Photo( "topimage", -file => $photo );
        }
        $p->Label(
            -image      => "topimage",
            -background => 'white',
          )->pack(
            -side   => "right",
            -anchor => "e",
            -padx   => 5,
            -pady   => 5,
          );
        $p->pack( -side => 'right', -anchor => 'n' );
        my $title_frame = $top_frame->Frame( -background => 'white', )->pack(
            -side   => 'left',
            -anchor => 'w',
            -expand => 1,
            -fill   => 'x',
        );
        my $f = $title_frame->Frame(qw/-background white -width 10 -height 30/)->pack(qw/-fill x -anchor n -side left/);
        $f->configure( -background => 'yellow' ) if DEBUG_FRAME;

        # The title frame content proper:
        $lTitle = $title_frame->Label(
            -justify    => 'left',
            -anchor     => 'w',
            -text       => $args->{-title},
            -font       => 'TITLE_FONT_TOP',
            -background => $title_frame->cget("-background"),
          )->pack(
            -side   => 'top',
            -expand => 1,
            -fill   => 'x',
            -pady   => 5,
            -padx   => 0,
          );
        $lSub = $title_frame->Label(
            -font       => 'SUBTITLE_FONT',
            -justify    => 'left',
            -anchor     => 'w',
            -text       => '   ' . $args->{-subtitle},
            -background => $title_frame->cget("-background"),
          )->pack(
            -side   => 'top',
            -expand => 0,
            -fill   => 'x',
            -padx   => 5,
          );

        # This is the line below top:
        if ( ( $self->cget( -style ) eq 'top' ) && !$self->_on_first_page ) {
            my $f = $frame->Frame(
                -relief => 'groove',
                -bd     => 1,
                -height => 2,
            )->pack(qw/-side top -fill x/);
            $f->configure( -background => 'red' ) if DEBUG_FRAME;
		}

        if ( $args->{-text} ) {
            $lText = $frame->Label(
                -font       => $self->{defaultFont},
                -justify    => 'left',
                -anchor     => 'w',
                -wraplength => $wrap + 100,
                -justify    => "left",
                -text       => $args->{-text},
                -background => $self->{background},
              )->pack(
                -side => 'top',

                # -anchor => 'n',
                # -expand => 1,
                -expand => 0,
                -fill   => 'x',
                -padx   => 10,
                -pady   => 10,
              );
        }
    }

    # if 'top' style, but not first or last page
	# Whenever page does NOT have the side banner:
    else {
        $lTitle = $frame->Label(
            -justify    => 'left',
            -anchor     => 'w',
            -text       => $args->{-title},
            -font       => 'TITLE_FONT',
            -background => $frame->cget("-background"),
          )->pack(
            -side   => 'top',
            -anchor => 'n',
            -expand => 0, # 1
            -fill   => 'x',
          );
        $lSub = $frame->Label(
            -font       => 'SUBTITLE_FONT',
            -justify    => 'left',
            -anchor     => 'w',
            -text       => '   ' . $args->{-subtitle},
            -background => $frame->cget("-background"),
          )->pack(
            -anchor => 'n',
            -side   => 'top',
            -expand => 0,
            -fill   => 'x',
          );
        if ( $args->{-text} ) {
            $lText = $frame->Label(
                -font       => $self->{defaultFont},
                -justify    => 'left',
                -anchor     => 'w',
                -wraplength => $wrap,
                -justify    => "left",
                -text       => $args->{-text},
                -background => $frame->cget("-background"),
              )->pack(
                -side   => 'top',
                -expand => 0,
                -fill   => 'x',
                -pady   => 10,
              );
        }
        else {
            $frame->Label();
        }
    }

    if (DEBUG_FRAME){
    	$lTitle->configure( -background => 'light blue' );
    	$lSub->configure( -background   => 'light green' );
    	Tk::Exists($lText) && $lText->configure( -background => 'pink' );
	}

    DEBUG "blank_frame(), raw -wait is ".($args->{-wait} || "undef");
    $args->{ -wait } ||= 0;
    DEBUG "blank_frame(), cooked -wait is now $args->{-wait}";

    if ( $args->{ -wait } > 0 ) {
        _fix_wait( \$args->{ -wait } );
        DEBUG  "In blank_frame(), fixed  -wait is $args->{-wait}";
        DEBUG  "Installing 'after', self is $self";
        $self->after(
            $args->{ -wait },
            sub {
				DEBUG "Waiting...";
                $self->{nextButton}->configure( -state => 'normal' );
                $self->{nextButton}->invoke;
            }
        );
    }

    return $frame->pack(qw/-side top -anchor n -fill both -expand 1/);
}

sub addPage {
    TRACE "Enter addPage";
    my ($self, @args) = @_;

	# Bit faster if, as of old, all args are code refs (ie no events):
	if ( scalar(grep { ref $_ eq 'CODE' } @args) == scalar(@args)) {
	   DEBUG "Add args to make ".scalar @{ $self->{_pages} };
	   push @{ $self->{_pages} }, @args;
    }

	# Add pages with arguments:
    else {
		my ($code, @sub_args, $found);
		while (@args){
			if (ref $args[0] eq 'CODE'){
				$found = 1;
				if (defined $code){
					DEBUG "Call _addPage_with_args...";
					$self->_addPage_with_args($code, @sub_args);
				} else {
					DEBUG "No code yet...";
				}
				@sub_args = ();
				$code = shift @args;
			} else {
				DEBUG "Add to sub_args...";
				push @sub_args, shift(@args), shift(@args);
			}
		}

		if (defined $code){
			$found = 1;
			DEBUG "Call _addPage_with_args (finally)";
			$self->_addPage_with_args($code, @sub_args);
		}

		if (not $found){
			DEBUG "No code ref found: blank frame from args: ", join", ",@sub_args;
			push @{ $self->{_pages} }, sub { $self->blank_frame(@sub_args) };
		}

	}

	TRACE "Leave addpage";
	return scalar @{ $self->{_pages} };
}


sub _addPage_with_args {
    TRACE "Enter _addPage_with_args";
    my ($self, $code) = (shift, shift);
	my $args = scalar(@_)? {@_} : {};

	# Add the page
	DEBUG "Adding code ".Dumper $code;
    push @{ $self->{_pages} }, $code;

	# Add the arguments
	DEBUG "ARGS ",Dumper $args;
	foreach my $e (@PAGE_EVENT_LIST){
		DEBUG "Add $e for $#{$self->{_pages}}" if defined $args->{$e};
		$self->{_pages_e}->{$e}->[ $#{$self->{_pages}} ] = $args->{$e} || undef;
	}
	TRACE "Leave _addPage_with_args";
}

sub addSplashPage {
    TRACE "Enter addSplashPage";
    my ($self, $args) = (shift, {@_});
    return $self->addPage( sub { $self->blank_frame(%$args) } );
}

sub addTextFramePage {
    my ($self, $args) = (shift, {@_});
    DEBUG "addTextFramePage args are ", Dumper($args);
    return $self->addPage( sub { $self->_text_frame($args) } );
}

sub _text_frame {
    my $self = shift;
    my $args = shift;

    DEBUG "Enter _text_frame with ", Dumper($args);
    my $text;
    my $frame = $self->blank_frame(%$args);
    if ( $args->{-boxedtext} ) {
        if ( ref $args->{-boxedtext} eq 'SCALAR' ) {
            $text = $args->{-boxedtext};
        }
        elsif ( not ref $args->{-boxedtext} ) {
            open my $in, $args->{-boxedtext}
            	or Carp::croak "Could not read file: $args->{-boxedtext}; $!";
            read $in, $$text, -s $in;
            close $in;
            WARN "Boxedtext file $args->{-boxedtext} is empty." if not length $text;
        }
    }
    $$text = "" if not defined $text;
    my $t = $frame->Scrolled(
        "ROText",
        -background => ( $args->{ -background } || 'white' ),
        -relief => "sunken",
        -borderwidth => "1",
        -font        => $self->{defaultFont},
        -scrollbars  => "osoe",
        -wrap        => "word",
    )->pack(qw/-expand 1 -fill both -padx 10 -pady 10/);

    $t->configure( -background => 'green' ) if DEBUG_FRAME;
	$t->insert( '0.0', $$text );
    $t->configure( -state => "disabled" );

    return $frame;
}

#
# Function (NOT a method!):       _dispatch
# Description:  Thin wrapper to dispatch event cycles as needed
# Parameters:    The _dispatch function is an internal function used to determine if the dispatch back reference
#         is undefined or if it should be dispatched.  Undefined methods are used to denote dispatchback
#         methods to bypass.  This reduces the number of method dispatches made for each handler and also
#         increased the usability of the set methods when trying to unregister event handlers.
#
sub _dispatch {
    my $handler = shift;
    DEBUG "Enter _dispatch with " . ( $handler || "undef" );

    if ( ref($handler) eq 'Tk::Callback' ) {
        return !$handler->Call();
    }
    if ( ref($handler) eq 'CODE' ) {
        return !$handler->();
    }

    return 1;

    # Below is the original 1.9451 version:
    return ( !( $handler->Call() ) )
      if defined $handler
          and ref $handler
          and ref $handler eq 'CODE';

    return 0;
}

# Returns the number of the last page (zero-based):
sub _last_page {
    my $self = shift;
    my $i    = $#{ $self->{_pages} };
    return $i;
}

# Returns true if the current page is the last page:
sub _on_last_page {
    my $self = shift;
    DEBUG "_on_last_page(), pagePtr is $self->{_current_page_idx}";
    return ( $self->_last_page == $self->{_current_page_idx} );
}

# Returns true if the current page is the first page:
sub _on_first_page {
    my $self = shift;
    return ( 0 == $self->{_current_page_idx} );
}

# Method:      _NextButtonEventCycle
# Description: Runs the complete view of the action handler cycle for the "Next>" button on the
#              wizard button bar. This includes dispatching the preNextButtonAction and
#              postNextButtonAction handler at the appropriate times.
#
# Dictat: Never ever use goto unless you have a very good reason, and please explain that reason
#
sub _NextButtonEventCycle {
    my $self = shift;
    TRACE "Enter _NextButtonEventCycle";
    $self->{_inside_nextButtonEventCycle_}++ unless shift;

    DEBUG "NBEC counter == $self->{_inside_nextButtonEventCycle_}";

    # If there is more than one pending invocation, we will reinvoke
    # ourself when we're done:
    if ( $self->{_inside_nextButtonEventCycle_} > 1) {
#	    $self->{_inside_nextButtonEventCycle_}--;
        DEBUG "Called recursively, bail out";
        return;
    }

	# XXX DEBUG "Page $self->{_current_page_idx} -preNextButtonAction";
    if ( _dispatch( $self->cget( -preNextButtonAction ) ) ) {
        INFO "preNextButtonAction says we should not go ahead";
	    $self->{_inside_nextButtonEventCycle_}--;
		return;
    }

    if ( $self->_on_last_page ) {
        DEBUG "On the last page";
        if ( _dispatch( $self->cget( -preFinishButtonAction ) ) ) {
            DEBUG "preFinishButtonAction says we should not go ahead";
		    $self->{_inside_nextButtonEventCycle_}--;
            return;
        }
        elsif ( _dispatch( $self->cget( -finishButtonAction ) ) ) {
            DEBUG "finishButtonAction says we should not go ahead";
		    $self->{_inside_nextButtonEventCycle_}--;
        	return;
        }
        else {
        	$self->{really_quit}++;
        	$self->_CloseWindowEventCycle();
		}
    }

	# Advance the wizard page pointer and then adjust the navigation buttons.
	# Redraw the frame when finished to get changes to take effect.
	else {
		TRACE "OK - advance to next page";
		$self->_page_forward;
		$self->_render_current_page;
	}

    DEBUG "Before _dispatch postNextButtonAction";
    if ( _dispatch( $self->cget( -postNextButtonAction ) ) ) {
        INFO "postNextButtonAction says we should not go ahead";
	    $self->{_inside_nextButtonEventCycle_}--;
        return;
    }

    DEBUG "all done, NBEC counter is now $self->{_inside_nextButtonEventCycle_}";

    $self->{_inside_nextButtonEventCycle_}--;

    $self->_NextButtonEventCycle('no increment') if $self->{_inside_nextButtonEventCycle_};
}


# Move the wizard pointer back one position and then adjust the
# navigation buttons to reflect any state changes. Don't fall off
# end of page pointer
sub _BackButtonEventCycle {
    my $self = shift;
    return if _dispatch( $self->cget( -preBackButtonAction ) );
    $self->_page_backward;
    $self->_render_current_page;
    if ( _dispatch( $self->cget( -postBackButtonAction ) ) ) { return; }
	return;
}

sub _HelpButtonEventCycle {
    my $self = shift;
    if ( _dispatch( $self->cget( -preHelpButtonAction ) ) )  { return; }
    if ( _dispatch( $self->cget( -helpButtonAction ) ) )     { return; }
    if ( _dispatch( $self->cget( -postHelpButtonAction ) ) ) { return; }
}

sub _CancelButtonEventCycle {
    my $self = shift;
    return
      if $self->Callback( -preCancelButtonAction => $self->{-preCancelButtonAction} );
    $self->_CloseWindowEventCycle($_);
}

sub _CloseWindowEventCycle {
    my $self = shift;
    my $gui  = shift;
    TRACE "Enter _CloseWindowEventCycle... really=[", ($self->{really_quit} || 'undef'), "]";

    if ( not $self->{really_quit} ) {
        DEBUG "Really?";
        if ( $self->Callback( -preCloseWindowAction => $self->{-preCloseWindowAction} ) ) {
            DEBUG "preCloseWindowAction says we should not go ahead";
            return;
        }
    }
    if ( Tk::Exists($gui) ) {
        DEBUG "gui=$gui= withdraw";
        $gui->withdraw;
    }

    if ( $self->{Configure}{-kill_parent_on_destroy} and Tk::Exists( $self->parent ) ) {
        DEBUG "Kill parent " . $self->parent . " " . $self->{Configure}{ -parent };
        # This should kill us, too:
        $self->parent->destroy;
        return;
    }

    DEBUG "Legacy withdraw";
    $self->{_showing} = 0;
    if ( $self->{Configure}{-kill_self_after_finish} ) {
        $self->destroy;
    }
    else {
        $self->withdraw;    # Legacy
    }
    return undef;
}

sub Show {
	TRACE "Enter Show";
    my $self = shift;
    return if $self->{_showing};

    if ( $self->_last_page < 2 ) {
		my $lp = $self->_last_page + 1;
        warnings::warnif(
			ref($self), "Showing a Wizard with "
    	    . $lp . ' page' . ($lp==1? '' : 's').'!'
		)
    }

    $self->{_current_page_idx} = 0;
    $self->_initial_layout;

    $self->resizable( 0, 0 )
      unless $self->{Configure}{-resizable}
         and $self->{Configure}{-resizable} =~ /^(1|yes|true)$/i;

    $self->parent->withdraw;
    $self->Popup;
    $self->transient;    # forbid minimize
    $self->protocol( WM_DELETE_WINDOW => [ \&_CloseWindowEventCycle, $self, $self ] );

    # $self->packPropagate(0);
    $self->configure( -background => $self->cget("-background") );
    $self->_render_current_page;
    $self->{_showing} = 1;

    TRACE "Leave Show";
    return 1;
}

sub forward {
    my $self = shift;
    return $self->_NextButtonEventCycle;
}

sub backward {
    my $self = shift;
    return $self->{backButton}->invoke;
}

sub _showing_side_banner {
    my $self = shift;
    return 1 if ( $self->cget( -style ) eq '95' );
    return 1 if $self->_on_first_page;
    return 1 if $self->_on_last_page;
    return 0;
}

sub currentPage {
    my $self = shift;
    # Throughout this module, the internal _current_page_idx is zero-based.  But we
    # "publish" it as one-based:
    return $self->{_current_page_idx} + 1;
}

sub setPageSkip {
    my $self = shift;
	# The user's argument is 1-based, but our internal data structures
	# are zero-based, thus subract 1:
    foreach my $i (@_) {
        $self->{page_skip}{ $i - 1 } = 1;
    }
}

sub setPageUnskip {
    my $self = shift;
	# The user's argument is 1-based, but our internal data structures
	# are zero-based, thus subtract 1:
    foreach my $i (@_) {
        $self->{page_skip}{ $i - 1 } = 0;
    }
}

sub next_page_number {
    my $self  = shift;
	return $self->_next_page_number + 1;
}


# _next_page_number
# As public, but value is minus one
#
sub _next_page_number {
    my $self  = shift;
    my $i = $self->{_current_page_idx};
    DEBUG "_page_forward($i -->";

    do {
        $i++;
    } until (
		not $self->{page_skip}->{$i} or $self->_last_page <= $i
    );
    $i = $self->_last_page if ( $self->_last_page < $i );

    DEBUG " $i)\n";
    return $i;
}

# Increments the page pointer forward to the next logical page,
# honouring the Skip flags:
sub _page_forward {
    my $self = shift;
    $self->{_current_page_idx} = $self->_next_page_number;
}

# sub back_page_number {
#    my $self  = shift;
#    my $iPage = $self->{_current_page_idx};
#    do {
#        $iPage--;
#    } until ( !$self->{page_skip}{$iPage} || ( $iPage <= 0 ) );
#    $iPage = 0 if ( $iPage < 0 );
#    return $iPage;
# }

sub back_page_number {
	my $self = shift;
	return $self->_back_page_number + 1;
}

sub _back_page_number {
	my $self = shift;
    my $iPage = $self->{_current_page_idx};
    do {
        $iPage--;
    } until ( !$self->{page_skip}{$iPage} || ( $iPage <= 0 ) );
    $iPage = 0 if ( $iPage < 0 );
    return $iPage;
}


# Decrements the page pointer backward to the previous logical page,
# honouring the Skip flags:
sub _page_backward {
    my $self = shift;
    $self->{_current_page_idx} = $self->_back_page_number;
}

sub prompt {
    my $self = shift;
    my $args = {@_};
    my ( $d, $w );
    my $input = $self->cget( -value );
    $d = $self->DialogBox(
        -title => $args->{-title} || "Prompt",
        -buttons        => [ $LABELS{CANCEL}, $LABELS{OK} ],
        -default_button => $LABELS{OK},
    );

    if ( $args->{-text} ) {
        $w = $d->add(
            "Label",
            -font       => $self->{defaultFont},
            -text       => $args->{-text},
            -width      => 40,
            -wraplength => $args->{-wraplength} || 275,
            -justify    => 'left',
            -anchor     => 'w',
        )->pack();
    }

    $w = $d->add(
        "Entry",
        -font         => $self->{defaultFont},
        -relief       => "sunken",
        -width        => $args->{-width} || 40,
        -background   => "white",
        -justify      => 'left',
        -textvariable => \$input,
    )->pack(qw( -padx 2 -pady 2 -expand 1 ));

    $d->Show;
    return $input ? $input : undef;
}

#
# Using a -wait value for After of less than this seems to cause a weird Tk dump
# so call this whenever using a -wait
#
sub _fix_wait {
    my $wait_ref = shift;
    $$wait_ref += 200 if $$wait_ref < 250;
}

sub DIALOGUE_really_quit {
    my $self = shift;
    TRACE "Enter DIALOGUE_really_quit";
    return 0 if $self->{nextButton}->cget( -text ) eq $LABELS{FINISH};

    unless ( $self->{really_quit} ) {
        DEBUG "# Get really quit info";
        my $button = $self->messageBox(
            '-icon'  => 'question',
            -type    => 'yesno',
            -default => 'no',
            -title   => 'Quit Wizard?',
            -message => "The Wizard has not finished running.\n\n"
            	. "If you quit now, the job will not be complete.\n\nDo you really wish to quit?"
        );
        $self->{really_quit} = lc $button eq 'yes' ? 1 : 0;
        DEBUG "# ... really=[$self->{really_quit}]";
    }
    return !$self->{really_quit};
}

REDEFINES:
{
    no warnings 'redefine';
    sub Tk::ErrorOFF {
        DEBUG "This is Martin's Tk::Error\n";
        my ( $oWidget, $sError, @asLocations ) = @_;
        local $, = "\n";
        print STDERR @asLocations;
    }
}

1;

__END__