1#!/usr/bin/perl -w 2 3use strict; 4use vars qw($VERSION $tk_opt $tree $server $portfile $Mblib @I $debug); 5 6$VERSION = '5.10'; 7 8use IO::Socket; 9 10sub INIT { 11 my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}; 12 $portfile = "$home/.tkpodsn"; 13 my $port = $ENV{'TKPODPORT'}; 14 return if $^C; 15 unless (defined $port) { 16 if (open(SN,"$portfile")) { 17 $port = <SN>; 18 close(SN); 19 } 20 } 21 if (defined $port) { 22 my $sock = IO::Socket::INET->new(PeerAddr => 'localhost', 23 PeerPort => $port, Proto => 'tcp'); 24 if ($sock) { 25 binmode($sock); 26 $sock->autoflush; 27 foreach my $file (@ARGV) { 28 unless (print $sock "$file\n") { 29 die "Cannot print $file to socket: $!"; 30 } 31 print "Requested '$file'\n"; 32 } 33 $sock->close || die "Cannot close socket: $!"; 34 exit(0); 35 } else { 36 warn "Cannot connect to server on $port: $!"; 37 } 38 } 39} 40 41use Tk; 42 43# Experimental mousewheel support. This is part of newer Tk versions. 44# XXX <MouseWheel> support for Windows is untested. 45BEGIN { 46 if ($Tk::VERSION < 800.024012) { 47 local $^W = 0; 48 require Tk::Listbox; 49 my $orig_tk_listbox_classinit = \&Tk::Listbox::ClassInit; 50 *Tk::Listbox::ClassInit = sub { 51 my($class,$mw)=@_; 52 $orig_tk_listbox_classinit->(@_); 53 $mw->bind($class, "<4>", ['yview', 'scroll', -5, 'units']); 54 $mw->bind($class, "<5>", ['yview', 'scroll', +5, 'units']); 55 $mw->bind($class, '<MouseWheel>', 56 [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); 57 }; 58 59 require Tk::ROText; 60 my $orig_tk_text_classinit = \&Tk::ROText::ClassInit; 61 *Tk::ROText::ClassInit = sub { 62 my($class,$mw)=@_; 63 $orig_tk_text_classinit->(@_); 64 $mw->bind($class, "<4>", ['yview', 'scroll', -5, 'units']); 65 $mw->bind($class, "<5>", ['yview', 'scroll', +5, 'units']); 66 $mw->bind($class, '<MouseWheel>', 67 [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); 68 }; 69 70 require Tk::HList; 71 my $orig_tk_hlist_classinit = \&Tk::HList::ClassInit; 72 *Tk::HList::ClassInit = sub { 73 my($class,$mw)=@_; 74 $orig_tk_hlist_classinit->(@_); 75 $mw->bind($class, "<4>", ['yview', 'scroll', -5, 'units']); 76 $mw->bind($class, "<5>", ['yview', 'scroll', +5, 'units']); 77 $mw->bind($class, '<MouseWheel>', 78 [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); 79 }; 80 } 81} 82 83### Problems under Windows... do not use it anymore 84#BEGIN { eval { require Tk::FcyEntry; }; }; 85use Tk::Pod 4.18; 86use Tk::Pod::Text; # for findpod 87use Getopt::Long; 88#require Tk::ErrorDialog; 89 90my $geometry; 91# Do a pre-scan of cmdline to see if -geometry is used 92Getopt::Long::Configure('pass_through'); 93GetOptions("geometry=s" => \$geometry); 94Getopt::Long::Configure('nopass_through'); 95 96my $mw = MainWindow->new(); 97my $orig_state = $mw->state; # may be iconic 98$mw->withdraw; 99 100my $function; 101my $question; 102 103my $exit; 104 105$tree = 0; 106#XXX Getopt::Long::Configure ("bundling"); 107if (!GetOptions("tk" => \$tk_opt, 108 "tree" => \$tree, 109 "notree" => sub { $tree = 0 }, 110 "s|server!" => \$server, 111 "Mblib" => \$Mblib, 112 "I=s@" => \@I, 113 "d|debug!" => \$debug, 114 'exit' => \$exit, 115 "f=s" => \$function, 116 "q=s" => \$question, 117 "filedialog=s" => sub { 118 my $mod = $_[1]; 119 eval qq{ use $mod qw(as_default) }; 120 die $@ if $@; 121 }, 122 "version" => sub { 123 print <<EOF; 124tkpod $VERSION 125Tk::Pod $Tk::Pod::VERSION 126part of Tk-Pod-$Tk::Pod::DIST_VERSION 127EOF 128 CORE::exit(0); 129 }, 130 )) { 131 die <<EOT; 132Usage: $0 [-tk] [[-no]tree] [-Mblib] [-I dir] [-s|server] 133 [-filedialog module] 134 [-f function | -q FAQRegex | directory | name [...]] 135 [-d|debug] [-exit] 136 $0 -version 137 138EOT 139} 140 141# Add 'Tk' subdirectories to search path so, e.g., 142# 'Scrolled' will find doc in 'Tk/Scrolled' 143if ($tk_opt) { 144 my $tkdir; 145 foreach (reverse @INC) { 146 $tkdir = "$_/Tk"; 147 unshift @ARGV, $tkdir if -d $tkdir; 148 } 149} 150 151if ($debug) { 152 $ENV{'TKPODDEBUG'} = $debug; 153} 154 155if ($exit) { 156 local $^W = 0; 157 *Tk::Pod::Text::_error_dialog = sub { die @_ }; 158} 159 160my $use_reloader = 0; 161if ($ENV{'TKPODDEBUG'}) { 162 if (eval { require Tk::App::Reloader; 1 }) { 163 warn "Loaded Tk::App::Reloader ...\n"; 164 $Tk::App::Reloader::VERBOSE = $Tk::App::Reloader::VERBOSE = 1; 165 Tk::App::Reloader::shortcut(); 166 $use_reloader = 1; 167 } 168 if (eval { require Tk::App::Debug; 1 }) { 169 warn "Loaded Tk::App::Debug...\n"; 170 } 171} 172 173start_server() if $server; 174 175# CDE use Font Settings if available 176my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width 177my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional 178if (defined($ufont) and defined($sfont)) { 179 foreach ($ufont, $sfont) { s/:$//; }; 180 $mw->optionAdd('*Font', $sfont); 181 $mw->optionAdd('*Entry.Font', $ufont); 182 $mw->optionAdd('*Text.Font', $ufont); 183} 184 185if (1 && $^O ne "MSWin32") { # XXX still decide 186 my $lighter = $mw->Darken(Tk::NORMAL_BG, 110); 187 foreach my $class (qw(Entry BrowseEntry.Entry More*ROText Pod*Tree)) { 188 $mw->optionAdd("*$class*background", $lighter, "userDefault"); 189 } 190 $mw->optionAdd("*Pod*Pod*Frame*More*ROText*background", $lighter, "interactive"); 191} 192 193$mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0); 194 195my @extra_dirs; 196if (defined $Mblib) { 197 # XXX better to use Tk::Pod->Dir? blib/scripts => Tk::Pod->ScriptDir? 198 require blib; 199 blib->import; 200} 201if (@I) { 202 push @extra_dirs, @I; 203} 204Tk::Pod->Dir(@extra_dirs) if @extra_dirs; 205if ($ENV{TKPODDIRS}) { 206 require Config; 207 for my $dir (split $Config::Config{'path_sep'}, $ENV{TKPODDIRS}) { 208 Tk::Pod->Dir($dir); 209 } 210} 211 212my $tl; 213my $file; 214my $opened = 0; 215foreach $file (@ARGV) 216 { 217 if (-d $file && !Tk::Pod::Text->findpod($file, -quiet => 1)) 218 { 219 Tk::Pod->Dir($file); 220 } 221 else 222 { 223 $tl = make_tk_pod_window(); 224 # -file => ... should be called after creating the Pod window, 225 # because -title => ... is set implicitly by Pod's new 226 $tl->configure(-file => $file); 227 $opened++; 228 } 229 } 230 231if (defined $function) 232 { 233 $tl = make_tk_pod_window(); 234 $tl->configure($tl->getpodargs(-f => $function)); 235 $opened++; 236 } 237if (defined $question) 238 { 239 $tl = make_tk_pod_window(); 240 $tl->configure($tl->getpodargs(-q => $question)); 241 $opened++; 242 } 243 244if (!$opened) # This may happen if all arguments are directories 245 { 246 $tl = make_tk_pod_window(); 247 if (!$tree) 248 { 249 $tl->configure(-file => "perl"); 250 } 251 } 252 253if (Tk::Exists($tl) && $orig_state eq 'iconic') { 254 $tl->iconify; 255} 256 257# xxx dirty but it works. A simple $mw->destroy if $mw->children 258# does not work because Tk::ErrorDialogs could be created. 259# (they are withdrawn after Ok instead of destory'ed I guess) 260 261if ($mw->children) { 262 $mw->repeat(1000, sub { 263 if (Tk::Exists($mw)) { 264 # ErrorDialog is withdrawn not deleted :-( 265 foreach ($mw->children) { 266 return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod') 267 } 268 $mw->destroy; 269 } 270 }); 271} else { 272 $mw->destroy; 273} 274Tk::App::Reloader::check_loop() if $use_reloader; 275MainLoop unless $exit; 276unlink($portfile); 277exit(0); 278 279sub make_tk_pod_window { 280 my $tl = $mw->Pod( 281 -exitbutton => 1, 282 ); 283 if ($geometry) { 284 $tl->geometry($geometry); 285 } 286 if ($tree) { 287 $tl->tree($tree); 288 } 289 $tl; 290} 291 292sub start_server { 293 my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp'); 294 die "Cannot open listen socket: $!" unless defined $sock; 295 binmode($sock); 296 297 my $port = $sock->sockport; 298 $ENV{'TKPODPORT'} = $port; 299 open(SN,">$portfile") || die "Cannot open $portfile: $!"; 300 print SN $port; 301 close(SN); 302 print STDERR "Accepting connections on $port\n"; 303 $mw->fileevent($sock,'readable', 304 sub { 305 print STDERR "accepting $sock\n"; 306 my $client = $sock->accept; 307 if (defined $client) { 308 binmode($client); 309 print STDERR "Connection $client\n"; 310 $mw->fileevent($client,'readable',[\&PodRequest,$client]); 311 } 312 }); 313 $SIG{TERM} = \&server_cleanup; 314} 315 316sub server_cleanup { 317 unlink $portfile if -e $portfile; 318} 319 320sub PodRequest { 321 my($client) = @_; 322 local $_; 323 while (<$client>) { 324 chomp($_); 325 print STDERR "'$_'\n"; 326 my $pod = make_tk_pod_window(); 327 $pod->configure(-file => $_); 328 } 329 warn "Odd $!" unless eof($client); 330 $mw->fileevent($client,'readable',''); 331 print STDERR "Close $client\n"; 332 $client->close; 333} 334 335__END__ 336 337=head1 NAME 338 339tkpod - Perl/Tk Pod browser 340 341=head1 SYNOPSIS 342 343 tkpod [-tk] [[-no]tree] [-Mblib] [-I dir] [-d|debug] [-s|server] 344 [-filedialog module] 345 [-f function | -q FAQRegex | directory | name [...]] 346 347 348=head1 DESCRIPTION 349 350B<tkpod> is a simple Pod browser with hypertext capabilities. 351Pod (L<Plain Old Document|perlpod>) is a simple and readable 352markup language that could be mixed with L<perl> code. 353 354Pods are searched by default in C<@INC> and C<$ENV{PATH}>. Directories 355listed on the command line or with the B<-I> option are added to the 356default search path. 357 358For each C<name> listed on the command line B<tkpod> tries 359to find Pod in C<name>, C<name.pod> and C<name.pm> in the search 360path. For each C<name> a new Pod browser window is opened. 361 362If no C<name> is listed, then the main C<perl> pod is opened instead. 363 364=head1 OPTIONS 365 366=over 4 367 368=item B<-tree> 369 370When specified, C<tkpod> will show a tree window with all available 371Pods on the local host. However, this may be slow on startup, 372especially first time because there is no cache yet. You can always 373turn on the tree view with the menu entry 'View' -E<gt> 'Pod Tree'. 374 375=item B<-tk> 376 377Useful for perl/Tk documentation. When specified it adds all 378C<Tk> subdirectories in C<@INC> to the Pod search path. This way 379when C<Scrolled> is selected in the browser the C<Tk/Scrolled> 380documentation is found. 381 382=item B<-s> or B<-server> 383 384Start C<tkpod> in server mode. Subsequent calls to C<tkpod> (without 385the B<-s> option) will cause to load the requested Pods into the 386server program, thus minimizing startup time and memory usage. Note 387that there is no access control, so this might be a security hole! 388 389=item B<-Mblib> 390 391Add the C<blib> directories under the current directory to the Pod 392search path. 393 394=item B<-I> I<dir> 395 396Add another directory to the Pod search path. Note that the space is 397mandatory. 398 399=item B<-f> I<function> 400 401Show documentation for I<function>. 402 403=item B<-q> I<FAQRegex> 404 405Show the FAQ entry matching I<FAQRegex>. 406 407=item B<-filedialog> I<module> 408 409Use an alternative file dialog module, e.g. L<Tk::FileSelect>, 410L<Tk::FBox> or L<Tk::PathEntry::Dialog>. 411 412=item B<-d> or B<-debug> 413 414Turn debugging on. 415 416=item B<-exit> 417 418Only for internal testing: exit before entering C<MainLoop>. 419 420=back 421 422 423=head1 USAGE 424 425How to navigate with the Pod browser is described in L<Tk::Pod_usage>. 426It's also accessible via the menu 'Help' -> 'Usage...'. 427 428=head1 ENVIRONMENT 429 430=over 431 432=item TKPODPORT 433 434Force a port for tkpod's server mode. 435 436=item TKPODDIRS 437 438A list of directories (on Unix usually separated by C<:>, on Windows 439by C<;>) for additional Pod directories. These directories will appear 440in the "local dirs" section of the tree view. 441 442=back 443 444See L<Tk::Pod::Text/Environment> and L<Tk::Pod::FindPods/Environment> 445for more environment variables. 446 447=head1 KNOWN BUGS 448 449see L<Tk::Pod::Text> 450 451=head1 SEE ALSO 452 453L<perlpod|perlpod> 454L<pod2man|pod2man> 455L<pod2text|pod2text> 456L<pod2html|pod2html> 457L<Tk::Pod|Tk::Pod> 458L<Tk::Pod::Text|Tk::Pod::Text> 459L<Tk::Pod::Tree|Tk::Pod::Tree> 460 461=head1 AUTHOR 462 463Nick Ing-Simmons <F<nick@ni-s.u-net.com>> 464 465Former maintainer: Achim Bohnet <F<ach@mpe.mpg.de>>. 466 467Code currently maintained by Slaven Rezic <F<slaven@rezic.de>>. 468 469Copyright (c) 1997-1998 Nick Ing-Simmons. 470Copyright (c) 2015 Slaven Rezic. 471All rights reserved. This program is free software; you can 472redistribute it and/or modify it under the same terms as Perl itself. 473 474=cut 475