lib/Pod/Perldoc/ToTk.pm

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