home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Pod.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-16  |  13.4 KB  |  510 lines
  1. package Tk::Pod;
  2. use strict;
  3. use Tk ();
  4. use Tk::Toplevel;
  5.  
  6. use vars qw($VERSION @ISA);
  7. $VERSION = substr(q$Revision: 1.2 $, 10) + 2 . "";
  8.  
  9. @ISA = qw(Tk::Toplevel);
  10.  
  11. Construct Tk::Widget 'Pod';
  12.  
  13. my $history;
  14.  
  15. sub Populate
  16. {
  17.  my ($w,$args) = @_;
  18.  
  19.  require Tk::Pod::Text;
  20.  require Tk::Pod::Tree;
  21.  
  22.  $w->SUPER::Populate($args);
  23.  
  24.  my $tree = $w->Scrolled('PodTree',
  25.              -scrollbars => 'oso'.($Tk::platform eq 'MSWin32'?'e':'w')
  26.             );
  27.  $w->Advertise('tree' => $tree);
  28.  
  29.  my $searchcase = 0;
  30.  my $p = $w->Component('PodText' => 'pod', -searchcase => $searchcase)->pack(-expand => 1, -fill => 'both');
  31.  
  32.  my $exitbutton = delete $args->{-exitbutton} || 0;
  33.  
  34.  my $menuitems =
  35.  [
  36.  
  37.   [Cascade => '~File', -menuitems =>
  38.    [
  39.     [Button => '~Open File...', '-command' => ['openfile',$w]],
  40.     [Button => '~Set Pod...', '-command' => ['openpod',$w,$p]],
  41.     [Button => '~New Window...', '-command' => ['newwindow',$w,$p]],
  42.     [Button => '~Reload',    '-command' => ['reload',$p]],
  43.     [Button => '~Edit',      '-command' => ['edit',$p]],
  44.     [Button => 'Edit with p~tked', '-command' => ['edit',$p,'ptked']],
  45.     [Button => '~Print...',  '-command' => ['Print',$p]],
  46.     [Separator => ""],
  47.     [Button => '~Close',     '-command' => ['quit',$w]],
  48.     ($exitbutton
  49.      ? [Button => 'E~xit',      '-command' => sub { $p->MainWindow->destroy }]
  50.      : ()
  51.     ),
  52.    ]
  53.   ],
  54.  
  55.   [Cascade => '~View', -menuitems =>
  56.    [
  57.     [Checkbutton => '~Pod Tree', -variable => \$w->{Tree_on},
  58.      '-command' => sub { $w->tree($w->{Tree_on}) }],
  59.     '-',
  60.     [Button => "Zoom ~in",  -command => ['zoom_in', $p]],
  61.     [Button => "~Normal",   -command => ['zoom_normal', $p]],
  62.     [Button => "Zoom ~out", -command => ['zoom_out', $p]],
  63.    ]
  64.   ],
  65.  
  66.   [Cascade => '~Search', -menuitems =>
  67.    [
  68.     [Button => '~Search',           '-accelerator' => '/', '-command' => ['Search', $p, 'Next']],
  69.     [Button => 'Search ~backwards', '-accelerator' => '?', '-command' => ['Search', $p, 'Prev']],
  70.     [Button => '~Repeat search',    '-accelerator' => 'n', '-command' => ['ShowMatch', $p, 'Next']],
  71.     [Button => 'R~epeat backwards', '-accelerator' => 'N', '-command' => ['ShowMatch', $p, 'Prev']],
  72.     [Checkbutton => '~Case sensitive', -variable => \$searchcase, '-command' => sub { $p->configure(-searchcase => $searchcase) }],
  73.     [Separator => ""],
  74.     [Button => 'Search ~full text', '-command' => ['SearchFullText', $p, 'Prev']],
  75.    ]
  76.   ],
  77.  
  78.   [Cascade => 'H~istory', -menuitems =>
  79.    [
  80.     [Button => '~Back',    '-accelerator' => 'Alt-Left',  '-command' => ['history_move', $p, -1]],
  81.     [Button => '~Forward', '-accelerator' => 'Alt-Right', '-command' => ['history_move', $p, +1]],
  82.     [Button => '~View',    '-command' => ['history_view', $p]],
  83.     '-',
  84.     [Button => 'Clear cache', '-command' => ['clear_cache', $p]],
  85.    ]
  86.   ],
  87.  
  88.   [Cascade => '~Help', -menuitems =>
  89.    [
  90.     # XXX restructure to not reference to tkpod
  91.     [Button => '~Usage...',       -command => ['help', $w]],
  92.     [Button => '~Programming...', -command => sub { $w->parent->Pod(-file=>'Tk/Pod.pm', -exitbutton => $w->cget(-exitbutton)) }],
  93.     [Button => '~About...', -command => ['about', $w]],
  94.    ]
  95.   ]
  96.  ];
  97.  
  98.  my $mbar = $w->Menu(-menuitems => $menuitems);
  99.  $w->configure(-menu => $mbar);
  100.  $w->Advertise(menubar => $mbar);
  101.  
  102.  $w->Delegates('Menubar' => $mbar);
  103.  $w->ConfigSpecs(
  104.     -tree => ['METHOD', 'tree', 'Tree', 0],
  105.     -exitbutton => ['PASSIVE', 'exitButton', 'ExitButton', $exitbutton],
  106.     'DEFAULT' => [$p],
  107.  );
  108.  
  109.  foreach my $mod (qw(Alt Meta))
  110.   {
  111.    $w->bind($w->toplevel->PathName, "<$mod-Left>"  => [$p, 'history_move', -1]);
  112.    $w->bind($w->toplevel->PathName, "<$mod-Right>" => [$p, 'history_move', +1]);
  113.   }
  114.  
  115.  $w->protocol('WM_DELETE_WINDOW',['quit',$w]);
  116. }
  117.  
  118. my $fsbox;
  119.  
  120. sub openfile {
  121.     my ($cw,$p) = @_;
  122.     my $file;
  123.     if ($cw->can("getOpenFile")) {
  124.     $file = $cw->getOpenFile
  125.         (-title => "Choose Pod file",
  126.          -defaultextension => 'pod',
  127.          -filetypes => [['Pod containing files', ['*.pod',
  128.                               '*.pl',
  129.                               '*.pm']],
  130.                 ['Pod files', '*.pod'],
  131.                 ['Perl scripts', '*.pl'],
  132.                 ['Perl modules', '*.pm'],
  133.                 ['All files', '*']]);
  134.     } else {
  135.     unless (defined $fsbox && $fsbox->IsWidget) {
  136.         require Tk::FileSelect;
  137.         $fsbox = $cw->FileSelect();
  138.     }
  139.     $file = $fsbox->Show();
  140.     }
  141.     $cw->configure(-file => $file) if defined $file && -r $file;
  142. }
  143.  
  144. sub openpod {
  145.     my($cw,$p) = @_;
  146.     my $t = $cw->Toplevel(-title => "Set Pod");
  147.     $t->transient($cw);
  148.     $t->grab;
  149.     my($pod, $e, $go);
  150.     {
  151.     my $Entry = 'Entry';
  152.     eval {
  153.         require Tk::HistEntry;
  154.         Tk::HistEntry->VERSION(0.40);
  155.         $Entry = "HistEntry";
  156.     };
  157.  
  158.     my $f = $t->Frame->pack(-fill => "x");
  159.     $f->Label(-text => "Pod:")->pack(-side => "left");
  160.     $e = $f->$Entry(-textvariable => \$pod)->pack(-side => "left", -fill => "x", -expand => 1);
  161.     if ($e->can('history') && $history) {
  162.         $e->history($history);
  163.     }
  164.     $e->focus;
  165.     $go = 0;
  166.     $e->bind("<Return>" => sub { $go = 1 });
  167.     $e->bind("<Escape>" => sub { $go = -1 });
  168.     }
  169.  
  170.     {
  171.     my $f = $t->Frame->pack;
  172.     $f->Button(-text => "OK",
  173.            -command => sub { $go = 1 })->pack(-side => "left");
  174.     $f->Button(-text => "New window",
  175.            -command => sub { $go = 2 })->pack(-side => "left");
  176.     $f->Button(-text => "Cancel",
  177.            -command => sub { $go = -1 })->pack(-side => "left");
  178.     }
  179.     $t->Popup(-popover => $cw);
  180.     $t->OnDestroy(sub { $go = -1 unless $go });
  181.     $t->waitVariable(\$go);
  182.     if (Tk::Exists($t)) {
  183.     if ($pod ne "" && $go > 0 && $e->can('historyAdd')) {
  184.         $e->historyAdd($pod);
  185.         $history = [ $e->history ];
  186.     }
  187.     $t->grabRelease;
  188.     $t->destroy;
  189.     }
  190.     if ($pod ne "") {
  191.     if ($go == 1) {
  192.         $cw->configure(-file => $pod);
  193.     } elsif ($go == 2) {
  194.         my $new_cw = $cw->MainWindow->Pod
  195.         ('-tree' => $cw->cget(-tree),
  196.          -exitbutton => $cw->cget(-exitbutton),
  197.         );
  198.         $new_cw->configure('-file' => $pod);
  199.     }
  200.     }
  201. }
  202.  
  203. sub newwindow {
  204.     my($cw) = @_;
  205.     $cw->MainWindow->Pod('-tree' => $cw->cget(-tree),
  206.              -exitbutton => $cw->cget(-exitbutton),
  207.             );
  208. }
  209.  
  210. sub Dir {
  211.     require Tk::Pod::Text;
  212.     require Tk::Pod::Tree;
  213.     Tk::Pod::Text::Dir(@_);
  214.     Tk::Pod::Tree::Dir(@_);
  215. }
  216.  
  217.  
  218. sub quit { shift->destroy }
  219.  
  220. sub help {
  221.     my $w = shift;
  222.     $w->parent->Pod(-file=>'Tk::Pod_usage.pod',
  223.             -exitbutton => $w->cget(-exitbutton),
  224.            );
  225. }
  226.  
  227. sub about {
  228.     shift->messageBox(-title => "About Tk::Pod",
  229.                       -icon => "info",
  230.               -message => join "\n",
  231.                 "Tk::Pod $VERSION",
  232.                 $Pod::Simple::VERSION
  233.                   ? "(Using Pod::Simple $Pod::Simple::VERSION)"
  234.                   : (),
  235.                 'Please contact <slaven@rezic.de>',
  236.                 "in case of problems.",
  237.              );
  238. }
  239.  
  240. sub add_section_menu {
  241.     my($pod) = @_;
  242.  
  243.     my $screenheight = $pod->screenheight;
  244.     my $mbar = $pod->Subwidget('menubar');
  245.     my $sectionmenu = $mbar->Subwidget('sectionmenu');
  246.     if (defined $sectionmenu) {
  247.         $sectionmenu->delete(0, 'end');
  248.     } else {
  249.     $mbar->insert($mbar->index("last"), "cascade",
  250.               '-label' => 'Section', -underline => 1);
  251.     $sectionmenu = $mbar->Menu;
  252.     $mbar->entryconfigure($mbar->index("last")-1, -menu => $sectionmenu);
  253.     $mbar->Advertise(sectionmenu => $sectionmenu);
  254.     }
  255.  
  256.     my $podtext = $pod->Subwidget('pod');
  257.     my $text    = $podtext->Subwidget('more')->Subwidget('text');
  258.  
  259.     $text->tag('configure', '_section_mark',
  260.                -background => 'red',
  261.                -foreground => 'black',
  262.               );
  263.  
  264.     my $sdef;
  265.     foreach $sdef (@{$podtext->{'sections'}}) {
  266.         my($head_level, $subject, $pos) = @$sdef;
  267.  
  268.     my @args;
  269.     if ($sectionmenu &&
  270.         $sectionmenu->yposition("last") > $screenheight-40) {
  271.         push @args, -columnbreak => 1;
  272.     }
  273.  
  274.         $sectionmenu->command
  275.       (-label => ("  " x ($head_level-1)) . $subject,
  276.        -command => sub {
  277.            my($line) = split(/\./, $pos);
  278.            $text->tag('remove', '_section_mark', qw/0.0 end/);
  279.            $text->tag('add', '_section_mark',
  280.               $line-1 . ".0",
  281.               $line-1 . ".0 lineend");
  282.            $text->yview("_section_mark.first");
  283.            $text->after(500, [$text, qw/tag remove _section_mark 0.0 end/]);
  284.        },
  285.        @args,
  286.       );
  287.     }
  288. }
  289.  
  290. sub tree {
  291.     my $w = shift;
  292.     if (@_) {
  293.     my $val = shift;
  294.     $w->{Tree_on} = $val;
  295.     my $tree = $w->Subwidget('tree');
  296.     my $p = $w->Subwidget("pod");
  297.     if ($val) {
  298.         $p->packForget;
  299.         $tree->packAdjust(-side => 'left', -fill => 'y');
  300.         $p->pack(-side => "left", -expand => 1, -fill => 'both');
  301.         if (!$tree->Filled) {
  302.         $w->_configure_tree;
  303.         $w->Busy(-recurse => 1);
  304.         eval {
  305.             $tree->Fill;
  306.         };
  307.         my $err = $@;
  308.         $w->Unbusy;
  309.         if ($err) {
  310.             die $err;
  311.         }
  312.         }
  313.         $tree->SeePath("file:" . $p->cget(-path)) if $p->cget(-path);
  314.     } else {
  315.         if ($tree && $tree->manager) {
  316.         $tree->packForget;
  317.         $p->packForget;
  318.         eval {
  319.             $w->Walk
  320.             (sub {
  321.                  my $w = shift;
  322.                  if ($w->isa('Tk::Adjuster') &&
  323.                  $w->cget(-widget) eq $tree) {
  324.                  $w->destroy;
  325.                  die;
  326.                  }
  327.              });
  328.         };
  329.         $p->pack(-side => "left", -expand => 1, -fill => 'both');
  330.         }
  331.     }
  332.     }
  333.     $w->{Tree_on};
  334. }
  335.  
  336. sub _configure_tree {
  337.     my($w) = @_;
  338.     my $tree = $w->Subwidget("tree");
  339.     my $p    = $w->Subwidget("pod");
  340.     $tree->configure
  341.     (-showcommand  => sub {
  342.          my $e = $_[1];
  343.          my $uri = $e->uri;
  344.          if ($uri =~ /^file:(.*)/) {
  345.          $p->configure(-file => $1);
  346.          } elsif ($uri =~ /^cpan:(.*)/) {
  347.          my $modid = $1;
  348.          # XXX nach ..../CPAN.pm auslagern
  349.  
  350.          my $asked = 0;
  351.          my $ask = sub {
  352.              $asked++;
  353.              $w->messageBox
  354.              (-message => "Look into CPAN module $modid?",
  355.               -title => "Tk::Pod and CPAN $modid",
  356.               -type => 'YesNo',
  357.               -icon => 'question') =~ /yes/i
  358.               };
  359.          if ($w->{CPAN_Asked} || $ask->()) {
  360.              $w->{CPAN_Asked}++;
  361.              require CPAN;
  362.              my(@mods) = CPAN::Shell->expand("Module", $modid);
  363.              if (@mods != 1) {
  364.              die "Found more/less than 1 module for $modid: @mods";
  365.              }
  366.              my $mod = shift @mods;
  367.              my $dist = $CPAN::META->instance('CPAN::Distribution', $mod->cpan_file);
  368.  
  369.              require ExtUtils::MakeMaker;
  370.              my($local_wanted) =
  371.              MM->catfile(
  372.                      $CPAN::Config->{keep_source_where},
  373.                      "authors",
  374.                      "id",
  375.                      split("/",$dist->id)
  376.                     );
  377.              if ($asked || -e $local_wanted || $ask->()) {
  378.              my $dir  = $dist->dir or $dist->get;
  379.              $dir = $dist->dir;
  380.              eval { $mod->make }; # XXX Reihenfolge ist wichtig!!!
  381.              if ($@) { warn $@ }
  382.              (my $modpath = $modid) =~ s|::|/|g;
  383.              my $blib_modpath = "$dir/blib/lib/$modpath";
  384.              if (-r "$blib_modpath.pod") {
  385.                  $modpath = "$blib_modpath.pod";
  386.              } elsif (-r "$blib_modpath.pm") {
  387.                  $modpath = "$blib_modpath.pm";
  388.              } else {
  389.                  # try to find it...
  390.                  require File::Find;
  391.                  require File::Basename;
  392.                  my @hits;
  393.              TRY: {
  394.                  foreach my $path ("$modpath.pod",
  395.                            "$modpath.pm",
  396.                            File::Basename::basename($modpath) . ".pod",
  397.                            File::Basename::basename($modpath) . ".pm") {
  398.                      File::Find::find
  399.                          (sub {
  400.                           rindex($File::Find::name, $path) == length($File::Find::name)-length($path)
  401.                               &&
  402.                               push @hits, $File::Find::name;
  403.                           }, $dir);
  404.                      if (@hits) {
  405.                      warn "More than 1 hit: @hits" if @hits > 1;
  406.                      $modpath = "$hits[0]"; #XXX is it really absolute?
  407.                      last TRY;
  408.                      }
  409.                  }
  410.                  die "Can't find $modpath";
  411.                  }
  412.              }
  413.              $p->configure(-file => $modpath);
  414.              }
  415.          }
  416.          } else {
  417.          die "Unrecognized uri $uri";
  418.          }
  419.      },
  420.      -showcommand2 => sub {#XXX rewrite for CPAN...
  421.          my $e = $_[1];
  422.          my $uri = $e->uri;
  423.          if ($uri =~ /^file:(.*)/) {
  424.          $w->MainWindow->Pod
  425.              ('-file' => $1,
  426.               -exitbutton => $w->cget(-exitbutton),
  427.               '-tree' => !!$tree);
  428.          } else {
  429.          die "NYI";
  430.          }
  431.      },
  432.     );
  433. }
  434.  
  435. 1;
  436.  
  437. __END__
  438.  
  439. =head1 NAME
  440.  
  441. Tk::Pod - Pod browser toplevel widget
  442.  
  443.  
  444. =head1 SYNOPSIS
  445.  
  446.     use Tk::Pod
  447.  
  448.     Tk::Pod->Dir(@dirs)            # add dirs to search path for Pod
  449.  
  450.     $pod = $parent->Pod(
  451.         -file = > $name,    # search and display Pod for name
  452.         -tree = > $bool        # display pod file tree
  453.         );
  454.  
  455.  
  456. =head1 DESCRIPTION
  457.  
  458. Simple Pod browser with hypertext capabilities in a C<Toplevel> widget
  459.  
  460. =head1 OPTIONS
  461.  
  462. =over
  463.  
  464. =item -tree
  465.  
  466. Set tree view by default on or off. Default is false.
  467.  
  468. =item -exitbutton
  469.  
  470. Add to the menu an exit entry. This is only useful for standalone pod
  471. readers. Default is false. This option can only be set on construction
  472. time.
  473.  
  474. =back
  475.  
  476. Other options are propagated to the embedded L<Tk::Pod::Text> widget.
  477.  
  478. =head1 BUGS
  479.  
  480. If you set C<-file> while creating the Pod widget,
  481.  
  482.     $parent->Pod(-tree => 1, -file => $pod);
  483.  
  484. then the title will not be displayed correctly. This is because the
  485. internal setting of C<-title> may override the title setting caused by
  486. C<-file>. So it is better to configure C<-file> separately:
  487.  
  488.     $pod = $parent->Pod(-tree => 1);
  489.     $pod->configure(-file => $pod);
  490.  
  491. =head1 SEE ALSO
  492.  
  493. L<Tk::Pod_usage|Tk::Pod_usage>
  494. L<Tk::Pod::Text|Tk::Pod::Text>
  495. L<tkpod|tkpod>
  496. L<perlpod|perlpod>
  497.  
  498. =head1 AUTHOR
  499.  
  500. Nick Ing-Simmons <F<nick@ni-s.u-net.com>>
  501.  
  502. Current maintainer is Slaven Rezic <F<slaven@rezic.de>>.
  503.  
  504. Copyright (c) 1997-1998 Nick Ing-Simmons.  All rights reserved.  This program
  505. is free software; you can redistribute it and/or modify it under the same
  506. terms as Perl itself.
  507.  
  508. =cut
  509.  
  510.