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