cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTk.pm

   1 package Pod::Perldoc::ToTk;
   2 use strict;
   3 use warnings;
   4
   5 use vars qw($VERSION);
   6 $VERSION = '3.28';
   7
   8 use parent qw(Pod::Perldoc::BaseTo);
   9
  10 sub is_pageable        { 1 }
  11 sub write_with_binmode { 0 }
  12 sub output_extension   { 'txt' } # doesn't matter
  13 sub if_zero_length { }  # because it will be 0-length!
  14 sub new { return bless {}, ref($_[0]) || $_[0] }
  15
  16 # TODO: document these and their meanings...
  17 sub tree      { shift->_perldoc_elem('tree'    , @_) }
  18 sub tk_opt    { shift->_perldoc_elem('tk_opt'  , @_) }
  19 sub forky     { shift->_perldoc_elem('forky'   , @_) }
  20
  21 use Pod::Perldoc ();
  22 use File::Spec::Functions qw(catfile);
  23
  24 BEGIN{ # Tk is not core, but this is
  25   eval { require Tk } ||
  26   __PACKAGE__->die( <<"HERE" );
  27 You must have the Tk module to use Pod::Perldoc::ToTk.
  28 If you have it installed, ensure it's in your Perl library
  29 path.
  30 HERE
  31
  32   __PACKAGE__->die(
  33     __PACKAGE__,
  34     " doesn't work nice with Tk.pm version $Tk::VERSION"
  35     ) if $Tk::VERSION eq '800.003';
  36   }
  37
  38
  39 BEGIN { eval { require Tk::FcyEntry; }; };
  40 BEGIN{ # Tk::Pod is not core, but this is
  41   eval { require Tk::Pod } ||
  42   __PACKAGE__->die( <<"HERE" );
  43 You must have the Tk::Pod module to use Pod::Perldoc::ToTk.
  44 If you have it installed, ensure it's in your Perl library
  45 path.
  46 HERE
  47   }
  48
  49 # The following was adapted from "tkpod" in the Tk-Pod dist.
  50
  51 sub parse_from_file {
  52
  53     my($self, $Input_File) = @_;
  54     if($self->{'forky'}) {
  55       return if fork;  # i.e., parent process returns
  56     }
  57
  58     $Input_File =~ s{\\}{/}g
  59      if $self->is_mswin32 or $self->is_dos
  60      # and maybe OS/2
  61     ;
  62
  63     my($tk_opt, $tree);
  64     $tree   = $self->{'tree'  };
  65     $tk_opt = $self->{'tk_opt'};
  66
  67     #require Tk::ErrorDialog;
  68
  69     # Add 'Tk' subdirectories to search path so, e.g.,
  70     # 'Scrolled' will find doc in 'Tk/Scrolled'
  71
  72     if( $tk_opt ) {
  73       push @INC, grep -d $_, map catfile($_,'Tk'), @INC;
  74     }
  75
  76     my $mw = MainWindow->new();
  77     #eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug';
  78     $mw->withdraw;
  79
  80     # CDE use Font Settings if available
  81     my $ufont = $mw->optionGet('userFont','UserFont');     # fixed width
  82     my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional
  83     if (defined($ufont) and defined($sfont)) {
  84         foreach ($ufont, $sfont) { s/:$//; };
  85         $mw->optionAdd('*Font',       $sfont);
  86         $mw->optionAdd('*Entry.Font', $ufont);
  87         $mw->optionAdd('*Text.Font',  $ufont);
  88     }
  89
  90     $mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0);
  91
  92     $mw->Pod(
  93       '-file' => $Input_File,
  94       (($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ())
  95     )->focusNext;
  96
  97     # xxx dirty but it works. A simple $mw->destroy if $mw->children
  98     # does not work because Tk::ErrorDialogs could be created.
  99     # (they are withdrawn after Ok instead of destory'ed I guess)
 100
 101     if ($mw->children) {
 102         $mw->repeat(1000, sub {
 103                     # ErrorDialog is withdrawn not deleted :-(
 104                     foreach ($mw->children) {
 105                             return if "$_" =~ /^Tk::Pod/  # ->isa('Tk::Pod')
 106                     }
 107                     $mw->destroy;
 108                 });
 109     } else {
 110         $mw->destroy;
 111     }
 112     #$mw->WidgetDump;
 113     MainLoop();
 114
 115     exit if $self->{'forky'}; # we were the child!  so exit now!
 116     return;
 117 }
 118
 119 1;
 120 __END__
 121
 122
 123 =head1 NAME
 124
 125 Pod::Perldoc::ToTk - let Perldoc use Tk::Pod to render Pod
 126
 127 =head1 SYNOPSIS
 128
 129   perldoc -o tk Some::Modulename &
 130
 131 =head1 DESCRIPTION
 132
 133 This is a "plug-in" class that allows Perldoc to use
 134 Tk::Pod as a formatter class.
 135
 136 You have to have installed Tk::Pod first, or this class won't load.
 137
 138 =head1 SEE ALSO
 139
 140 L<Tk::Pod>, L<Pod::Perldoc>
 141
 142 =head1 AUTHOR
 143
 144 Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
 145
 146 Past contributions from:
 147 brian d foy C<< <bdfoy@cpan.org> >>
 148 Adriano R. Ferreira C<< <ferreira@cpan.org> >>;
 149 Sean M. Burke C<< <sburke@cpan.org> >>;
 150 significant portions copied from
 151 F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al.
 152
 153 =cut
 154