File Coverage

blib/lib/Tk/Wizard.pm
Criterion Covered Total %
statement 28 30 93.3
branch n/a
condition n/a
subroutine 10 10 100.0
pod n/a
total 38 40 95.0


line stmt bran cond sub pod time code
1             package Tk::Wizard;
2              
3 6     6   8598 use strict;
  6         13  
  6         303  
4 6     6   37 use warnings;
  6         10  
  6         238  
5 6     6   32 use warnings::register;
  6         11  
  6         1010  
6              
7 6     6   37 use vars '$VERSION';
  6         9  
  6         712  
8             $VERSION = do { my @r = ( q$Revision: 2.084 $ =~ /\d+/g ); sprintf "%d." . "%03d" x $#r, @r };
9              
10             =head1 NAME
11              
12             Tk::Wizard - GUI for step-by-step interactive logical process
13              
14             =cut
15              
16 6     6   39 use Carp;
  6         11  
  6         538  
17 6     6   36 use Config;
  6         11  
  6         290  
18 6     6   4811 use Data::Dumper;
  6         39370  
  6         668  
19 6     6   88 use File::Path;
  6         13  
  6         504  
20 6     6   4625 use File::Spec::Functions qw( rootdir );
  6         5626  
  6         581  
21 6     6   3896 use Tk;
  0            
  0            
22             use Tk::DialogBox;
23             use Tk::Frame;
24             use Tk::Font;
25             use Tk::MainWindow;
26             use Tk::ROText;
27             use Tk::Wizard::Image;
28             use Tk::JPEG;
29             use Tk::PNG;
30              
31             use constant DEBUG_FRAME => 0;
32              
33             use vars qw( @EXPORT @ISA %LABELS );
34              
35             # use Log4perl if we have it, otherwise stub:
36             # See Log::Log4perl::FAQ
37             BEGIN {
38             eval { require Log::Log4perl; };
39              
40             # No Log4perl so bluff: see Log4perl FAQ
41             if($@) {
42             no strict qw"refs";
43             *{__PACKAGE__."::$_"} = sub { } for qw(TRACE DEBUG INFO WARN ERROR FATAL);
44             }
45              
46             # Setup log4perl
47             else {
48             no warnings;
49             no strict qw"refs";
50             require Log::Log4perl::Level;
51             Log::Log4perl::Level->import(__PACKAGE__);
52             Log::Log4perl->import(":easy");
53             # It took four CPAN uploads and tests to workout why
54             # one user was getting syntax errors for TRACE: must
55             # be the Mithrasmas spirit (hic):
56             if ($Log::Log4perl::VERSION < 1.11){
57             *{__PACKAGE__."::TRACE"} = *DEBUG;
58             }
59             }
60              
61             require Exporter; # Exporting Tk's MainLoop so that
62             @ISA = ( "Exporter", ); # I can just use strict and Tk::Wizard without
63             @EXPORT = ("MainLoop"); # having to use Tk
64             }
65              
66             use base qw[ Tk::Derived Tk::Toplevel ];
67             Tk::Widget->Construct('Wizard');
68              
69             # See INTERNATIONALISATION
70             %LABELS = (
71             # Buttons
72             BACK => "< Back",
73             NEXT => "Next >",
74             FINISH => "Finish",
75             CANCEL => "Cancel",
76             HELP => "Help",
77             OK => "OK",
78             );
79              
80             my $WINDOZE = ($^O =~ m/MSWin32/i);
81             my @PAGE_EVENT_LIST = qw(
82             -preNextButtonAction
83             -postNextButtonAction
84             -preBackButtonAction
85             -postBackButtonAction
86             );
87              
88             my $REFRESH_MS = 1000; # Refresh the wizard every REFRESH_MS milliseconds
89              
90             =head1 SYNOPSIS
91              
92             use Tk::Wizard ();
93             my $wizard = new Tk::Wizard;
94             # OR my $wizard = Tk::MainWindow->new -> Wizard();
95             $wizard->configure( -property=>'value' );
96             $wizard->cget( "-property");
97             # $wizard->addPage(
98             # ... code-ref to anything returning a Tk::Frame ...
99             # );
100             $wizard->addPage(
101             sub {
102             return $wizard->blank_frame(
103             -title => "Page Title",
104             -subtitle => "Sub-title",
105             -text => "Some text.",
106             -wait => $milliseconds_b4_proceeding_anyway,
107             );
108             }
109             );
110             $wizard->addPage(
111             sub { $wizard->blank_frame(@args) },
112             -preNextButtonAction => sub { warn "My -preNextButtonAction called here" },
113             -postNextButtonAction => sub { warn "My -postNextButtonAction called here" },
114             );
115             $wizard->Show;
116             MainLoop;
117             exit;
118              
119             To avoid 50 lines of SYNOPSIS, please see the files included with the
120             distribution in the test directory: F. These are just Perl
121             programs that are run during the C phase of installation: you
122             can move/copy/rename them without harm once you have installed the module.
123              
124             =head1 CHANGES
125              
126             Please see the file F included with the distribution for change history.
127              
128             =head1 DEPENDENCIES
129              
130             C and modules of the current standard Perl Tk distribution.
131              
132             On MS Win32 only: C.
133              
134             =head1 EXPORTS
135              
136             MainLoop();
137              
138             This is so that I can say C without
139             having to C. You can always C to avoid
140             importing this.
141              
142             =head1 DESCRIPTION
143              
144             In the context of this name space, a Wizard is defined as a graphic user interface (GUI)
145             that presents information, and possibly performs tasks, step-by-step via a series of
146             different pages. Pages (or 'screens', or 'Wizard frames') may be chosen logically depending
147             upon user input.
148              
149             The C module automates a large part of the creation of a wizard program
150             to collect information and then perform some complex task based upon it.
151              
152             The wizard feel is largely based upon the Microsoft(TM,etc) wizard style: the default is
153             similar to that found in Windows 2000, though the more traditional Windows 95-like feel is also
154             supported (see the C<-style> entry in L. Sub-classing the
155             module to provide different look-and-feel is highly encourage: please see
156             L. If anyone would like to do a I or
157             I version, please let me know how you would like to handle the buttons. I'm not
158             hot on advertising widgets.
159              
160             =head1 ADVERTISED SUB-WIDGETS
161              
162             my $subwidget = $wizard->Subwidget('buttonPanel');
163              
164             =over 4
165              
166             =item buttonPanel
167              
168             The C that holds the navigation buttons and optional help button.
169              
170             =item nextButton
171              
172             =item backButton
173              
174             =item cancelButton
175              
176             =item helpButton
177              
178             The buttons in the C.
179              
180             =item tagLine
181              
182             The line above the C, a L object.
183              
184             =item tagText
185              
186             The grayed-out text above the C, a L object.
187              
188             =item tagBox
189              
190             A L holding the tagText and tagLine.
191              
192             =item imagePane
193              
194             On all pages of a C<95>-style Wizard,
195             and for the first and last pages of the default c-style Wizard,
196             this is a large pane on the left, that holds an image.
197             For the other pages of a C-style Wizard, this refers to the image box at the top of the wizard.
198              
199             =item wizardFrame
200              
201             The frame that holds the content frame, the current Wizard page.
202              
203             =back
204              
205             =head1 STANDARD OPTIONS
206              
207             =over 4
208              
209             =item -title
210              
211             Text that appears in the title bar.
212              
213             =item -background
214              
215             Main background colour of the Wizard's window.
216              
217             =back
218              
219             =head1 WIDGET-SPECIFIC OPTIONS
220              
221             =over 4
222              
223             =item Name: style
224              
225             =item Class: Style
226              
227             =item Switch: -style
228              
229             Sets the display style of the Wizard.
230              
231             The default no-value or value of C gives the Wizard will be a Windows 2000-like
232             look, with the initial page being a version of the traditional
233             style with a white background, and subsequent pages being C coloured,
234             with a white strip at the top holding a title and subtitle, and a smaller image (see
235             C<-topimagepath>, below).
236              
237             The old default of C<95> is still available, if you wish to create a traditional,
238             Windows 95-style wizard, with every page being C coloured, with a
239             large image on the left (C<-imagepath>, below).
240              
241             =item Name: imagepath
242              
243             =item Class: Imagepath
244              
245             =item Switch: -imagepath
246              
247             Path to an image that will be displayed on the left-hand side
248             of the screen. (Dimensions are not constrained.) One of either:
249              
250             =over 4
251              
252             =item *
253              
254             Path to a file from which to construct a L
255             object without the format being specified;
256             No checking is done, but paths ought to be absolute, as no effort
257             is made to maintain or restore any initial current working directory.
258              
259             =item *
260              
261             A reference to a Base64-encoded image to pass in the C<-data> field of the
262             L object. This is the default form, and a couple
263             of extra, unused images are supplied: see L.
264              
265             =back
266              
267             =item Name: topimagepath
268              
269             =item Class: Topimagepath
270              
271             =item Switch: -topimagepath
272              
273             Only required if C<-style=E'top'> (as above): the image
274             this filepath specifies
275             will be displayed in the top-right corner of the screen. Dimensions are not
276             restrained (yet), but only 50x50 has been tested.
277              
278             Please see notes for the C<-imagepath>>.
279              
280             =item Name: nohelpbutton
281              
282             =item Class: Nohelpbutton
283              
284             =item Switch: -nohelpbutton
285              
286             Set to anything to disable the display of the I button.
287              
288             =item Name: resizable
289              
290             =item Class: resizable
291              
292             =item Switch: -resizable
293              
294             Supply a boolean value to allow resizing of the window: default
295             is to disable that feature to minimise display issues.
296              
297             =item Switch: -tag_text
298              
299             Text to supply in a 'tag line' above the wizard's control buttons.
300             Specify empty string to disable the display of the tag text box.
301              
302             =item -fontfamily
303              
304             Specify the "family" (ie name) of the font you want to use for all Wizard elements.
305             The default is your operating system default (or a sans serif), which on my test computers is
306             "MS Sans Serif" on Windows, "Helvetica" on Linux, and "Helvetica" on Solaris.
307              
308             =item -basefontsize
309              
310             Specify the base size of the font you want to use for all Wizard elements.
311             Titles and subtitles will be drawn a little larger than this;
312             licenses (the proverbial fine print) will be slightly smaller.
313             The default is your operating system default, which on my test computers is
314             8 on Windows, 12 on Linux, and 12 on Solaris.
315              
316             =item -width
317              
318             Specify the width of the CONTENT AREA of the Wizard, for all pages.
319             The default width (if you do not give any -width argument) is 50 * the basefontsize.
320             You can override this measure for a particular page by supplying a -width argument to the add*Page() method.
321              
322             =item -height
323              
324             Specify the height of the CONTENT AREA of the Wizard, for all pages.
325             The default height (if you do not give any -height argument) is 3/4 the default width.
326             You can override for a particular page by supplying a -height argument to the add*Page() method.
327              
328             =item -kill_self_after_finish
329              
330             The default for the Wizard is to withdraw itself after the "finish"
331             (or "cancel") button is clicked. This allows the Wizard to be reused
332             during the same session (the Wizard will be destroyed when its parent
333             MainWindow is destroyed).
334             If you supply a non-zero value to this option,
335             the Wizard will instead be destroyed after the "finish" button is clicked.
336              
337             =back
338              
339             Please see also L.
340              
341             =head2 WIZARD REFRESH RATE
342              
343             C<$Tk::Wizard::REFRESH_MS> is the number of milliseconds
344             after which an C will be called to redraw the Wizard.
345             Current value is one second.
346              
347             =head1 METHODS
348              
349             =head2 import
350              
351             use Tk::Wizard;
352             use Tk::Wizard ();
353             use Tk::Wizard ':old';
354             use Tk::Wizard ':use' => [qw[ Choices FileSystem ]];
355              
356             All the above examples are currently equivalent. However,
357             as of version 3.00, later in 2008, the first two will no
358             longer act as the last two -- that is, they will no longer
359             import the methods now located in the C and
360             C modules (L, L):
361             you will have to do that yourself, as in the final example,
362             or manuall:
363              
364             use Tk::Wizard;
365             use Tk::Wizard::Tasks;
366              
367             =cut
368              
369             sub import {
370             my $inv = shift;
371             # The default `use module ()` messes up the logic below; fix with:
372             shift if scalar(@_) and not defined $_[0];
373              
374             DEBUG "Enter import for ".$inv;
375             if (scalar @_){
376             DEBUG "Import list : ", join(",",@_);
377             } else {
378             DEBUG "No import list";
379             }
380              
381             # Maintian backwards compatabilty while $VERSION < 3
382             if (not scalar(@_) or $_[0] eq ':old'){
383              
384             require Tk::Wizard::Choices;
385             Tk::Wizard::Choices->import if Tk::Wizard::Choices->can('import');
386              
387             require Tk::Wizard::FileSystem;
388             Tk::Wizard::FileSystem->import if Tk::Wizard::FileSystem->can('import');
389              
390             require Tk::Wizard::Tasks;
391             Tk::Wizard::Tasks->import if Tk::Wizard::Tasks->can('import');
392             }
393              
394             elsif (scalar @_ == 1){
395             if ($_[0] eq ':none'){
396             DEBUG "Load no modules";
397             }
398             }
399              
400             elsif ($_[0] eq ':use'){
401             shift; # drop :use - everything else is a sub-module sub-name
402             my $use = shift;
403             foreach my $m (ref $use? @$use : $use){
404             my $n = 'Tk::Wizard::'.$m.'.pm';
405             my $o = $n;
406             $n =~ s/::/\//g;
407             # require Tk::Wizard::Choices;
408             require $n;
409             $o->import;
410             }
411             }
412              
413             return @_;
414             }
415              
416              
417             =head2 new
418              
419             Create a new C object. You can provide custom values for any
420             or all of the standard widget options or widget-specific options
421              
422             =cut
423              
424             # The method is overridden to allow us to supply a MainWindow if one
425             # is not supplied by the caller. Not supplying one suits me, but Mr.
426             # Rothenberg requires one, and he was probably right.
427              
428             sub new {
429             TRACE "Enter new with ", (@_ || 'nothing');
430             my $inv = ref( $_[0] ) ? ref( $_[0] ) : $_[0];
431             shift; # Ignore invocant
432              
433             my @args = @_;
434              
435             unless (
436             ( scalar(@_) % 2 ) # Not a simple list
437             and ref $args[0] # Already got a MainWindow
438             ) {
439             # Get a main window:
440             unshift @args, Tk::MainWindow->new;
441             push @args, "-parent" => $args[0];
442             push @args, "-kill_parent_on_destroy" => 1;
443             $args[0]->optionAdd( '*BorderWidth' => 1 );
444             }
445             my $self = $inv->SUPER::new(@args);
446             my $sFontFamily = $self->cget( -fontfamily );
447             my $iFontSize = $self->cget( -basefontsize );
448              
449             # Font used for &blank_frame titles
450             $self->fontCreate(
451             'TITLE_FONT',
452             -family => $sFontFamily,
453             -size => $iFontSize + 4,
454             -weight => 'bold',
455             );
456             $self->fontCreate(
457             'FIXED',
458             -family => 'Courier',
459             -size => $iFontSize + 1,
460             );
461              
462             # Font used in multiple choices for radio title
463             $self->fontCreate(
464             'RADIO_BOLD',
465             -family => $sFontFamily,
466             -size => $iFontSize + 2,
467             -weight => 'demi',
468             );
469              
470             # Fonts used if -style=>"top"
471             $self->fontCreate(
472             'TITLE_FONT_TOP',
473             -family => $sFontFamily,
474             -size => $iFontSize + 4,
475             -weight => 'bold',
476             );
477             $self->fontCreate(
478             'SUBTITLE_FONT',
479             -family => $sFontFamily,
480             -size => $iFontSize + 2,
481             );
482              
483             # Font used in licence agreement XXX REMOVE TO CORRECT MODULE
484             $self->fontCreate(
485             'SMALL_FONT',
486             -family => $sFontFamily,
487             -size => $iFontSize - 1,
488             );
489              
490             # Font used in all other places
491             $self->fontCreate(
492             'DEFAULT_FONT',
493             -family => $sFontFamily,
494             -size => $iFontSize,
495             );
496             $self->{defaultFont} = 'DEFAULT_FONT';
497             $self->{tagtext}->configure( -font => $self->{defaultFont} );
498              
499             if ( !$self->cget('-width') ) {
500             # Caller apparently did not supply a -width argument to new():
501             $self->configure( -width => $iFontSize * 50 );
502             }
503              
504             if ( !$self->cget('-height') ) {
505             # Caller apparently did not supply a -height argument to new():
506             $self->configure( -height => $self->cget( -width ) * 0.75 );
507             }
508             return $self;
509             }
510              
511             =head2 Populate
512              
513             This method is part of the underlying Tk inheritance mechanisms.
514             You the programmer do not necessarily even need to know it exists;
515             we document it here only to satisfy Pod coverage tests.
516              
517             =cut
518              
519             sub Populate {
520             my ( $self, $args ) = @_;
521             TRACE "Enter Populate";
522             $self->SUPER::Populate($args);
523             $self->withdraw;
524             my $sTagTextDefault = 'Perl Wizard';
525             my $iFontSize = $self->_font_size;
526              
527             # $composite->ConfigSpecs(-attribute => [where,dbName,dbClass,default]);
528             $self->ConfigSpecs(
529             -resizable => [ 'SELF', 'resizable', 'Resizable', undef ],
530              
531             # Potentially a MainWindow:
532             -parent => [ 'PASSIVE', undef, undef, undef ],
533             -command => [ 'CALLBACK', undef, undef, undef ],
534              
535             # -foreground => ['PASSIVE', 'foreground','Foreground', 'black'],
536             -background =>
537             [ 'METHOD', 'background', 'Background', $WINDOZE? 'SystemButtonFace' : 'gray90' ],
538             -style => [ 'PASSIVE', "style", "Style", "top" ],
539             -imagepath => [ 'PASSIVE', 'imagepath', 'Imagepath', \$Tk::Wizard::Image::LEFT{WizModernImage} ],
540             -topimagepath => [ 'PASSIVE', 'topimagepath', 'Topimagepath', \$Tk::Wizard::Image::TOP{WizModernSmallImage} ],
541              
542             # event handling references
543             -nohelpbutton => [ 'CALLBACK', undef, undef, sub { 1 } ],
544             -preNextButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
545             -postNextButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
546             -preBackButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
547             -postBackButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
548             -preHelpButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
549             -helpButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
550             -postHelpButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
551             -preFinishButtonAction => [ 'CALLBACK', undef, undef, sub { 1 } ],
552             -finishButtonAction => [ 'CALLBACK', undef, undef, sub { $self->withdraw; 1 } ],
553              
554             -kill_parent_on_destroy => [ 'PASSIVE', undef, undef, 0 ],
555             -kill_self_after_finish => [ 'PASSIVE', undef, undef, 0 ],
556             -debug => [ 'PASSIVE', undef, undef, 0 ],
557             -preCloseWindowAction => [ 'CALLBACK', undef, undef, sub { $self->DIALOGUE_really_quit } ],
558             -tag_text => [ 'PASSIVE', "tag_text", "TagText", $sTagTextDefault ],
559             -tag_width => [ 'PASSIVE', "tag_width", "TagWidth", 0 ],
560             -wizardFrame => [ 'PASSIVE', undef, undef, 0 ],
561             -width => [ 'PASSIVE', undef, undef, 0 ],
562             -height => [ 'PASSIVE', undef, undef, 0 ],
563             -basefontsize => [ 'PASSIVE', undef, undef, $self->_font_size ],
564             -fontfamily => [ 'PASSIVE', undef, undef, $self->_font_family ],
565             );
566              
567             if ( exists $args->{-imagepath}
568             and not ref($args->{-imagepath}) eq 'SCALAR' and not -e $args->{-imagepath}
569             ) {
570             Carp::confess "Can't find file at -imagepath: " . $args->{-imagepath};
571             }
572             if ( exists $args->{-topimagepath}
573             and not ref($args->{-imagepath}) eq 'SCALAR' and not -e $args->{-topimagepath}
574             ) {
575             Carp::confess "Can't find file at -topimagepath: " . $args->{-topimagepath};
576             }
577             $self->{-imagepath} = $args->{-imagepath};
578             $self->{-topimagepath} = $args->{-topimagepath};
579              
580             # Here's why we need Page objects
581             $self->{_pages} = [];
582              
583             # XXX Events indexed like pages
584             $self->{_pages_e} = {};
585             # $self->{_pages_e}->{ $event_name }->[ $page_idx ];
586             $self->{_pages_e}->{$_} = [] foreach @PAGE_EVENT_LIST;
587              
588             $self->{-debug} = $args->{-debug} || $Tk::Wizard::DEBUG || undef;
589             $self->{background_userchoice} = $args->{-background} || $self->ConfigSpecs->{-background}[3];
590             $self->{background} = $self->{background_userchoice};
591             $self->{-style} = $args->{-style} || "top";
592             $self->{_current_page_idx} = 0;
593              
594             # $self->overrideredirect(1); # Removes borders and controls
595             CREATE_BUTTON_PANEL: {
596             my $buttonPanel = $self->Frame( -background => $self->{background}, )->pack(qw/ -side bottom -fill x/);
597             $buttonPanel->configure( -background => 'yellow' ) if DEBUG_FRAME;
598              
599             # right margin:
600             my $f = $buttonPanel->Frame(
601             -width => 5,
602             -background => $self->{background},
603             )->pack( -side => "right", -expand => 0 );
604             $f->configure( -background => 'red' ) if DEBUG_FRAME;
605             $self->Advertise( buttonPanel => $buttonPanel );
606             }
607              
608             CREATE_TAGLINE: {
609             my $tagbox = $self->Frame(
610             -height => 12,
611             -background => $self->{background},
612             )->pack(qw/-side bottom -fill x/);
613             $tagbox->configure( -background => 'magenta' ) if DEBUG_FRAME;
614              
615             # This is a new, simpler, accurate-width Label way of doing it:
616             $self->{tagtext} = $tagbox->Label(
617             -border => 2,
618             -foreground => 'gray50',
619             -background => $self->{background},
620             );
621             $self->{tagtext}->configure( -background => 'red' ) if DEBUG_FRAME;
622             $self->_maybe_pack_tag_text;
623              
624             # This is the line that extends to the right from the tag text:
625             $self->{tagline} = $tagbox->Frame(
626             -relief => 'groove',
627             -bd => 1,
628             -height => 2,
629             )->pack(qw( -side right -fill x -expand 1 ));
630             $self->{tagline}->configure( -background => 'yellow' ) if DEBUG_FRAME;
631             $self->Advertise( tagLine => $self->{tagline} );
632             $self->Advertise( tagBox => $tagbox );
633             $self->Advertise( tagText => $self->{tagtext} );
634             }
635              
636             # Desktops for dir select: thanks to Slaven Rezic who also suggested SHGetSpecialFolderLocation for Win32. l8r
637             # There is a good module for this now
638             if ($WINDOZE
639             and exists $ENV{USERPROFILE}
640             and -d "$ENV{USERPROFILE}/Desktop"
641             ) {
642             $self->{desktop_dir} = "$ENV{USERPROFILE}/Desktop";
643             }
644             elsif (exists $ENV{HOME}){
645             if ( -d "$ENV{HOME}/Desktop" ) {
646             $self->{desktop_dir} = "$ENV{HOME}/Desktop";
647             }
648             elsif ( -d "$ENV{HOME}/.gnome-desktop" ) {
649             $self->{desktop_dir} = "$ENV{HOME}/.gnome-desktop";
650             }
651             }
652              
653             }
654              
655              
656             =head2 parent
657              
658             my $apps_main_window = $wizard->parent;
659              
660             This returns a reference to the parent Tk widget that was used to create the wizard.
661              
662             =cut
663              
664             sub parent { return $_[0]->{Configure}{ -parent } || shift }
665              
666             sub _maybe_pack_tag_text {
667             my $self = shift;
668             TRACE "Enter _maybe_pack_tag_text";
669             return if ( ( $self->{Configure}{-tag_text} || '' ) eq '' );
670             $self->{tagtext}->configure( -text => $self->{Configure}{-tag_text} . ' ' );
671             $self->{tagtext}->pack(qw( -side left -padx 0 -ipadx 2 ));
672             }
673              
674             sub _pack_forget {
675             my $self = shift;
676             foreach my $o (@_) {
677             $o->packForget if Tk::Exists($o);
678             }
679             }
680              
681             # Private method: returns a font family name suitable for the
682             # operating system. (The default system font, if we can determine it)
683             sub _font_family {
684             my $self = shift;
685              
686             # Find the default font on this platform:
687             my $label = $self->Label;
688             my $sFont = $label->cget( -font );
689             return $1 if $sFont =~ /{(.+?)}/;
690             return 'Helvetica' if $^O =~ /solaris/i;
691             return 'Verdana' if $WINDOZE;
692             return 'Helvetica';
693             }
694              
695              
696             # Private method: returns a font size suitable for the operating
697             # system. (The default system font size, if we can determine it)
698             sub _font_size {
699             my $self = shift;
700              
701             # Find the default font on this platform:
702             my $label = $self->Label;
703             my $sFont = $label->cget( -font );
704              
705             # use Tk::Pretty;
706             # DEBUG Tk::Pretty::Pretty($sFont);
707             # DEBUG (" III default label font as string: font=%s=\n", $sFont);
708             return $1 if $sFont =~ /(\d+)/;
709             return 12 if $^O =~ /solaris/i;
710             return 8 if $WINDOZE;
711             return 12; # Linux etc.
712             }
713              
714              
715             =head2 background
716              
717             Get/set the background color for the body of the Wizard.
718              
719             =cut
720              
721             sub background {
722             my $self = shift;
723             my $operand = shift;
724             if ( defined($operand) ) {
725             $self->{background} = $operand;
726             }
727             elsif (( $self->{-style} ne '95' )
728             && ( $self->_on_first_page || $self->_on_last_page ) )
729             {
730             $self->{background} = 'white';
731             }
732             else {
733             $self->{background} = $self->{background_userchoice};
734             }
735             return $self->{background};
736             } # background
737              
738             #
739             # Sub-class me!
740             # Called by Show().
741             #
742             sub _initial_layout {
743             my $self = shift;
744             TRACE "Enter _initial_layout";
745             return if $self->{_laid_out};
746              
747             # Wizard 98/95 style
748             if ( $self->_showing_side_banner ) {
749             my $im = $self->cget( -imagepath );
750             if ( not ref $im ) {
751             DEBUG "Load photo from file $im";
752             FATAL "No such file as $im" unless -e $im;
753             DEBUG $self;
754             $self->Photo( "sidebanner", -file => $im );
755             }
756             else {
757             $self->Photo( "sidebanner", -data => $$im );
758             }
759             my $bg =
760             $self->_on_first_page ? 'white'
761             : $self->_on_last_page ? 'white'
762             : $self->{background};
763             $self->{left_object} = $self->Label(
764             -image => "sidebanner",
765             -anchor => "n",
766             -background => $bg,
767             )->pack(
768             -anchor => "n",
769             -fill => 'y',
770             );
771             $self->{left_object}->configure( -background => 'blue' ) if DEBUG_FRAME;
772             } # end if 95 or first page
773              
774             # Wizard 2k style - builds the left side of the wizard
775             else {
776             my $im = $self->cget( -topimagepath );
777             if ( ref $im ) {
778             $self->Photo( "topbanner", -data => $$im );
779             }
780             else {
781             $self->Photo( "topbanner", -file => $im );
782             }
783             $self->{left_object} = $self->Label( -image => "topbanner" )->pack( -side => "top", -anchor => "e", );
784             }
785             $self->Advertise( imagePane => $self->{left_object} );
786             $self->{_laid_out}++;
787             }
788              
789             #
790             # Maybe sub-class me
791             #
792             sub _render_current_page {
793             my $self = shift;
794             TRACE "Enter _render_current_page $self->{_current_page_idx}";
795             my %frame_pack = ( -side => "top" );
796              
797             $self->_pack_forget( $self->{tagtext} );
798              
799             if ( !$self->_showing_side_banner ) {
800             $self->_maybe_pack_tag_text;
801             }
802              
803             if ( $self->_on_first_page or $self->_on_last_page ) {
804             $self->{left_object}->pack( -side => "left", -anchor => "n", -fill => 'y' );
805             if ( $self->{-style} ne '95' ) {
806             $frame_pack{-expand} = 1;
807             $frame_pack{-fill} = 'both';
808             }
809             }
810              
811             elsif ( $self->cget( -style ) eq 'top' ) {
812             $self->_pack_forget( $self->{left_object} );
813             }
814              
815             # Take page-event from the store and apply to the object.
816             # These compromises are getting silly, and indicative of the
817             # need for a slight refactoring.
818             # warn "Page == $self->{_current_page_idx}";
819             foreach my $e (@PAGE_EVENT_LIST){
820             # warn "E = $e";
821             # warn Dumper $self->{_pages_e};
822             my $code = $self->{_pages_e}->{$e}->[ $self->{_current_page_idx} ] || undef;
823             # warn $code if $code;
824             if (defined $code){
825             $self->configure( $e => $code )
826             } else {
827             # $self->configure( $e => undef )
828             }
829             }
830              
831             ######################################
832             ### $self->_repack_buttons now below;
833              
834             # Process button events and re-rendering
835             my $panel = $self->Subwidget('buttonPanel');
836             my %hssPackArgs = (
837             -side => "right", -expand => 0, -pady => 5, -padx => 5, -ipadx => 8,
838             );
839             $self->_pack_forget(
840             @{ $self->{_button_spacers} },
841             $self->{cancelButton},
842             $self->{nextButton}, $self->{backButton}, $self->{helpButton},
843             );
844              
845             # No cancel button on the last page
846             unless ($self->_on_last_page ) {
847             $self->{cancelButton} = $panel->Button(
848             -font => $self->{defaultFont},
849             -text => $LABELS{CANCEL},
850             -command => [ \&_CancelButtonEventCycle, $self, $self ],
851             )->pack(%hssPackArgs);
852              
853             # Set the cancel button a little apart from the next button:
854             my $f1 = $panel->Frame(
855             -width => 8,
856             -background => $panel->cget( "-background" ),
857             )->pack( -side => "right" );
858              
859             $f1->configure( -background => 'black' ) if DEBUG_FRAME;
860             push @{ $self->{_button_spacers} }, $f1;
861             $self->Advertise( cancelButton => $self->{cancelButton} );
862             }
863              
864             $self->{nextButton} = $panel->Button(
865             -font => $self->{defaultFont},
866             -text => $self->_on_last_page ? $LABELS{FINISH} : $LABELS{NEXT},
867             -command => [ \&_NextButtonEventCycle, $self ],
868             )->pack(%hssPackArgs);
869             $self->Advertise( nextButton => $self->{nextButton} );
870              
871             $self->{backButton} = $panel->Button(
872             -font => $self->{defaultFont},
873             -text => $LABELS{BACK},
874             -command => [ \&_BackButtonEventCycle, $self ],
875             -state => $self->_on_first_page ? 'disabled' : 'normal',
876             )->pack(%hssPackArgs);
877             $self->Advertise( backButton => $self->{backButton} );
878              
879             # Optional help button:
880             unless ($self->cget( -nohelpbutton ) ) {
881             $self->{helpButton} = $panel->Button(
882             -font => $self->{defaultFont},
883             -text => $LABELS{HELP},
884             -command => [ \&_HelpButtonEventCycle, $self ],
885             )->pack(
886             -side => 'left', -anchor => 'w',
887             -pady => 10, -padx => 10,
888             -ipadx => 8,
889             );
890             $self->Advertise( helpButton => $self->{helpButton} );
891             }
892              
893              
894             ########################################
895              
896             $self->configure( -background => $self->cget("-background") );
897             $self->_pack_forget( $self->{wizardFrame} );
898              
899             if (not @{ $self->{_pages} } ) {
900             Carp::croak '_render_current_page called without any frames: did you add frames to the wizard?';
901             }
902             my $page = $self->{_pages}->[ $self->{_current_page_idx} ];
903              
904             if (not ref $page){
905             Carp::croak '_render_current_page() called for a non-existent frame: did you add frames to the wizard?';
906             }
907              
908             my $frame = $page->();
909             if (not Tk::Exists($frame) ) {
910             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);
911             }
912              
913             $self->{wizardFrame} = $frame->pack(%frame_pack);
914             $self->{wizardFrame}->update;
915              
916             # Update the wizard every 1000 seconds
917             $self->{_refresh_event_id} = $self->{wizardFrame}->repeat(
918             $REFRESH_MS,
919             sub { $self->{wizardFrame}->update }
920             ) if not $self->{_refresh_event_id};
921              
922             $self->Advertise( wizardFrame => $self->{wizardFrame} );
923              
924             # $self->_resize_window;
925             $self->{nextButton}->focus();
926             TRACE "Leave _render_current_page $self->{_current_page_idx}";
927             }
928              
929             =head2 update
930              
931             Redraws the Wizard.
932              
933             =cut
934              
935             sub update {
936             my $self = shift;
937             $self->{wizardFrame}->update if $self->{wizardFrame};
938             return 1;
939             }
940              
941             sub _resize_window {
942             my $self = shift;
943             return;
944             if ( Tk::Exists( $self->{wizardFrame} ) ) {
945             if ( $self->{frame_sizes}->[ $self->{_current_page_idx} ] ) {
946             my ( $iW, $iH ) = @{ $self->{frame_sizes}->[ $self->{_current_page_idx} ] };
947             DEBUG "Resize frame: -width => $iW, -height => $iH\n";
948             $self->{wizardFrame}->configure(
949             -width => $iW,
950             -height => $iH,
951             );
952             $self->{wizardFrame}->update;
953             # $self->update;
954             }
955             }
956             }
957              
958             =head2 blank_frame
959              
960             my $frame = wizard>->blank_frame(
961             -title => $sTitle,
962             -subtitle => $sSub,
963             -text => $sStandfirst,
964             -wait => $iMilliseconds
965             );
966              
967             Returns a L object that is a child of the Wizard
968             control, with some Cing parameters applied - for more details,
969             please see C<-style> entry elsewhere in this document.
970              
971             Arguments are name/value pairs:
972              
973             =over 4
974              
975             =item -title =>
976              
977             Printed in a big, bold font at the top of the frame
978              
979             =item -subtitle =>
980              
981             Subtitle/stand-first.
982              
983             =item -text =>
984              
985             Main body text.
986              
987             =item -wait =>
988              
989             Experimental, mainly for test scripts.
990             The amount of time in milliseconds to wait before moving forward
991             regardless of the user. This actually just calls the C method (see
992             L). Use of this feature will enable the back-button even if
993             you have disabled it. What's more, if the page is supposed to wait for user
994             input, this feature will probably not give your users a chance.
995              
996             WARNING: do not set -wait to too small of a number, or you might get
997             callbacks interrupting previous callbacks and the whole wizard will
998             get all out of whack. 100 is probably safe for most modern computers;
999             for slower machines try 300. If you want to see the page as it flips
1000             by, use 1000 or more.
1001              
1002             See also: L.
1003              
1004             =item -width -height
1005              
1006             Size of the CONTENT AREA of the wizard.
1007             Yes, you can set a different size for each page!
1008              
1009             =back
1010              
1011             Also:
1012              
1013             -background
1014              
1015             =cut
1016              
1017             #
1018             # Sub-class me:
1019             # accept the args in the POD and return a Tk::Frame
1020             #
1021             sub blank_frame {
1022             my $self = shift;
1023             my $args = {@_};
1024             TRACE "Enter blank_frame";
1025             DEBUG "self.bg = $self->{background}";
1026              
1027             my $wrap = $args->{-wraplength} || 375;
1028             if (not defined( $args->{-height} ) ) {
1029             $args->{-height} = $self->cget( -height );
1030             }
1031              
1032             if (not defined( $args->{-width} ) ) {
1033             $args->{-width} = $self->cget( -width );
1034             $args->{-width} += $self->{left_object}->width
1035             if !$self->_showing_side_banner;
1036             }
1037              
1038             $self->{frame_sizes}->[ $self->{_current_page_idx} ] = [ $args->{-width}, $args->{-height} ];
1039             $self->{frame_titles}->[ $self->{_current_page_idx} ] = $args->{-title}
1040             || 'no title given';
1041              
1042             DEBUG "blank_frame setting width/height to $args->{-width}/$args->{-height}";
1043              
1044             # This is the main content frame:
1045             my $frame = $self->Frame(
1046             -width => $args->{-width},
1047             -height => $args->{-height},
1048             -background => $self->{background},
1049             );
1050             $frame->configure( -background => 'green' ) if DEBUG_FRAME;
1051              
1052             # Do not let the content (body) frame auto-resize when we pack its
1053             # contents:
1054             $frame->packPropagate(0);
1055             $args->{-title} ||= '';
1056              
1057             # We force the title to be one line (sorry):
1058             $args->{-title} =~ s/[\n\r\f]/ /g;
1059             $args->{-subtitle} ||= '';
1060              
1061             # We don't let the subtitle get pushed down away from the title:
1062             $args->{-subtitle} =~ s/^[\n\r\f]*//;
1063             my ( $lTitle, $lSub, $lText );
1064             if ( !$self->_showing_side_banner ) {
1065              
1066             # For 'top' style pages other than first and last
1067             my $top_frame = $frame->Frame( -background => 'white', )->pack(
1068             -fill => 'x',
1069             -side => 'top',
1070             -anchor => 'e'
1071             );
1072             my $p = $top_frame->Frame( -background => 'white' );
1073             my $photo = $self->cget( -topimagepath );
1074             if ( ref $photo ) {
1075             $p->Photo( "topimage", -data => $$photo );
1076             }
1077             else {
1078             $p->Photo( "topimage", -file => $photo );
1079             }
1080             $p->Label(
1081             -image => "topimage",
1082             -background => 'white',
1083             )->pack(
1084             -side => "right",
1085             -anchor => "e",
1086             -padx => 5,
1087             -pady => 5,
1088             );
1089             $p->pack( -side => 'right', -anchor => 'n' );
1090             my $title_frame = $top_frame->Frame( -background => 'white', )->pack(
1091             -side => 'left',
1092             -anchor => 'w',
1093             -expand => 1,
1094             -fill => 'x',
1095             );
1096             my $f = $title_frame->Frame(qw/-background white -width 10 -height 30/)->pack(qw/-fill x -anchor n -side left/);
1097             $f->configure( -background => 'yellow' ) if DEBUG_FRAME;
1098              
1099             # The title frame content proper:
1100             $lTitle = $title_frame->Label(
1101             -justify => 'left',
1102             -anchor => 'w',
1103             -text => $args->{-title},
1104             -font => 'TITLE_FONT_TOP',
1105             -background => $title_frame->cget("-background"),
1106             )->pack(
1107             -side => 'top',
1108             -expand => 1,
1109             -fill => 'x',
1110             -pady => 5,
1111             -padx => 0,
1112             );
1113             $lSub = $title_frame->Label(
1114             -font => 'SUBTITLE_FONT',
1115             -justify => 'left',
1116             -anchor => 'w',
1117             -text => ' ' . $args->{-subtitle},
1118             -background => $title_frame->cget("-background"),
1119             )->pack(
1120             -side => 'top',
1121             -expand => 0,
1122             -fill => 'x',
1123             -padx => 5,
1124             );
1125              
1126             # This is the line below top:
1127             if ( ( $self->cget( -style ) eq 'top' ) && !$self->_on_first_page ) {
1128             my $f = $frame->Frame(
1129             -relief => 'groove',
1130             -bd => 1,
1131             -height => 2,
1132             )->pack(qw/-side top -fill x/);
1133             $f->configure( -background => 'red' ) if DEBUG_FRAME;
1134             }
1135              
1136             if ( $args->{-text} ) {
1137             $lText = $frame->Label(
1138             -font => $self->{defaultFont},
1139             -justify => 'left',
1140             -anchor => 'w',
1141             -wraplength => $wrap + 100,
1142             -justify => "left",
1143             -text => $args->{-text},
1144             -background => $self->{background},
1145             )->pack(
1146             -side => 'top',
1147              
1148             # -anchor => 'n',
1149             # -expand => 1,
1150             -expand => 0,
1151             -fill => 'x',
1152             -padx => 10,
1153             -pady => 10,
1154             );
1155             }
1156             }
1157              
1158             # if 'top' style, but not first or last page
1159             # Whenever page does NOT have the side banner:
1160             else {
1161             $lTitle = $frame->Label(
1162             -justify => 'left',
1163             -anchor => 'w',
1164             -text => $args->{-title},
1165             -font => 'TITLE_FONT',
1166             -background => $frame->cget("-background"),
1167             )->pack(
1168             -side => 'top',
1169             -anchor => 'n',
1170             -expand => 0, # 1
1171             -fill => 'x',
1172             );
1173             $lSub = $frame->Label(
1174             -font => 'SUBTITLE_FONT',
1175             -justify => 'left',
1176             -anchor => 'w',
1177             -text => ' ' . $args->{-subtitle},
1178             -background => $frame->cget("-background"),
1179             )->pack(
1180             -anchor => 'n',
1181             -side => 'top',
1182             -expand => 0,
1183             -fill => 'x',
1184             );
1185             if ( $args->{-text} ) {
1186             $lText = $frame->Label(
1187             -font => $self->{defaultFont},
1188             -justify => 'left',
1189             -anchor => 'w',
1190             -wraplength => $wrap,
1191             -justify => "left",
1192             -text => $args->{-text},
1193             -background => $frame->cget("-background"),
1194             )->pack(
1195             -side => 'top',
1196             -expand => 0,
1197             -fill => 'x',
1198             -pady => 10,
1199             );
1200             }
1201             else {
1202             $frame->Label();
1203             }
1204             }
1205              
1206             if (DEBUG_FRAME){
1207             $lTitle->configure( -background => 'light blue' );
1208             $lSub->configure( -background => 'light green' );
1209             Tk::Exists($lText) && $lText->configure( -background => 'pink' );
1210             }
1211              
1212             DEBUG "blank_frame(), raw -wait is ".($args->{-wait} || "undef");
1213             $args->{ -wait } ||= 0;
1214             DEBUG "blank_frame(), cooked -wait is now $args->{-wait}";
1215              
1216             if ( $args->{ -wait } > 0 ) {
1217             _fix_wait( \$args->{ -wait } );
1218             DEBUG "In blank_frame(), fixed -wait is $args->{-wait}";
1219             DEBUG "Installing 'after', self is $self";
1220             $self->after(
1221             $args->{ -wait },
1222             sub {
1223             DEBUG "Waiting...";
1224             $self->{nextButton}->configure( -state => 'normal' );
1225             $self->{nextButton}->invoke;
1226             }
1227             );
1228             }
1229              
1230             return $frame->pack(qw/-side top -anchor n -fill both -expand 1/);
1231             }
1232              
1233              
1234             =head2 addPage
1235              
1236             $wizard->addPage ($page_code_ref1 ... $page_code_refN)
1237             $wizard->addPage (@args)
1238             $wizard->addPage ($page_code_ref, -preNextButtonAction => $x, -postNextButtonAction => $y)
1239              
1240             Adds a page to the wizard. The parameters must be references to code that
1241             evaluate to L objects, such as those returned by the methods
1242             C and C.
1243              
1244             Pages are (currently) stored and displayed in the order added.
1245              
1246             Returns the index of the page added, which is useful as a page UID when
1247             performing checks as the I button is pressed (see file F
1248             supplied with the distribution).
1249              
1250             As of version 2.084, you can just supply the args to L.
1251              
1252             As of version 2.076, you may supply arguments: C<-preNextButtonAction>,
1253             C<-postNextButtonAction>, C<-preBackButtonAction>, C<-postBackButtonAction>:
1254             see L for further information. More handlers, and
1255             more documentation, may be added.
1256              
1257             =cut
1258              
1259             sub addPage {
1260             TRACE "Enter addPage";
1261             my ($self, @args) = @_;
1262              
1263             # Bit faster if, as of old, all args are code refs (ie no events):
1264             if ( scalar(grep { ref $_ eq 'CODE' } @args) == scalar(@args)) {
1265             DEBUG "Add args to make ".scalar @{ $self->{_pages} };
1266             push @{ $self->{_pages} }, @args;
1267             }
1268              
1269             # Add pages with arguments:
1270             else {
1271             my ($code, @sub_args, $found);
1272             while (@args){
1273             if (ref $args[0] eq 'CODE'){
1274             $found = 1;
1275             if (defined $code){
1276             DEBUG "Call _addPage_with_args...";
1277             $self->_addPage_with_args($code, @sub_args);
1278             } else {
1279             DEBUG "No code yet...";
1280             }
1281             @sub_args = ();
1282             $code = shift @args;
1283             } else {
1284             DEBUG "Add to sub_args...";
1285             push @sub_args, shift(@args), shift(@args);
1286             }
1287             }
1288              
1289             if (defined $code){
1290             $found = 1;
1291             DEBUG "Call _addPage_with_args (finally)";
1292             $self->_addPage_with_args($code, @sub_args);
1293             }
1294              
1295             if (not $found){
1296             DEBUG "No code ref found: blank frame from args: ", join", ",@sub_args;
1297             push @{ $self->{_pages} }, sub { $self->blank_frame(@sub_args) };
1298             }
1299              
1300             }
1301              
1302             TRACE "Leave addpage";
1303             return scalar @{ $self->{_pages} };
1304             }
1305              
1306              
1307             sub _addPage_with_args {
1308             TRACE "Enter _addPage_with_args";
1309             my ($self, $code) = (shift, shift);
1310             my $args = scalar(@_)? {@_} : {};
1311              
1312             # Add the page
1313             DEBUG "Adding code ".Dumper $code;
1314             push @{ $self->{_pages} }, $code;
1315              
1316             # Add the arguments
1317             DEBUG "ARGS ",Dumper $args;
1318             foreach my $e (@PAGE_EVENT_LIST){
1319             DEBUG "Add $e for $#{$self->{_pages}}" if defined $args->{$e};
1320             $self->{_pages_e}->{$e}->[ $#{$self->{_pages}} ] = $args->{$e} || undef;
1321             }
1322             TRACE "Leave _addPage_with_args";
1323             }
1324              
1325              
1326             =head2 addSplashPage
1327              
1328             Add to the wizard a page containing a chunk of text, specified in
1329             the parameter C<-text>. Suitable for an introductory "splash" page
1330             and for a final "all done" page.
1331              
1332             Accepts exactly the same arguments as C.
1333              
1334             =cut
1335              
1336             sub addSplashPage {
1337             TRACE "Enter addSplashPage";
1338             my ($self, $args) = (shift, {@_});
1339             return $self->addPage( sub { $self->blank_frame(%$args) } );
1340             }
1341              
1342             =head2 addTextFramePage
1343              
1344             Add to the wizard a page containing a scrolling textbox, specified in
1345             the parameter C<-boxedtext>. If this is a reference to a scalar, it is
1346             taken to be plain text; if a plain scalar, it is taken to be the name
1347             of a file to be opened and read.
1348              
1349             Accepts the usual C<-title>, C<-subtitle>, and C<-text> like C.
1350              
1351             =cut
1352              
1353             sub addTextFramePage {
1354             my ($self, $args) = (shift, {@_});
1355             DEBUG "addTextFramePage args are ", Dumper($args);
1356             return $self->addPage( sub { $self->_text_frame($args) } );
1357             }
1358              
1359             sub _text_frame {
1360             my $self = shift;
1361             my $args = shift;
1362              
1363             DEBUG "Enter _text_frame with ", Dumper($args);
1364             my $text;
1365             my $frame = $self->blank_frame(%$args);
1366             if ( $args->{-boxedtext} ) {
1367             if ( ref $args->{-boxedtext} eq 'SCALAR' ) {
1368             $text = $args->{-boxedtext};
1369             }
1370             elsif ( not ref $args->{-boxedtext} ) {
1371             open my $in, $args->{-boxedtext}
1372             or Carp::croak "Could not read file: $args->{-boxedtext}; $!";
1373             read $in, $$text, -s $in;
1374             close $in;
1375             WARN "Boxedtext file $args->{-boxedtext} is empty." if not length $text;
1376             }
1377             }
1378             $$text = "" if not defined $text;
1379             my $t = $frame->Scrolled(
1380             "ROText",
1381             -background => ( $args->{ -background } || 'white' ),
1382             -relief => "sunken",
1383             -borderwidth => "1",
1384             -font => $self->{defaultFont},
1385             -scrollbars => "osoe",
1386             -wrap => "word",
1387             )->pack(qw/-expand 1 -fill both -padx 10 -pady 10/);
1388              
1389             $t->configure( -background => 'green' ) if DEBUG_FRAME;
1390             $t->insert( '0.0', $$text );
1391             $t->configure( -state => "disabled" );
1392              
1393             return $frame;
1394             }
1395              
1396             #
1397             # Function (NOT a method!): _dispatch
1398             # Description: Thin wrapper to dispatch event cycles as needed
1399             # Parameters: The _dispatch function is an internal function used to determine if the dispatch back reference
1400             # is undefined or if it should be dispatched. Undefined methods are used to denote dispatchback
1401             # methods to bypass. This reduces the number of method dispatches made for each handler and also
1402             # increased the usability of the set methods when trying to unregister event handlers.
1403             #
1404             sub _dispatch {
1405             my $handler = shift;
1406             DEBUG "Enter _dispatch with " . ( $handler || "undef" );
1407              
1408             if ( ref($handler) eq 'Tk::Callback' ) {
1409             return !$handler->Call();
1410             }
1411             if ( ref($handler) eq 'CODE' ) {
1412             return !$handler->();
1413             }
1414              
1415             return 1;
1416              
1417             # Below is the original 1.9451 version:
1418             return ( !( $handler->Call() ) )
1419             if defined $handler
1420             and ref $handler
1421             and ref $handler eq 'CODE';
1422              
1423             return 0;
1424             }
1425              
1426             # Returns the number of the last page (zero-based):
1427             sub _last_page {
1428             my $self = shift;
1429             my $i = $#{ $self->{_pages} };
1430             return $i;
1431             }
1432              
1433             # Returns true if the current page is the last page:
1434             sub _on_last_page {
1435             my $self = shift;
1436             DEBUG "_on_last_page(), pagePtr is $self->{_current_page_idx}";
1437             return ( $self->_last_page == $self->{_current_page_idx} );
1438             }
1439              
1440             # Returns true if the current page is the first page:
1441             sub _on_first_page {
1442             my $self = shift;
1443             return ( 0 == $self->{_current_page_idx} );
1444             }
1445              
1446             # Method: _NextButtonEventCycle
1447             # Description: Runs the complete view of the action handler cycle for the "Next>" button on the
1448             # wizard button bar. This includes dispatching the preNextButtonAction and
1449             # postNextButtonAction handler at the appropriate times.
1450             #
1451             # Dictat: Never ever use goto unless you have a very good reason, and please explain that reason
1452             #
1453             sub _NextButtonEventCycle {
1454             my $self = shift;
1455             TRACE "Enter _NextButtonEventCycle";
1456             $self->{_inside_nextButtonEventCycle_}++ unless shift;
1457              
1458             DEBUG "NBEC counter == $self->{_inside_nextButtonEventCycle_}";
1459              
1460             # If there is more than one pending invocation, we will reinvoke
1461             # ourself when we're done:
1462             if ( $self->{_inside_nextButtonEventCycle_} > 1) {
1463             # $self->{_inside_nextButtonEventCycle_}--;
1464             DEBUG "Called recursively, bail out";
1465             return;
1466             }
1467              
1468             # XXX DEBUG "Page $self->{_current_page_idx} -preNextButtonAction";
1469             if ( _dispatch( $self->cget( -preNextButtonAction ) ) ) {
1470             INFO "preNextButtonAction says we should not go ahead";
1471             $self->{_inside_nextButtonEventCycle_}--;
1472             return;
1473             }
1474              
1475             if ( $self->_on_last_page ) {
1476             DEBUG "On the last page";
1477             if ( _dispatch( $self->cget( -preFinishButtonAction ) ) ) {
1478             DEBUG "preFinishButtonAction says we should not go ahead";
1479             $self->{_inside_nextButtonEventCycle_}--;
1480             return;
1481             }
1482             elsif ( _dispatch( $self->cget( -finishButtonAction ) ) ) {
1483             DEBUG "finishButtonAction says we should not go ahead";
1484             $self->{_inside_nextButtonEventCycle_}--;
1485             return;
1486             }
1487             else {
1488             $self->{really_quit}++;
1489             $self->_CloseWindowEventCycle();
1490             }
1491             }
1492              
1493             # Advance the wizard page pointer and then adjust the navigation buttons.
1494             # Redraw the frame when finished to get changes to take effect.
1495             else {
1496             TRACE "OK - advance to next page";
1497             $self->_page_forward;
1498             $self->_render_current_page;
1499             }
1500              
1501             DEBUG "Before _dispatch postNextButtonAction";
1502             if ( _dispatch( $self->cget( -postNextButtonAction ) ) ) {
1503             INFO "postNextButtonAction says we should not go ahead";
1504             $self->{_inside_nextButtonEventCycle_}--;
1505             return;
1506             }
1507              
1508             DEBUG "all done, NBEC counter is now $self->{_inside_nextButtonEventCycle_}";
1509              
1510             $self->{_inside_nextButtonEventCycle_}--;
1511              
1512             $self->_NextButtonEventCycle('no increment') if $self->{_inside_nextButtonEventCycle_};
1513             }
1514              
1515              
1516             # Move the wizard pointer back one position and then adjust the
1517             # navigation buttons to reflect any state changes. Don't fall off
1518             # end of page pointer
1519             sub _BackButtonEventCycle {
1520             my $self = shift;
1521             return if _dispatch( $self->cget( -preBackButtonAction ) );
1522             $self->_page_backward;
1523             $self->_render_current_page;
1524             if ( _dispatch( $self->cget( -postBackButtonAction ) ) ) { return; }
1525             return;
1526             }
1527              
1528             sub _HelpButtonEventCycle {
1529             my $self = shift;
1530             if ( _dispatch( $self->cget( -preHelpButtonAction ) ) ) { return; }
1531             if ( _dispatch( $self->cget( -helpButtonAction ) ) ) { return; }
1532             if ( _dispatch( $self->cget( -postHelpButtonAction ) ) ) { return; }
1533             }
1534              
1535             sub _CancelButtonEventCycle {
1536             my $self = shift;
1537             return
1538             if $self->Callback( -preCancelButtonAction => $self->{-preCancelButtonAction} );
1539             $self->_CloseWindowEventCycle($_);
1540             }
1541              
1542             sub _CloseWindowEventCycle {
1543             my $self = shift;
1544             my $gui = shift;
1545             TRACE "Enter _CloseWindowEventCycle... really=[", ($self->{really_quit} || 'undef'), "]";
1546              
1547             if ( not $self->{really_quit} ) {
1548             DEBUG "Really?";
1549             if ( $self->Callback( -preCloseWindowAction => $self->{-preCloseWindowAction} ) ) {
1550             DEBUG "preCloseWindowAction says we should not go ahead";
1551             return;
1552             }
1553             }
1554             if ( Tk::Exists($gui) ) {
1555             DEBUG "gui=$gui= withdraw";
1556             $gui->withdraw;
1557             }
1558              
1559             if ( $self->{Configure}{-kill_parent_on_destroy} and Tk::Exists( $self->parent ) ) {
1560             DEBUG "Kill parent " . $self->parent . " " . $self->{Configure}{ -parent };
1561             # This should kill us, too:
1562             $self->parent->destroy;
1563             return;
1564             }
1565              
1566             DEBUG "Legacy withdraw";
1567             $self->{_showing} = 0;
1568             if ( $self->{Configure}{-kill_self_after_finish} ) {
1569             $self->destroy;
1570             }
1571             else {
1572             $self->withdraw; # Legacy
1573             }
1574             return undef;
1575             }
1576              
1577              
1578             =head2 Show
1579              
1580             $wizard->Show();
1581              
1582             Draw and display the Wizard on the screen.
1583             Normally you would call C right after this.
1584              
1585             =cut
1586              
1587             sub Show {
1588             TRACE "Enter Show";
1589             my $self = shift;
1590             return if $self->{_showing};
1591              
1592             if ( $self->_last_page < 2 ) {
1593             my $lp = $self->_last_page + 1;
1594             warnings::warnif(
1595             ref($self), "Showing a Wizard with "
1596             . $lp . ' page' . ($lp==1? '' : 's').'!'
1597             )
1598             }
1599              
1600             $self->{_current_page_idx} = 0;
1601             $self->_initial_layout;
1602              
1603             $self->resizable( 0, 0 )
1604             unless $self->{Configure}{-resizable}
1605             and $self->{Configure}{-resizable} =~ /^(1|yes|true)$/i;
1606              
1607             $self->parent->withdraw;
1608             $self->Popup;
1609             $self->transient; # forbid minimize
1610             $self->protocol( WM_DELETE_WINDOW => [ \&_CloseWindowEventCycle, $self, $self ] );
1611              
1612             # $self->packPropagate(0);
1613             $self->configure( -background => $self->cget("-background") );
1614             $self->_render_current_page;
1615             $self->{_showing} = 1;
1616              
1617             TRACE "Leave Show";
1618             return 1;
1619             }
1620              
1621             =head2 forward
1622              
1623             Convenience method to move the Wizard on a page by invoking the
1624             callback for the C.
1625              
1626             You can automatically move forward after C<$x> tenths of a second
1627             by doing something like this:
1628              
1629             $frame->after($x,sub{$wizard->forward});
1630              
1631             =cut
1632              
1633             sub forward {
1634             my $self = shift;
1635             return $self->_NextButtonEventCycle;
1636             }
1637              
1638             =head2 backward
1639              
1640             Convenience method to move the Wizard back a page by invoking the
1641             callback for the C.
1642              
1643             =cut
1644              
1645             sub backward {
1646             my $self = shift;
1647             return $self->{backButton}->invoke;
1648             }
1649              
1650             sub _showing_side_banner {
1651             my $self = shift;
1652             return 1 if ( $self->cget( -style ) eq '95' );
1653             return 1 if $self->_on_first_page;
1654             return 1 if $self->_on_last_page;
1655             return 0;
1656             }
1657              
1658             =head2 currentPage
1659              
1660             my $current_page = $wizard->currentPage()
1661              
1662             This returns the index of the page currently being shown to the user.
1663             Page are indexes start at 1, with the first page that is associated with
1664             the wizard through the C method.
1665             See also the L entry.
1666              
1667             =cut
1668              
1669             sub currentPage {
1670             my $self = shift;
1671             # Throughout this module, the internal _current_page_idx is zero-based. But we
1672             # "publish" it as one-based:
1673             return $self->{_current_page_idx} + 1;
1674             }
1675              
1676             =head2 setPageSkip
1677              
1678             Mark one or more pages to be skipped at runtime.
1679             All integer arguments are taken to be page numbers
1680             (ie the number returned by any of the C methods)
1681              
1682             You should never set the first page to be skipped, and
1683             you can not set the last page to be skipped, though these
1684             rules are not (yet) enforced.
1685              
1686             =cut
1687              
1688             sub setPageSkip {
1689             my $self = shift;
1690             # The user's argument is 1-based, but our internal data structures
1691             # are zero-based, thus subract 1:
1692             foreach my $i (@_) {
1693             $self->{page_skip}{ $i - 1 } = 1;
1694             }
1695             }
1696              
1697             =head2 setPageUnskip
1698              
1699             Mark one or more pages not to be skipped at runtime
1700             (ie reverse the effects of setPageSkip).
1701             All integer arguments are taken to be page numbers
1702             (ie the number returned by any of the addPage methods)
1703              
1704             =cut
1705              
1706             sub setPageUnskip {
1707             my $self = shift;
1708             # The user's argument is 1-based, but our internal data structures
1709             # are zero-based, thus subtract 1:
1710             foreach my $i (@_) {
1711             $self->{page_skip}{ $i - 1 } = 0;
1712             }
1713             }
1714              
1715             =head2 next_page_number
1716              
1717             Returns the number of the page the Wizard will land on if the Next button is clicked
1718             (ie the integer returned by C).
1719              
1720             =cut
1721              
1722             sub next_page_number {
1723             my $self = shift;
1724             return $self->_next_page_number + 1;
1725             }
1726              
1727              
1728             # _next_page_number
1729             # As public, but value is minus one
1730             #
1731             sub _next_page_number {
1732             my $self = shift;
1733             my $i = $self->{_current_page_idx};
1734             DEBUG "_page_forward($i -->";
1735              
1736             do {
1737             $i++;
1738             } until (
1739             not $self->{page_skip}->{$i} or $self->_last_page <= $i
1740             );
1741             $i = $self->_last_page if ( $self->_last_page < $i );
1742              
1743             DEBUG " $i)\n";
1744             return $i;
1745             }
1746              
1747             # Increments the page pointer forward to the next logical page,
1748             # honouring the Skip flags:
1749             sub _page_forward {
1750             my $self = shift;
1751             $self->{_current_page_idx} = $self->_next_page_number;
1752             }
1753              
1754              
1755             =head2 back_page_number
1756              
1757             Returns the number (ie the integer returned by add*Page) of the page
1758             the Wizard will land on if the Back button is clicked.
1759              
1760             =cut
1761              
1762             # sub back_page_number {
1763             # my $self = shift;
1764             # my $iPage = $self->{_current_page_idx};
1765             # do {
1766             # $iPage--;
1767             # } until ( !$self->{page_skip}{$iPage} || ( $iPage <= 0 ) );
1768             # $iPage = 0 if ( $iPage < 0 );
1769             # return $iPage;
1770             # }
1771              
1772             sub back_page_number {
1773             my $self = shift;
1774             return $self->_back_page_number + 1;
1775             }
1776              
1777             sub _back_page_number {
1778             my $self = shift;
1779             my $iPage = $self->{_current_page_idx};
1780             do {
1781             $iPage--;
1782             } until ( !$self->{page_skip}{$iPage} || ( $iPage <= 0 ) );
1783             $iPage = 0 if ( $iPage < 0 );
1784             return $iPage;
1785             }
1786              
1787              
1788             # Decrements the page pointer backward to the previous logical page,
1789             # honouring the Skip flags:
1790             sub _page_backward {
1791             my $self = shift;
1792             $self->{_current_page_idx} = $self->_back_page_number;
1793             }
1794              
1795             =head2 prompt
1796              
1797             Equivalent to the JavaScript method of the same name: pops up
1798             a dialogue box to get a text string, and returns it. Arguments
1799             are:
1800              
1801             =over 4
1802              
1803             =item -title =>
1804              
1805             The title of the dialogue box.
1806              
1807             =item -text =>
1808              
1809             The text to display above the C widget.
1810              
1811             =item -value =>
1812              
1813             The initial value of the C box.
1814              
1815             =item -wraplength =>
1816              
1817             Text C
1818              
1819             =item -width =>
1820              
1821             The C widget's width: defaults to 40.
1822              
1823             =back
1824              
1825             =cut
1826              
1827             sub prompt {
1828             my $self = shift;
1829             my $args = {@_};
1830             my ( $d, $w );
1831             my $input = $self->cget( -value );
1832             $d = $self->DialogBox(
1833             -title => $args->{-title} || "Prompt",
1834             -buttons => [ $LABELS{CANCEL}, $LABELS{OK} ],
1835             -default_button => $LABELS{OK},
1836             );
1837              
1838             if ( $args->{-text} ) {
1839             $w = $d->add(
1840             "Label",
1841             -font => $self->{defaultFont},
1842             -text => $args->{-text},
1843             -width => 40,
1844             -wraplength => $args->{-wraplength} || 275,
1845             -justify => 'left',
1846             -anchor => 'w',
1847             )->pack();
1848             }
1849              
1850             $w = $d->add(
1851             "Entry",
1852             -font => $self->{defaultFont},
1853             -relief => "sunken",
1854             -width => $args->{-width} || 40,
1855             -background => "white",
1856             -justify => 'left',
1857             -textvariable => \$input,
1858             )->pack(qw( -padx 2 -pady 2 -expand 1 ));
1859              
1860             $d->Show;
1861             return $input ? $input : undef;
1862             }
1863              
1864             #
1865             # Using a -wait value for After of less than this seems to cause a weird Tk dump
1866             # so call this whenever using a -wait
1867             #
1868             sub _fix_wait {
1869             my $wait_ref = shift;
1870             $$wait_ref += 200 if $$wait_ref < 250;
1871             }
1872              
1873             =head1 CALLBACKS
1874              
1875             =head2 DIALOGUE_really_quit
1876              
1877             This is the default callback for -preCloseWindowAction.
1878             It gives the user a Yes/No dialog box; if the user clicks "Yes",
1879             this function returns true (otherwise returns a false value).
1880              
1881             =cut
1882              
1883             sub DIALOGUE_really_quit {
1884             my $self = shift;
1885             TRACE "Enter DIALOGUE_really_quit";
1886             return 0 if $self->{nextButton}->cget( -text ) eq $LABELS{FINISH};
1887              
1888             unless ( $self->{really_quit} ) {
1889             DEBUG "# Get really quit info";
1890             my $button = $self->messageBox(
1891             '-icon' => 'question',
1892             -type => 'yesno',
1893             -default => 'no',
1894             -title => 'Quit Wizard?',
1895             -message => "The Wizard has not finished running.\n\n"
1896             . "If you quit now, the job will not be complete.\n\nDo you really wish to quit?"
1897             );
1898             $self->{really_quit} = lc $button eq 'yes' ? 1 : 0;
1899             DEBUG "# ... really=[$self->{really_quit}]";
1900             }
1901             return !$self->{really_quit};
1902             }
1903              
1904              
1905              
1906              
1907             =head1 ACTION EVENT HANDLERS
1908              
1909             A Wizard is a series of pages that gather information and perform
1910             tasks based upon that information. Navigated through the pages is via
1911             I and I buttons, as well as I, I and
1912             I buttons.
1913              
1914             In the C implementation, each button has associated with
1915             it one or more action event handlers, supplied as code-references
1916             executed before, during and/or after the button press.
1917              
1918             The handler code should return a Boolean value, signifying whether the
1919             remainder of the action should continue. If a false value is
1920             returned, execution of the event handler halts.
1921              
1922             =over 4
1923              
1924             =item -preNextButtonAction =>
1925              
1926             This is a reference to a function that will be dispatched before the Next
1927             button is processed.
1928              
1929             =item -postNextButtonAction =>
1930              
1931             This is a reference to a function that will be dispatched after the Next
1932             button is processed. The function is called after the application has logically
1933             advanced to the next page, but before the next page is drawn on screen.
1934              
1935              
1936             =item -preBackButtonAction =>
1937              
1938             This is a reference to a function that will be dispatched before the Previous
1939             button is processed.
1940              
1941             =item -postBackButtonAction =>
1942              
1943             This is a reference to a function that will be dispatched after the Previous
1944             button is processed.
1945              
1946             =item -preHelpButtonAction =>
1947              
1948             This is a reference to a function that will be dispatched before the Help
1949             button is processed.
1950              
1951             =item -helpButtonAction =>
1952              
1953             This is a reference to a function that will be dispatched to handle the Help
1954             button action.
1955             By default there is no Help action; therefore unless you are providing this
1956             function, you should initialize your Wizard with -nohelpbutton => 1.
1957              
1958             =item -postHelpButtonAction =>
1959              
1960             This is a reference to a function that will be dispatched after the Help
1961             button is processed.
1962              
1963             =item -preFinishButtonAction =>
1964              
1965             This is a reference to a function that will be dispatched just before the Finish
1966             button action.
1967              
1968             =item -finishButtonAction =>
1969              
1970             This is a reference to a function that will be dispatched to handle the Finish
1971             button action.
1972              
1973             =item -preCancelButtonAction =>
1974              
1975             This is a reference to a function that will be dispatched before the Cancel
1976             button is processed. Default is to exit on user confirmation - see
1977             L.
1978              
1979             =item -preCloseWindowAction =>
1980              
1981             This is a reference to a function that will be dispatched before the window
1982             is issued a close command.
1983             If this function returns a true value, the Wizard will close.
1984             If this function returns a false value, the Wizard will stay on the current page.
1985             Default is to exit on user confirmation - see L.
1986              
1987             =back
1988              
1989             All active event handlers can be set at construction or using configure --
1990             see L and L.
1991              
1992             =head1 BUTTONS
1993              
1994             backButton nextButton helpButton cancelButton
1995              
1996             If you must, you can access the Wizard's button through the object
1997             fields listed above, each of which represents a
1998             L object. This may not be a good way to do it:
1999             patches always welcome ;)
2000              
2001             This is not advised for anything other than disabling or re-enabling the display
2002             status of the buttons, as the C<-command> switch is used by the Wizard:
2003              
2004             $wizard->{backButton}->configure( -state => "disabled" )
2005              
2006             Note: the I button is simply the C with the label C<$LABEL{FINISH}>.
2007              
2008             See also L.
2009              
2010             =head1 INTERNATIONALISATION
2011              
2012             The labels of the buttons can be changed (perhaps into a language other an English)
2013             by changing the values of the package-global C<%LABELS> hash, where keys are
2014             C, C, C, C, and C.
2015              
2016             The text of the callbacks can also be changed via the
2017             C<%LABELS> hash: see the top of the source code for details.
2018              
2019             =head1 IMPLEMENTATION NOTES
2020              
2021             This widget is implemented using the Tk 'standard' API as far as possible,
2022             given that when I first needed a wizard in Perl/Tk, I had almost three weeks
2023             of exposure to the technology. Please, if you have a suggestion,
2024             or patch, send it to me directly via C, or via CPAN's RT.
2025              
2026             The widget supports both C and not C window.
2027             Originally, only the former was supported - the reasoning was that
2028             Wizards are applications in their own right, and not usually parts of other
2029             applications. However, conventions are not always bad things, hence the update.
2030              
2031             =head1 THE C NAMESPACE
2032              
2033             In discussion on comp.lang.perl.tk, it was suggested by Dominique Dumont
2034             that the following guidelines for the use of the C namespace be followed:
2035              
2036             =over 4
2037              
2038             =item 1
2039              
2040             That the module C act as a base module, providing all the
2041             basic services and components a Wizard might require.
2042              
2043             =item 2
2044              
2045             That modules beneath the base in the hierarchy provide implementations
2046             based on aesthetics and/or architecture.
2047              
2048             =back
2049              
2050             =head1 NOTES ON SUB-CLASSING Tk::Wizard
2051              
2052             If you are planning to sub-class C to create a different display style,
2053             there are three routines you will need to over-ride:
2054              
2055             =over 4
2056              
2057             =item _initial_layout
2058              
2059             =item _render_current_page
2060              
2061             =item blank_frame
2062              
2063             =back
2064              
2065             This may change, please bear with me.
2066              
2067             =head1 CAVEATS
2068              
2069             =over 4
2070              
2071             =item *
2072              
2073             Bit messy when composing frames.
2074              
2075             =item *
2076              
2077             Task Frame LabFrame background colour doesn't set properly under 5.6.1.
2078              
2079             =item *
2080              
2081             20 January 2003: the directory tree part does not create directories
2082             unless the eponymous button is clicked. Is this still an issue?
2083              
2084             =item *
2085              
2086             In Windows, with the system font set to > 96 DPI (via Display Properties / Settings
2087             / Advanced / General / Display / Font Size), the Wizard will not display pro pertly.
2088             This seems to be a Tk feature.
2089              
2090             =item *
2091              
2092             Nothing is currently done to ensure text fits into the window - it is currently up to
2093             the client to make frames C) as required.
2094              
2095             =back
2096              
2097             =head1 BUGS
2098              
2099             Please use RT (https://rt.cpan.org/Ticket/Create.html?Queue=Tk-Wizard)
2100             to submit a bug report.
2101              
2102             =head1 AUTHOR
2103              
2104             Lee Goddard (lgoddard@cpan.org) based on work by Daniel T Hable.
2105              
2106             Thanks to Martin Thurn (mthurn@cpan.org) and Scott R. Keszler for support,
2107             patches, and extensions, whilst I'm elsewhere.
2108              
2109             =head1 KEYWORDS
2110              
2111             Wizard; set-up; setup; installer; uninstaller; install; uninstall; Tk; GUI.
2112              
2113             =head1 COPYRIGHT
2114              
2115             Copyright (C) Lee Goddard, 11/2002 - 02/2010 ff.
2116              
2117             This software is made available under the same terms as Perl itself.
2118              
2119             This software is not endorsed by, or in any way associated with, the Microsoft Corp
2120              
2121             Microsoft is, obvisouly, a registered trademark of Microsoft Corp.
2122              
2123             =cut
2124              
2125             REDEFINES:
2126             {
2127             no warnings 'redefine';
2128             sub Tk::ErrorOFF {
2129             DEBUG "This is Martin's Tk::Error\n";
2130             my ( $oWidget, $sError, @asLocations ) = @_;
2131             local $, = "\n";
2132             print STDERR @asLocations;
2133             }
2134             }
2135              
2136             1;
2137              
2138             __END__