—
—
—
—
—

              
package Tk::AppWindow::Ext::Help;
HideShow 6 lines of Pod
=head1 NAME
Tk::AppWindow::Ext::Help - about box and help facilities
=cut
use strict;
use warnings;
use vars qw($VERSION);
$VERSION="0.17";
use base qw( Tk::AppWindow::BaseClasses::Extension );
use Tk;
use File::Basename;
require Tk::HList;
require Tk::NoteBook;
require Tk::PodViewer::Full;
require Tk::ROText;
require Tk::YADialog;
HideShow 99 lines of Pod
=head1 SYNOPSIS
 my $app = new Tk::AppWindow(@options,
    -extensions => ['Help'],
 );
 $app->MainLoop;
=head1 DESCRIPTION
Adds a help facility and an about box to your application. Initiates
menu entries for them.
=head1 CONFIG VARIABLES
=over 4
=item Switch: B<-aboutinfo>
Specify the link to a hash. Possible keys:
=over 4
=item B<author>
Your name
=item B<components>
Specify a list of modules you want the version numbers displayed.
Opens a new tab.
=item B<email>
Who to contact
=item B<http>
The website that supports this application
=item B<license>
Specify your license. By default it is set to I<Same as Perl>.
Set it to I<undef> if you do not want it to show.
=item B<licensefile>
Specify a plain text file as your license file. It is displayed in a new
tab with a L<Tk::ROText> widget.
=item B<licenselink>
Works only if the I<license> key is defined. Specify the weblink to your license. By default it 
is set to L<https://dev.perl.org/licenses/>.
Set it to I<undef> if you do not want it to show.
=item B<version>
Specify the version of your application. By default it is set to the
version numer of the main window widget. Set it to undef if you do not
want it to show.
=back
=item Switch: B<-helpfile>
Point to your help file. Can be a weblink.
If it is a I<.pod> file it will launch a dialog box with
a I<PodText> widget.
=item Switch: B<-updatesmenuitem>
Default value 0;
If set a menu entrie 'Check for updates' is added to the menu.
=back
=head1 COMMANDS
The following commands are defined.
=over 4
=item B<about>
Pops the about box.
=item B<help>
Loads the helpfile in your system's default application or browser.
=item B<updates>
Pops the updates box and starts checking for updates.
=back
=cut
sub new {
        my $class = shift;
        my $self = $class->SUPER::new(@_);
        $self->{ABOUTDEFAULTS} = {
                version => $self->GetAppWindow->VERSION,
                license => 'Same as Perl',
                licenselink => 'https://dev.perl.org/licenses/',
        };
        $self->addPreConfig(
                -aboutinfo => ['PASSIVE', undef, undef, {    }],
                -helpfile => ['PASSIVE'],
                -reportproblemlink => ['PASSIVE'],
                -updatesmenuitem => ['PASSIVE', undef, undef, 0],
        );
        $self->cmdConfig(
                about => ['CmdAbout', $self],
                updates => ['CmdUpdates', $self],
                report_problem => ['CmdReportProblem', $self],
                help => ['CmdHelp', $self],
        );
        return $self;
}
HideShow 6 lines of Pod
=head1 METHODS
=over 4
=cut
sub CmdAbout {
        my $self = shift;
        my $inf = $self->configGet('-aboutinfo');
        my $defaults = $self->{ABOUTDEFAULTS};
        for (keys %$defaults) {
                $inf->{$_} = $defaults->{$_} unless exists $inf->{$_}
        }
        my $db = $self->YADialog(
                -buttons => ['Close'],
                -defaultbutton => 'Close',
                -title => 'About ' . $self->appName,
        );
        my @padding = (-padx => 2);
        my $nb; #NoteBookWidget;
        my $ap; #About frame widget
        my $addnb = sub {
                unless (defined $nb) {
                        $nb = $db->NoteBook->pack(-expand => 1, -fill => 'both') ;
                        $ap = $nb->add('about', -label =>'About');
                }
        };
        my @col0 = ( -column => 0, -sticky => 'e', @padding);
        my @col1 = ( -column => 1, -sticky => 'w', @padding);
        if (my $file = $inf->{licensefile}) {
                &$addnb;
                my $lp = $nb->add('licence', -label => 'License');
                my $t = $lp->Scrolled('ROText', 
                        -width => 8, 
                        -height => 8, 
                        -scrollbars => 'osoe'
                )->pack(-expand =>1, -fill => 'both', @padding);
                if (open(my $fh, '<', $file)) {
                        while (my $line = <$fh>) {
                                $t->insert('end', $line)
                        }
                        close $fh
                }
        } else {
                $ap = $db->Frame->pack(-expand => 1, -fill => 'both') unless defined $ap;
        }
        if (exists $inf->{components}) {
                &$addnb;
                my $lp = $nb->add('components', -label => 'Components');
                my $cl = $lp->Scrolled('HList',
                        -width => 4,
                        -height => 4,
                        -columns => 2,
                        -header => 1,
                        -scrollbars => 'osoe',
                )->pack(-expand => 1, -fill => 'both', @padding);
                my $count = 0;
                for ('Module', 'Version') {
                        my $header = $cl->Frame;
                        $header->Label(-text => $_)->pack(-side => 'left');
                        $cl->headerCreate($count,
                                -headerbackground => $self->configGet('-background'),
                                -itemtype => 'window', 
                                -widget => $header
                        );
                        $count ++;
                }
                my $components = $inf->{components};
                my $row = 0;
                for (@$components) {
                        my $module = $_;
                        my $version = $self->moduleVersion($module);
                        if (defined $version) {
                                $cl->add($row, -data => "$module: $version\n");
                                $cl->itemCreate($row, 0, -text => $module);
                                $cl->itemCreate($row, 1, -text => $version);
                                $row++
                        }
                }
                $lp->Button(
                        -text => 'Copy',
                        -command => sub {
                                my $text = '';
                                for (0 .. $row - 1) {
                                        $text = $text . $cl->infoData($_);
                                }
                                $self->clipboardClear;
                                $self->clipboardAppend($text);
                        }
                )->pack;
        } else {
                $ap = $db->Frame->pack(-expand => 1, -fill => 'both') unless defined $ap;
        }
        my $lg = $self->configGet('-logo');
        if (defined $lg) {
                $ap->Label(-image => $self->Photo(-file => $lg))->pack;
        }
        my $gf = $ap->Frame->pack(-expand => 1, -fill => 'both');
        my $row = 0;
        my $ver = $inf->{version};
        if (defined $ver) {
                $gf->Label(-text => 'Version:')->grid(-row => $row, @col0);
                my $l = $gf->Label(-text => $ver)->grid(-row => $row, @col1);
                $row ++;
        }
        my $aut = $inf->{author};
        if (defined $aut) {
                $gf->Label(-text => 'Author:')->grid(-row => $row, @col0);
                $gf->Label(-text => $aut)->grid(-row => $row, @col1);
                $row ++;
        }
        my $mail = $inf->{email};
        if (defined $mail) {
                $gf->Label(-text => 'E-mail:')->grid(-row => $row, @col0);
                my $url = $gf->Label(
                        -text => $mail,
                )->grid(-row => $row, @col1);
                $self->ConnectURL($url, "mailto:$mail"); 
                $row ++;
        }
        my $web = $inf->{http};
        if (defined $web) {
                $gf->Label(-text => 'Website:')->grid(-row => $row, @col0);
                my $url = $gf->Label(
                        -text => $web,
                )->grid(-row => $row, @col1);
                $self->ConnectURL($url, $web); 
                $row ++;
        }
        my $lc = $inf->{license}; 
        if (defined $lc) {
                if (defined $lc) {
                        $gf->Label(-text => 'License:')->grid(-row => $row, @col0);
                        my $l = $gf->Label(-text => $lc)->grid(-row => $row, @col1);
                        my $lcu = $inf->{licenselink};
                        if (defined $lcu) {
                                $self->ConnectURL($l, $lcu) if defined $lcu;
                        }
                }
                $row ++;
        }
        $db->Show(-popover => $self->GetAppWindow);
        $db->destroy;
}
sub CmdHelp {
        my $self = shift;
        my $file = $self->configGet('-helpfile');
        if (defined $file) {
                if ($file =~ /\.pod$/) { #is pod
                        my $db = $self->YADialog(
                                -buttons => ['Close'],
                                -title => 'Help',
                        );
                        my @podopt = ();
                        my $art = $self->extGet('Art');
                        @podopt = (
                                -nextimage => $art->createCompound(
                                        -image => $art->getIcon('go-next', 22),
                                        -text => 'Next',
                                ),
                                -previmage => $art->createCompound(
                                        -image => $art->getIcon('go-previous', 22),
                                        -text => 'Previous',
                                ),
                                -zoominimage => $art->createCompound(
                                        -image => $art->getIcon('zoom-in', 22),
                                        -text => 'Zoom in',
                                ),
                                -zoomoutimage => $art->createCompound(
                                        -image => $art->getIcon('zoom-out', 22),
                                        -text => 'Zoom out',
                                ),
                                -zoomresetimage => $art->createCompound(
                                        -image => $art->getIcon('zoom-original', 22),
                                        -text => 'Zoom reset',
                                ),
                        ) if defined $art;
                         
                        my $pod = $db->PodViewerFull(@podopt,
                                -width => 80,
                                -height => 20,
                        )->pack(-expand => 1, -fill => 'both');
                        $self->after(100, sub { $pod->load($file) });
                        $db->Show(-popover => $self->GetAppWindow);
                        $db->destroy;
                } else {
                        $self->openURL($file);
                }
        }
}
sub CmdReportProblem {
        my $self = shift;
        my $url = $self->configGet('-reportproblemlink');
        $self->openURL($url) if defined $url
}
sub CmdUpdates {
        my $self = shift;
        my $db = $self->YADialog(
                -buttons => ['Close'],
                -defaultbutton => 'Close',
                -nowithdraw => 1,
                -title => 'Updates check',
        );
        my $txt = $db->Scrolled('ROText',
                -tabs => '8m',
                -width => 36,
                -wrap => 'none',
                -height => 12,
                -scrollbars => 'osoe',
        )->pack(-padx => 2, -pady => 2, -expand => 1, -fill => 'both');
        my $app = $self->GetAppWindow;
        my @modules = (ref $app);
        my $inf = $self->configGet('-aboutinfo');
        if (exists $inf->{components}) {
                my $c = $inf->{components};
                push @modules, @$c;
        }
        $self->after(200, sub {
                $db->Subwidget('Close')->configure(-state => 'disabled');
                for (@modules) {
                        my $mod = $_;
                        $txt->insert('end', "Please wait ...");
                        $db->update;
                        my $output = "$mod\n";
                        my $string = `cpan -D $mod`;
                        while ($string ne '') {
                                if ($string =~ s/^(\s+Installed:\s+\d.*\n)//) {
                                        $output = $output . $1
                                } elsif ($string =~ s/^(\s+CPAN:\s*\d.*\n)//) {
                                        $output = $output . $1;
                                        last;
                                } else {
                                        $string =~ s/^.*\n|$//
                                }
                        }
                        my $end = $txt->index('end -1c');
                        $txt->delete("$end linestart", $end);
                        $txt->insert('end', $output);
                        $txt->see('end');
                        $db->update;
                }
                $txt->insert('end', "Done checking.\n");
                $txt->see('end');
                $db->Subwidget('Close')->configure(-state => 'normal');
                $db->configure(-nowithdraw => 0);
        });
        $db->show(-popover => $app);
        $db->destroy;
}
sub ConnectURL {
        my ($self, $widget, $url) = @_;
        $widget->configure(-cursor => 'hand2');
        $widget->bind('<Enter>', sub { 
                $widget->configure(-foreground => $self->configGet('-linkcolor'))
        });
        $widget->bind('<Leave>', sub { 
                $widget->configure(-foreground => $self->configGet('-foreground'))
        });
        $widget->bind('<Button-1>', sub { 
                $self->openURL($url) 
        });
}
sub MenuItems {
        my $self = shift;
        my @items = (
#This table is best viewed with tabsize 3.
#                        type                                   menupath                                label                                   cmd                     icon                                    keyb                    config variable
                [       'menu_normal',          'appname::Quit',        "~About",                       'about',                'help-about',           'SHIFT+F1'      ], 
                [       'menu_normal',          'appname::Quit',        "~Help",                        'help',         'help-browser', 'F1',                   ],
        );
         
        push @items,    [       'menu_normal',          'appname::Quit',        "~Check for updates", 'updates' ] 
                if $self->configGet('-updatesmenuitem'); 
        push @items,    [       'menu_normal',          'appname::Quit',        "~Report a problem", 'report_problem'   ] 
                if defined $self->configGet('-reportproblemlink'); 
        push @items, [  'menu_separator',       'appname::Quit',        'h1'];
        return @items
}
HideShow 6 lines of Pod
=item B<moduleVersion>I<($module)>
Returns the version number of I<$module>. Returns undef if the module is not found.
=cut
sub moduleVersion {
        my ($self, $module) = @_;
        my $version;
        my $s = '->VERSION';
        eval "use $module; \$version = $module$s";
        return $version
}
HideShow 22 lines of Pod
=back
=head1 AUTHOR
Hans Jeuken (hanje at cpan dot org)
=head1 BUGS
Unknown. If you find any, please contact the author.
=head1 SEE ALSO
=over 4
=item L<Tk::AppWindow>
=item L<Tk::AppWindow::BaseClasses::Extension>
=back
=cut
1;