home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _c21a5b600a45d437006e8a71826584a8 < prev    next >
Encoding:
Text File  |  2004-06-01  |  3.4 KB  |  130 lines
  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.  
  130.