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<[email protected]>, 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 |
|
---|