1 2require 5; 3package Pod::Perldoc::ToTk; 4use strict; 5use warnings; 6 7use base qw(Pod::Perldoc::BaseTo); 8 9sub is_pageable { 1 } 10sub write_with_binmode { 0 } 11sub output_extension { 'txt' } # doesn't matter 12sub if_zero_length { } # because it will be 0-length! 13sub new { return bless {}, ref($_[0]) || $_[0] } 14 15# TODO: document these and their meanings... 16sub tree { shift->_perldoc_elem('tree' , @_) } 17sub tk_opt { shift->_perldoc_elem('tk_opt' , @_) } 18sub forky { shift->_perldoc_elem('forky' , @_) } 19 20use Pod::Perldoc (); 21use File::Spec::Functions qw(catfile); 22 23use Tk; 24die join '', __PACKAGE__, " doesn't work nice with Tk.pm verison $Tk::VERSION" 25 if $Tk::VERSION eq '800.003'; 26 27BEGIN { eval { require Tk::FcyEntry; }; }; 28use Tk::Pod; 29 30# The following was adapted from "tkpod" in the Tk-Pod dist. 31 32sub 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 1001; 101__END__ 102 103 104=head1 NAME 105 106Pod::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 114This is a "plug-in" class that allows Perldoc to use 115Tk::Pod as a formatter class. 116 117You have to have installed Tk::Pod first, or this class won't load. 118 119=head1 SEE ALSO 120 121L<Tk::Pod>, L<Pod::Perldoc> 122 123=head1 AUTHOR 124 125Sean M. Burke C<sburke@cpan.org>, with significant portions copied from 126F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al. 127 128=cut 129 130