projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
~ isn't valid in VMS filenames
[p5sagit/p5-mst-13.2.git] / lib / Pod / Html.pm
CommitLineData
54310121 1package Pod::Html;
2
3use Pod::Functions;
4use Getopt::Long; # package for handling command-line parameters
29f227c9 5use File::Spec::Unix;
54310121 6require Exporter;
7b8d334a 7use vars qw($VERSION);
29f227c9 8$VERSION = 1.02;
54310121 9@ISA = Exporter;
10@EXPORT = qw(pod2html htmlify);
11use Cwd;
12
13use Carp;
14
3ec07288 15use locale; # make \w work right in non-ASCII lands
16
54310121 17use strict;
18
7b8d334a 19use Config;
20
54310121 21=head1 NAME
22
7b8d334a 23Pod::Html - module to convert pod files to HTML
54310121 24
25=head1 SYNOPSIS
26
7b8d334a 27 use Pod::Html;
54310121 28 pod2html([options]);
29
30=head1 DESCRIPTION
31
32Converts files from pod format (see L<perlpod>) to HTML format. It
33can automatically generate indexes and cross-references, and it keeps
34a cache of things it knows how to cross-reference.
35
36=head1 ARGUMENTS
37
38Pod::Html takes the following arguments:
39
40=over 4
41
42=item help
43
44 --help
45
46Displays the usage message.
47
5a039dd3 48=item htmldir
49
50 --htmldir=name
51
52Sets the directory in which the resulting HTML file is placed. This
29f227c9 53is used to generate relative links to other files. Not passing this
54causes all links to be absolute, since this is the value that tells
55Pod::Html the root of the documentation tree.
5a039dd3 56
54310121 57=item htmlroot
58
59 --htmlroot=name
60
61Sets the base URL for the HTML files. When cross-references are made,
62the HTML root is prepended to the URL.
63
64=item infile
65
66 --infile=name
67
68Specify the pod file to convert. Input is taken from STDIN if no
69infile is specified.
70
71=item outfile
72
73 --outfile=name
74
75Specify the HTML file to create. Output goes to STDOUT if no outfile
76is specified.
77
78=item podroot
79
80 --podroot=name
81
82Specify the base directory for finding library pods.
83
84=item podpath
85
86 --podpath=name:...:name
87
88Specify which subdirectories of the podroot contain pod files whose
89HTML converted forms can be linked-to in cross-references.
90
91=item libpods
92
93 --libpods=name:...:name
94
95List of page names (eg, "perlfunc") which contain linkable C<=item>s.
96
97=item netscape
98
99 --netscape
100
101Use Netscape HTML directives when applicable.
102
103=item nonetscape
104
105 --nonetscape
106
107Do not use Netscape HTML directives (default).
108
109=item index
110
111 --index
112
113Generate an index at the top of the HTML file (default behaviour).
114
115=item noindex
116
117 --noindex
118
119Do not generate an index at the top of the HTML file.
120
121
122=item recurse
123
124 --recurse
125
126Recurse into subdirectories specified in podpath (default behaviour).
127
128=item norecurse
129
130 --norecurse
131
132Do not recurse into subdirectories specified in podpath.
133
134=item title
135
136 --title=title
137
138Specify the title of the resulting HTML file.
139
34db337b 140=item css
141
142 --css=stylesheet
143
144Specify the URL of a cascading style sheet.
145
54310121 146=item verbose
147
148 --verbose
149
150Display progress messages.
151
34db337b 152=item quiet
153
154 --quiet
155
156Don't display I<mostly harmless> warning messages.
157
54310121 158=back
159
160=head1 EXAMPLE
161
162 pod2html("pod2html",
163 "--podpath=lib:ext:pod:vms",
164 "--podroot=/usr/src/perl",
165 "--htmlroot=/perl/nmanual",
166 "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
167 "--recurse",
168 "--infile=foo.pod",
169 "--outfile=/perl/nmanual/foo.html");
170
34db337b 171=head1 ENVIRONMENT
172
173Uses $Config{pod2html} to setup default options.
174
54310121 175=head1 AUTHOR
176
177Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
178
179=head1 BUGS
180
181Has trouble with C<> etc in = commands.
182
183=head1 SEE ALSO
184
185L<perlpod>
186
187=head1 COPYRIGHT
188
189This program is distributed under the Artistic License.
190
191=cut
192
1f763251 193my $cache_ext = $^O eq 'VMS' ? ".tmp" : ".x~~";
194my $dircache = "pod2htmd$cache_ext";
195my $itemcache = "pod2htmi$cache_ext";
54310121 196
197my @begin_stack = (); # begin/end stack
198
29f227c9 199my @libpods = (); # files to search for links from C<> directives
200my $htmlroot = "/"; # http-server base directory from which all
54310121 201 # relative paths in $podpath stem.
5a039dd3 202my $htmldir = ""; # The directory to which the html pages
203 # will (eventually) be written.
54310121 204my $htmlfile = ""; # write to stdout by default
29f227c9 205my $htmlfileurl = "" ; # The url that other files would use to
5a039dd3 206 # refer to this file. This is only used
207 # to make relative urls that point to
208 # other files.
54310121 209my $podfile = ""; # read from stdin by default
210my @podpath = (); # list of directories containing library pods.
211my $podroot = "."; # filesystem base directory from which all
212 # relative paths in $podpath stem.
34db337b 213my $css = ''; # Cascading style sheet
54310121 214my $recurse = 1; # recurse on subdirectories in $podpath.
34db337b 215my $quiet = 0; # not quiet by default
54310121 216my $verbose = 0; # not verbose by default
217my $doindex = 1; # non-zero if we should generate an index
218my $listlevel = 0; # current list depth
219my @listitem = (); # stack of HTML commands to use when a =item is
220 # encountered. the top of the stack is the
221 # current list.
222my @listdata = (); # similar to @listitem, but for the text after
223 # an =item
224my @listend = (); # similar to @listitem, but the text to use to
225 # end the list.
226my $ignore = 1; # whether or not to format text. we don't
227 # format text until we hit our first pod
228 # directive.
229
230my %items_named = (); # for the multiples of the same item in perlfunc
231my @items_seen = ();
232my $netscape = 0; # whether or not to use netscape directives.
233my $title; # title to give the pod(s)
34db337b 234my $header = 0; # produce block header/footer
54310121 235my $top = 1; # true if we are at the top of the doc. used
236 # to prevent the first <HR> directive.
237my $paragraph; # which paragraph we're processing (used
238 # for error messages)
239my %pages = (); # associative array used to find the location
240 # of pages referenced by L<> links.
241my %sections = (); # sections within this page
242my %items = (); # associative array used to find the location
243 # of =item directives referenced by C<> links
39e571d4 244my $Is83; # is dos with short filenames (8.3)
245
54310121 246sub init_globals {
34db337b 247$dircache = "pod2html.d~~";
248$itemcache = "pod2html.i~~";
54310121 249
250@begin_stack = (); # begin/end stack
251
252@libpods = (); # files to search for links from C<> directives
253$htmlroot = "/"; # http-server base directory from which all
254 # relative paths in $podpath stem.
255$htmlfile = ""; # write to stdout by default
256$podfile = ""; # read from stdin by default
257@podpath = (); # list of directories containing library pods.
258$podroot = "."; # filesystem base directory from which all
259 # relative paths in $podpath stem.
34db337b 260$css = ''; # Cascading style sheet
54310121 261$recurse = 1; # recurse on subdirectories in $podpath.
34db337b 262$quiet = 0; # not quiet by default
54310121 263$verbose = 0; # not verbose by default
264$doindex = 1; # non-zero if we should generate an index
265$listlevel = 0; # current list depth
266@listitem = (); # stack of HTML commands to use when a =item is
267 # encountered. the top of the stack is the
268 # current list.
269@listdata = (); # similar to @listitem, but for the text after
270 # an =item
271@listend = (); # similar to @listitem, but the text to use to
272 # end the list.
273$ignore = 1; # whether or not to format text. we don't
274 # format text until we hit our first pod
275 # directive.
276
277@items_seen = ();
278%items_named = ();
279$netscape = 0; # whether or not to use netscape directives.
34db337b 280$header = 0; # produce block header/footer
54310121 281$title = ''; # title to give the pod(s)
282$top = 1; # true if we are at the top of the doc. used
283 # to prevent the first <HR> directive.
284$paragraph = ''; # which paragraph we're processing (used
285 # for error messages)
54310121 286%sections = (); # sections within this page
3e3baf6d 287
288# These are not reinitialised here but are kept as a cache.
289# See get_cache and related cache management code.
290#%pages = (); # associative array used to find the location
291 # of pages referenced by L<> links.
292#%items = (); # associative array used to find the location
54310121 293 # of =item directives referenced by C<> links
39e571d4 294$Is83=$^O eq 'dos';
54310121 295}
296
297sub pod2html {
298 local(@ARGV) = @_;
299 local($/);
300 local $_;
301
302 init_globals();
303
39e571d4 304 $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
305
54310121 306 # cache of %pages and %items from last time we ran pod2html
54310121 307
308 #undef $opt_help if defined $opt_help;
309
310 # parse the command-line parameters
311 parse_command_line();
312
313 # set some variables to their default values if necessary
314 local *POD;
315 unless (@ARGV && $ARGV[0]) {
316 $podfile = "-" unless $podfile; # stdin
317 open(POD, "<$podfile")
318 || die "$0: cannot open $podfile file for input: $!\n";
319 } else {
320 $podfile = $ARGV[0]; # XXX: might be more filenames
321 *POD = *ARGV;
322 }
323 $htmlfile = "-" unless $htmlfile; # stdout
324 $htmlroot = "" if $htmlroot eq "/"; # so we don't get a //
29f227c9 325 $htmldir =~ s#/$## ; # so we don't get a //
326 if ( $htmlroot eq ''
327 && defined( $htmldir )
328 && $htmldir ne ''
329 && substr( $htmlfile, 0, length( $htmldir ) ) eq $htmldir
330 )
5a039dd3 331 {
29f227c9 332 # Set the 'base' url for this file, so that we can use it
333 # as the location from which to calculate relative links
334 # to other files. If this is '', then absolute links will
335 # be used throughout.
336 $htmlfileurl= "$htmldir/" . substr( $htmlfile, length( $htmldir ) + 1);
5a039dd3 337 }
54310121 338
339 # read the pod a paragraph at a time
340 warn "Scanning for sections in input file(s)\n" if $verbose;
341 $/ = "";
342 my @poddata = <POD>;
343 close(POD);
344
345 # scan the pod for =head[1-6] directives and build an index
346 my $index = scan_headings(\%sections, @poddata);
347
3e3baf6d 348 unless($index) {
349 warn "No pod in $podfile\n" if $verbose;
350 return;
351 }
352
54310121 353 # open the output file
354 open(HTML, ">$htmlfile")
355 || die "$0: cannot open $htmlfile file for output: $!\n";
356
d011ffae 357 # put a title in the HTML file if one wasn't specified
358 if ($title eq '') {
359 TITLE_SEARCH: {
360 for (my $i = 0; $i < @poddata; $i++) {
361 if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
362 for my $para ( @poddata[$i, $i+1] ) {
363 last TITLE_SEARCH
364 if ($title) = $para =~ /(\S+\s+-+.*\S)/s;
365 }
366 }
54310121 367
d011ffae 368 }
369 }
370 }
3e3baf6d 371 if (!$title and $podfile =~ /\.pod$/) {
372 # probably a split pod so take first =head[12] as title
373 for (my $i = 0; $i < @poddata; $i++) {
374 last if ($title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
375 }
376 warn "adopted '$title' as title for $podfile\n"
377 if $verbose and $title;
378 }
7b8d334a 379 if ($title) {
380 $title =~ s/\s*\(.*\)//;
381 } else {
34db337b 382 warn "$0: no title for $podfile" unless $quiet;
54310121 383 $podfile =~ /^(.*)(\.[^.\/]+)?$/;
384 $title = ($podfile eq "-" ? 'No Title' : $1);
3e3baf6d 385 warn "using $title" if $verbose;
54310121 386 }
34db337b 387 my $csslink = $css ? qq(\n<LINK REL="stylesheet" HREF="$css" TYPE="text/css">) : '';
388 $csslink =~ s,\\,/,g;
389 $csslink =~ s,(/.):,$1|,;
390
391 my $block = $header ? <<END_OF_BLOCK : '';
392<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0 WIDTH=100%>
393<TR><TD CLASS=block VALIGN=MIDDLE WIDTH=100% BGCOLOR="#cccccc">
394<FONT SIZE=+1><STRONG><P CLASS=block>&nbsp;$title</P></STRONG></FONT>
395</TD></TR>
396</TABLE>
397END_OF_BLOCK
398
54310121 399 print HTML <<END_OF_HEAD;
7b8d334a 400<HTML>
401<HEAD>
34db337b 402<TITLE>$title</TITLE>$csslink
7b8d334a 403<LINK REV="made" HREF="mailto:$Config{perladmin}">
404</HEAD>
54310121 405
7b8d334a 406<BODY>
34db337b 407$block
54310121 408END_OF_HEAD
409
3e3baf6d 410 # load/reload/validate/cache %pages and %items
411 get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse);
54310121 412
413 # scan the pod for =item directives
414 scan_items("", \%items, @poddata);
415
416 # put an index at the top of the file. note, if $doindex is 0 we
417 # still generate an index, but surround it with an html comment.
418 # that way some other program can extract it if desired.
419 $index =~ s/--+/-/g;
420 print HTML "<!-- INDEX BEGIN -->\n";
421 print HTML "<!--\n" unless $doindex;
422 print HTML $index;
423 print HTML "-->\n" unless $doindex;
424 print HTML "<!-- INDEX END -->\n\n";
425 print HTML "<HR>\n" if $doindex;
426
427 # now convert this file
428 warn "Converting input file\n" if $verbose;
429 foreach my $i (0..$#poddata) {
430 $_ = $poddata[$i];
431 $paragraph = $i+1;
432 if (/^(=.*)/s) { # is it a pod directive?
433 $ignore = 0;
434 $_ = $1;
435 if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
436 process_begin($1, $2);
437 } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
438 process_end($1, $2);
439 } elsif (/^=cut/) { # =cut
440 process_cut();
441 } elsif (/^=pod/) { # =pod
442 process_pod();
443 } else {
444 next if @begin_stack && $begin_stack[-1] ne 'html';
445
7b8d334a 446 if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
54310121 447 process_head($1, $2);
7b8d334a 448 } elsif (/^=item\s*(.*\S)/sm) { # =item text
54310121 449 process_item($1);
450 } elsif (/^=over\s*(.*)/) { # =over N
451 process_over();
452 } elsif (/^=back/) { # =back
453 process_back();
454 } elsif (/^=for\s+(\S+)\s+(.*)/si) {# =for
455 process_for($1,$2);
456 } else {
457 /^=(\S*)\s*/;
458 warn "$0: $podfile: unknown pod directive '$1' in "
459 . "paragraph $paragraph. ignoring.\n";
460 }
461 }
462 $top = 0;
463 }
464 else {
465 next if $ignore;
466 next if @begin_stack && $begin_stack[-1] ne 'html';
467 my $text = $_;
468 process_text(\$text, 1);
34db337b 469 print HTML "<P>\n$text</P>\n";
54310121 470 }
471 }
472
473 # finish off any pending directives
474 finish_list();
475 print HTML <<END_OF_TAIL;
34db337b 476$block
7b8d334a 477</BODY>
54310121 478
7b8d334a 479</HTML>
54310121 480END_OF_TAIL
481
482 # close the html file
483 close(HTML);
484
485 warn "Finished\n" if $verbose;
486}
487
488##############################################################################
489
490my $usage; # see below
491sub usage {
492 my $podfile = shift;
493 warn "$0: $podfile: @_\n" if @_;
494 die $usage;
495}
496
497$usage =<<END_OF_USAGE;
498Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
499 --podpath=<name>:...:<name> --podroot=<name>
500 --libpods=<name>:...:<name> --recurse --verbose --index
501 --netscape --norecurse --noindex
502
503 --flush - flushes the item and directory caches.
504 --help - prints this message.
505 --htmlroot - http-server base directory from which all relative paths
506 in podpath stem (default is /).
507 --index - generate an index at the top of the resulting html
508 (default).
509 --infile - filename for the pod to convert (input taken from stdin
510 by default).
511 --libpods - colon-separated list of pages to search for =item pod
512 directives in as targets of C<> and implicit links (empty
513 by default). note, these are not filenames, but rather
514 page names like those that appear in L<> links.
515 --netscape - will use netscape html directives when applicable.
516 --nonetscape - will not use netscape directives (default).
517 --outfile - filename for the resulting html file (output sent to
518 stdout by default).
519 --podpath - colon-separated list of directories containing library
520 pods. empty by default.
521 --podroot - filesystem base directory from which all relative paths
522 in podpath stem (default is .).
523 --noindex - don't generate an index at the top of the resulting html.
524 --norecurse - don't recurse on those subdirectories listed in podpath.
525 --recurse - recurse on those subdirectories listed in podpath
526 (default behavior).
527 --title - title that will appear in resulting html file.
34db337b 528 --header - produce block header/footer
529 --css - stylesheet URL
54310121 530 --verbose - self-explanatory
34db337b 531 --quiet - supress some benign warning messages
54310121 532
533END_OF_USAGE
534
535sub parse_command_line {
34db337b 536 my ($opt_flush,$opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose,$opt_css,$opt_header,$opt_quiet);
537 unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
54310121 538 my $result = GetOptions(
29f227c9 539 'flush' => \$opt_flush,
540 'help' => \$opt_help,
541 'htmldir=s' => \$opt_htmldir,
54310121 542 'htmlroot=s' => \$opt_htmlroot,
29f227c9 543 'index!' => \$opt_index,
54310121 544 'infile=s' => \$opt_infile,
545 'libpods=s' => \$opt_libpods,
546 'netscape!' => \$opt_netscape,
547 'outfile=s' => \$opt_outfile,
548 'podpath=s' => \$opt_podpath,
549 'podroot=s' => \$opt_podroot,
550 'norecurse' => \$opt_norecurse,
551 'recurse!' => \$opt_recurse,
552 'title=s' => \$opt_title,
34db337b 553 'header' => \$opt_header,
554 'css=s' => \$opt_css,
54310121 555 'verbose' => \$opt_verbose,
34db337b 556 'quiet' => \$opt_quiet,
54310121 557 );
558 usage("-", "invalid parameters") if not $result;
559
560 usage("-") if defined $opt_help; # see if the user asked for help
561 $opt_help = ""; # just to make -w shut-up.
562
563 $podfile = $opt_infile if defined $opt_infile;
564 $htmlfile = $opt_outfile if defined $opt_outfile;
5a039dd3 565 $htmldir = $opt_htmldir if defined $opt_outfile;
54310121 566
567 @podpath = split(":", $opt_podpath) if defined $opt_podpath;
568 @libpods = split(":", $opt_libpods) if defined $opt_libpods;
569
570 warn "Flushing item and directory caches\n"
571 if $opt_verbose && defined $opt_flush;
572 unlink($dircache, $itemcache) if defined $opt_flush;
573
574 $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
575 $podroot = $opt_podroot if defined $opt_podroot;
576
577 $doindex = $opt_index if defined $opt_index;
578 $recurse = $opt_recurse if defined $opt_recurse;
579 $title = $opt_title if defined $opt_title;
34db337b 580 $header = defined $opt_header ? 1 : 0;
581 $css = $opt_css if defined $opt_css;
54310121 582 $verbose = defined $opt_verbose ? 1 : 0;
34db337b 583 $quiet = defined $opt_quiet ? 1 : 0;
54310121 584 $netscape = $opt_netscape if defined $opt_netscape;
585}
586
3e3baf6d 587
588my $saved_cache_key;
589
590sub get_cache {
591 my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
592 my @cache_key_args = @_;
593
594 # A first-level cache:
595 # Don't bother reading the cache files if they still apply
596 # and haven't changed since we last read them.
597
598 my $this_cache_key = cache_key(@cache_key_args);
599
600 return if $saved_cache_key and $this_cache_key eq $saved_cache_key;
601
602 # load the cache of %pages and %items if possible. $tests will be
603 # non-zero if successful.
604 my $tests = 0;
605 if (-f $dircache && -f $itemcache) {
606 warn "scanning for item cache\n" if $verbose;
607 $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
608 }
609
610 # if we didn't succeed in loading the cache then we must (re)build
611 # %pages and %items.
612 if (!$tests) {
613 warn "scanning directories in pod-path\n" if $verbose;
614 scan_podpath($podroot, $recurse, 0);
615 }
616 $saved_cache_key = cache_key(@cache_key_args);
617}
618
619sub cache_key {
620 my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
621 return join('!', $dircache, $itemcache, $recurse,
29f227c9 622 @$podpath, $podroot, stat($dircache), stat($itemcache));
3e3baf6d 623}
624
54310121 625#
3e3baf6d 626# load_cache - tries to find if the caches stored in $dircache and $itemcache
54310121 627# are valid caches of %pages and %items. if they are valid then it loads
628# them and returns a non-zero value.
629#
3e3baf6d 630
631sub load_cache {
54310121 632 my($dircache, $itemcache, $podpath, $podroot) = @_;
633 my($tests);
634 local $_;
635
636 $tests = 0;
637
638 open(CACHE, "<$itemcache") ||
639 die "$0: error opening $itemcache for reading: $!\n";
640 $/ = "\n";
641
642 # is it the same podpath?
643 $_ = <CACHE>;
644 chomp($_);
3e3baf6d 645 $tests++ if (join(":", @$podpath) eq $_);
54310121 646
647 # is it the same podroot?
648 $_ = <CACHE>;
649 chomp($_);
650 $tests++ if ($podroot eq $_);
651
652 # load the cache if its good
653 if ($tests != 2) {
654 close(CACHE);
54310121 655 return 0;
656 }
657
658 warn "loading item cache\n" if $verbose;
659 while (<CACHE>) {
660 /(.*?) (.*)$/;
661 $items{$1} = $2;
662 }
663 close(CACHE);
664
665 warn "scanning for directory cache\n" if $verbose;
666 open(CACHE, "<$dircache") ||
667 die "$0: error opening $dircache for reading: $!\n";
668 $/ = "\n";
669 $tests = 0;
670
671 # is it the same podpath?
672 $_ = <CACHE>;
673 chomp($_);
3e3baf6d 674 $tests++ if (join(":", @$podpath) eq $_);
54310121 675
676 # is it the same podroot?
677 $_ = <CACHE>;
678 chomp($_);
679 $tests++ if ($podroot eq $_);
680
681 # load the cache if its good
682 if ($tests != 2) {
683 close(CACHE);
54310121 684 return 0;
685 }
686
687 warn "loading directory cache\n" if $verbose;
688 while (<CACHE>) {
689 /(.*?) (.*)$/;
690 $pages{$1} = $2;
691 }
692
693 close(CACHE);
694
695 return 1;
696}
697
698#
699# scan_podpath - scans the directories specified in @podpath for directories,
700# .pod files, and .pm files. it also scans the pod files specified in
701# @libpods for =item directives.
702#
703sub scan_podpath {
3e3baf6d 704 my($podroot, $recurse, $append) = @_;
54310121 705 my($pwd, $dir);
706 my($libpod, $dirname, $pod, @files, @poddata);
707
3e3baf6d 708 unless($append) {
709 %items = ();
710 %pages = ();
711 }
712
54310121 713 # scan each directory listed in @podpath
714 $pwd = getcwd();
715 chdir($podroot)
716 || die "$0: error changing to directory $podroot: $!\n";
717 foreach $dir (@podpath) {
718 scan_dir($dir, $recurse);
719 }
720
721 # scan the pods listed in @libpods for =item directives
722 foreach $libpod (@libpods) {
723 # if the page isn't defined then we won't know where to find it
724 # on the system.
725 next unless defined $pages{$libpod} && $pages{$libpod};
726
727 # if there is a directory then use the .pod and .pm files within it.
29f227c9 728 # NOTE: Only finds the first so-named directory in the tree.
729# if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
730 if ($pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
54310121 731 # find all the .pod and .pm files within the directory
732 $dirname = $1;
733 opendir(DIR, $dirname) ||
734 die "$0: error opening directory $dirname: $!\n";
735 @files = grep(/(\.pod|\.pm)$/ && ! -d $_, readdir(DIR));
736 closedir(DIR);
737
738 # scan each .pod and .pm file for =item directives
739 foreach $pod (@files) {
740 open(POD, "<$dirname/$pod") ||
741 die "$0: error opening $dirname/$pod for input: $!\n";
742 @poddata = <POD>;
743 close(POD);
744
745 scan_items("$dirname/$pod", @poddata);
746 }
747
748 # use the names of files as =item directives too.
749 foreach $pod (@files) {
750 $pod =~ /^(.*)(\.pod|\.pm)$/;
751 $items{$1} = "$dirname/$1.html" if $1;
752 }
753 } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ ||
754 $pages{$libpod} =~ /([^:]*\.pm):/) {
755 # scan the .pod or .pm file for =item directives
756 $pod = $1;
757 open(POD, "<$pod") ||
758 die "$0: error opening $pod for input: $!\n";
759 @poddata = <POD>;
760 close(POD);
761
762 scan_items("$pod", @poddata);
763 } else {
764 warn "$0: shouldn't be here (line ".__LINE__."\n";
765 }
766 }
767 @poddata = (); # clean-up a bit
768
769 chdir($pwd)
770 || die "$0: error changing to directory $pwd: $!\n";
771
772 # cache the item list for later use
773 warn "caching items for later use\n" if $verbose;
774 open(CACHE, ">$itemcache") ||
775 die "$0: error open $itemcache for writing: $!\n";
776
777 print CACHE join(":", @podpath) . "\n$podroot\n";
778 foreach my $key (keys %items) {
779 print CACHE "$key $items{$key}\n";
780 }
781
782 close(CACHE);
783
784 # cache the directory list for later use
785 warn "caching directories for later use\n" if $verbose;
786 open(CACHE, ">$dircache") ||
787 die "$0: error open $dircache for writing: $!\n";
788
789 print CACHE join(":", @podpath) . "\n$podroot\n";
790 foreach my $key (keys %pages) {
791 print CACHE "$key $pages{$key}\n";
792 }
793
794 close(CACHE);
795}
796
797#
798# scan_dir - scans the directory specified in $dir for subdirectories, .pod
799# files, and .pm files. notes those that it finds. this information will
800# be used later in order to figure out where the pages specified in L<>
801# links are on the filesystem.
802#
803sub scan_dir {
804 my($dir, $recurse) = @_;
805 my($t, @subdirs, @pods, $pod, $dirname, @dirs);
806 local $_;
807
808 @subdirs = ();
809 @pods = ();
810
811 opendir(DIR, $dir) ||
812 die "$0: error opening directory $dir: $!\n";
813 while (defined($_ = readdir(DIR))) {
814 if (-d "$dir/$_" && $_ ne "." && $_ ne "..") { # directory
815 $pages{$_} = "" unless defined $pages{$_};
816 $pages{$_} .= "$dir/$_:";
817 push(@subdirs, $_);
818 } elsif (/\.pod$/) { # .pod
819 s/\.pod$//;
820 $pages{$_} = "" unless defined $pages{$_};
821 $pages{$_} .= "$dir/$_.pod:";
822 push(@pods, "$dir/$_.pod");
823 } elsif (/\.pm$/) { # .pm
824 s/\.pm$//;
825 $pages{$_} = "" unless defined $pages{$_};
826 $pages{$_} .= "$dir/$_.pm:";
827 push(@pods, "$dir/$_.pm");
828 }
829 }
830 closedir(DIR);
831
832 # recurse on the subdirectories if necessary
833 if ($recurse) {
834 foreach my $subdir (@subdirs) {
835 scan_dir("$dir/$subdir", $recurse);
836 }
837 }
838}
839
840#
841# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
842# build an index.
843#
844sub scan_headings {
845 my($sections, @data) = @_;
846 my($tag, $which_head, $title, $listdepth, $index);
847
be173d55 848 # here we need local $ignore = 0;
849 # unfortunately, we can't have it, because $ignore is lexical
850 $ignore = 0;
851
54310121 852 $listdepth = 0;
853 $index = "";
854
855 # scan for =head directives, note their name, and build an index
856 # pointing to each of them.
857 foreach my $line (@data) {
bb9460ed 858 if ($line =~ /^=(head)([1-6])\s+(.*)/) {
54310121 859 ($tag,$which_head, $title) = ($1,$2,$3);
860 chomp($title);
861 $$sections{htmlify(0,$title)} = 1;
862
102c538a 863 while ($which_head != $listdepth) {
864 if ($which_head > $listdepth) {
865 $index .= "\n" . ("\t" x $listdepth) . "<UL>\n";
866 $listdepth++;
867 } elsif ($which_head < $listdepth) {
868 $listdepth--;
869 $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
870 }
54310121 871 }
54310121 872
873 $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
be173d55 874 "<A HREF=\"#" . htmlify(0,$title) . "\">" .
34db337b 875 html_escape(process_text(\$title, 0)) . "</A></LI>";
54310121 876 }
877 }
878
879 # finish off the lists
880 while ($listdepth--) {
881 $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
882 }
883
884 # get rid of bogus lists
885 $index =~ s,\t*<UL>\s*</UL>\n,,g;
886
bb9460ed 887 $ignore = 1; # restore old value;
be173d55 888
54310121 889 return $index;
890}
891
892#
893# scan_items - scans the pod specified by $pod for =item directives. we
894# will use this information later on in resolving C<> links.
895#
896sub scan_items {
897 my($pod, @poddata) = @_;
898 my($i, $item);
899 local $_;
900
901 $pod =~ s/\.pod$//;
902 $pod .= ".html" if $pod;
903
904 foreach $i (0..$#poddata) {
905 $_ = $poddata[$i];
906
907 # remove any formatting instructions
908 s,[A-Z]<([^<>]*)>,$1,g;
909
910 # figure out what kind of item it is and get the first word of
911 # it's name.
912 if (/^=item\s+(\w*)\s*.*$/s) {
913 if ($1 eq "*") { # bullet list
914 /\A=item\s+\*\s*(.*?)\s*\Z/s;
915 $item = $1;
7b8d334a 916 } elsif ($1 =~ /^\d+/) { # numbered list
917 /\A=item\s+\d+\.?(.*?)\s*\Z/s;
54310121 918 $item = $1;
919 } else {
920# /\A=item\s+(.*?)\s*\Z/s;
921 /\A=item\s+(\w*)/s;
922 $item = $1;
923 }
924
925 $items{$item} = "$pod" if $item;
926 }
927 }
928}
929
930#
931# process_head - convert a pod head[1-6] tag and convert it to HTML format.
932#
933sub process_head {
934 my($tag, $heading) = @_;
935 my $firstword;
936
937 # figure out the level of the =head
938 $tag =~ /head([1-6])/;
939 my $level = $1;
940
941 # can't have a heading full of spaces and speechmarks and so on
942 $firstword = $heading; $firstword =~ s/\s*(\w+)\s.*/$1/;
943
944 print HTML "<P>\n" unless $listlevel;
945 print HTML "<HR>\n" unless $listlevel || $top;
946 print HTML "<H$level>"; # unless $listlevel;
947 #print HTML "<H$level>" unless $listlevel;
be173d55 948 my $convert = $heading; process_text(\$convert, 0);
7b8d334a 949 $convert = html_escape($convert);
54310121 950 print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>";
951 print HTML "</H$level>"; # unless $listlevel;
952 print HTML "\n";
953}
954
955#
956# process_item - convert a pod item tag and convert it to HTML format.
957#
958sub process_item {
959 my $text = $_[0];
960 my($i, $quote, $name);
961
962 my $need_preamble = 0;
963 my $this_entry;
964
965
966 # lots of documents start a list without doing an =over. this is
967 # bad! but, the proper thing to do seems to be to just assume
968 # they did do an =over. so warn them once and then continue.
969 warn "$0: $podfile: unexpected =item directive in paragraph $paragraph. ignoring.\n"
970 unless $listlevel;
971 process_over() unless $listlevel;
972
973 return unless $listlevel;
974
975 # remove formatting instructions from the text
976 1 while $text =~ s/[A-Z]<([^<>]*)>/$1/g;
977 pre_escape(\$text);
978
979 $need_preamble = $items_seen[$listlevel]++ == 0;
980
981 # check if this is the first =item after an =over
982 $i = $listlevel - 1;
983 my $need_new = $listlevel >= @listitem;
984
985 if ($text =~ /\A\*/) { # bullet
986
987 if ($need_preamble) {
988 push(@listend, "</UL>");
989 print HTML "<UL>\n";
990 }
991
7b8d334a 992 print HTML '<LI>';
993 if ($text =~ /\A\*\s*(.+)\Z/s) {
994 print HTML '<STRONG>';
995 if ($items_named{$1}++) {
996 print HTML html_escape($1);
997 } else {
998 my $name = 'item_' . htmlify(1,$1);
999 print HTML qq(<A NAME="$name">), html_escape($1), '</A>';
1000 }
1001 print HTML '</STRONG>';
1002 }
54310121 1003
7b8d334a 1004 } elsif ($text =~ /\A[\d#]+/) { # numbered list
54310121 1005
1006 if ($need_preamble) {
1007 push(@listend, "</OL>");
1008 print HTML "<OL>\n";
1009 }
1010
7b8d334a 1011 print HTML '<LI>';
1012 if ($text =~ /\A\d+\.?\s*(.+)\Z/s) {
1013 print HTML '<STRONG>';
1014 if ($items_named{$1}++) {
1015 print HTML html_escape($1);
1016 } else {
1017 my $name = 'item_' . htmlify(0,$1);
1018 print HTML qq(<A NAME="$name">), html_escape($1), '</A>';
1019 }
1020 print HTML '</STRONG>';
1021 }
54310121 1022
1023 } else { # all others
1024
1025 if ($need_preamble) {
1026 push(@listend, '</DL>');
1027 print HTML "<DL>\n";
1028 }
1029
7b8d334a 1030 print HTML '<DT>';
1031 if ($text =~ /(\S+)/) {
1032 print HTML '<STRONG>';
1033 if ($items_named{$1}++) {
1034 print HTML html_escape($text);
1035 } else {
1036 my $name = 'item_' . htmlify(1,$text);
1037 print HTML qq(<A NAME="$name">), html_escape($text), '</A>';
1038 }
1039 print HTML '</STRONG>';
1040 }
54310121 1041 print HTML '<DD>';
1042 }
1043
1044 print HTML "\n";
1045}
1046
1047#
1048# process_over - process a pod over tag and start a corresponding HTML
1049# list.
1050#
1051sub process_over {
1052 # start a new list
1053 $listlevel++;
1054}
1055
1056#
1057# process_back - process a pod back tag and convert it to HTML format.
1058#
1059sub process_back {
2ceaccd7 1060 warn "$0: $podfile: unexpected =back directive in paragraph $paragraph. ignoring.\n"
54310121 1061 unless $listlevel;
1062 return unless $listlevel;
1063
1064 # close off the list. note, I check to see if $listend[$listlevel] is
1065 # defined because an =item directive may have never appeared and thus
1066 # $listend[$listlevel] may have never been initialized.
1067 $listlevel--;
1068 print HTML $listend[$listlevel] if defined $listend[$listlevel];
1069 print HTML "\n";
1070
1071 # don't need the corresponding perl code anymore
1072 pop(@listitem);
1073 pop(@listdata);
1074 pop(@listend);
1075
1076 pop(@items_seen);
1077}
1078
1079#
1080# process_cut - process a pod cut tag, thus stop ignoring pod directives.
1081#
1082sub process_cut {
1083 $ignore = 1;
1084}
1085
1086#
1087# process_pod - process a pod pod tag, thus ignore pod directives until we see a
1088# corresponding cut.
1089#
1090sub process_pod {
1091 # no need to set $ignore to 0 cause the main loop did it
1092}
1093
1094#
1095# process_for - process a =for pod tag. if it's for html, split
c4d9b39d 1096# it out verbatim, if illustration, center it, otherwise ignore it.
54310121 1097#
1098sub process_for {
1099 my($whom, $text) = @_;
1100 if ( $whom =~ /^(pod2)?html$/i) {
1101 print HTML $text;
c4d9b39d 1102 } elsif ($whom =~ /^illustration$/i) {
1103 1 while chomp $text;
1104 for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
1105 $text .= $ext, last if -r "$text$ext";
1106 }
1107 print HTML qq{<p align = "center"><img src = "$text" alt = "$text illustration"></p>};
1108 }
54310121 1109}
1110
1111#
1112# process_begin - process a =begin pod tag. this pushes
1113# whom we're beginning on the begin stack. if there's a
1114# begin stack, we only print if it us.
1115#
1116sub process_begin {
1117 my($whom, $text) = @_;
1118 $whom = lc($whom);
1119 push (@begin_stack, $whom);
1120 if ( $whom =~ /^(pod2)?html$/) {
1121 print HTML $text if $text;
1122 }
1123}
1124
1125#
1126# process_end - process a =end pod tag. pop the
1127# begin stack. die if we're mismatched.
1128#
1129sub process_end {
1130 my($whom, $text) = @_;
1131 $whom = lc($whom);
1132 if ($begin_stack[-1] ne $whom ) {
1133 die "Unmatched begin/end at chunk $paragraph\n"
1134 }
1135 pop @begin_stack;
1136}
1137
1138#
1139# process_text - handles plaintext that appears in the input pod file.
1140# there may be pod commands embedded within the text so those must be
1141# converted to html commands.
1142#
1143sub process_text {
1144 my($text, $escapeQuotes) = @_;
1145 my($result, $rest, $s1, $s2, $s3, $s4, $match, $bf);
1146 my($podcommand, $params, $tag, $quote);
1147
1148 return if $ignore;
1149
1150 $quote = 0; # status of double-quote conversion
1151 $result = "";
1152 $rest = $$text;
1153
1154 if ($rest =~ /^\s+/) { # preformatted text, no pod directives
be173d55 1155 $rest =~ s/\n+\Z//;
1156 $rest =~ s#.*#
1157 my $line = $&;
1158 1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
1159 $line;
1160 #eg;
54310121 1161
1162 $rest =~ s/&/&amp;/g;
1163 $rest =~ s/</&lt;/g;
1164 $rest =~ s/>/&gt;/g;
1165 $rest =~ s/"/&quot;/g;
1166
1167 # try and create links for all occurrences of perl.* within
1168 # the preformatted text.
1169 $rest =~ s{
1170 (\s*)(perl\w+)
1171 }{
1172 if (defined $pages{$2}) { # is a link
1173 qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>);
39e571d4 1174 } elsif (defined $pages{dosify($2)}) { # is a link
1175 qq($1<A HREF="$htmlroot/$pages{dosify($2)}">$2</A>);
54310121 1176 } else {
1177 "$1$2";
1178 }
1179 }xeg;
5a039dd3 1180# $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g;
1181 $rest =~ s{
29f227c9 1182 (<A\ HREF="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
1183 }{
1184 my $url ;
1185 if ( $htmlfileurl ne '' ) {
1186 # Here, we take advantage of the knowledge
1187 # that $htmlfileurl ne '' implies $htmlroot eq ''.
1188 # Since $htmlroot eq '', we need to prepend $htmldir
1189 # on the fron of the link to get the absolute path
1190 # of the link's target. We check for a leading '/'
1191 # to avoid corrupting links that are #, file:, etc.
1192 my $old_url = $3 ;
1193 $old_url = "$htmldir$old_url"
1194 if ( $old_url =~ m{^\/} ) ;
1195 $url = relativize_url( "$old_url.html", $htmlfileurl );
1196# print( " a: [$old_url.html,$htmlfileurl,$url]\n" ) ;
1197 }
1198 else {
1199 $url = "$3.html" ;
1200 }
5a039dd3 1201 "$1$url" ;
1202 }xeg;
54310121 1203
5a039dd3 1204 # Look for embedded URLs and make them in to links. We don't
1205 # relativize them since they are best left as the author intended.
54310121 1206 my $urls = '(' . join ('|', qw{
1207 http
1208 telnet
1209 mailto
1210 news
1211 gopher
1212 file
1213 wais
1214 ftp
1215 } )
1216 . ')';
1217
1218 my $ltrs = '\w';
1219 my $gunk = '/#~:.?+=&%@!\-';
1220 my $punc = '.:?\-';
1221 my $any = "${ltrs}${gunk}${punc}";
1222
1223 $rest =~ s{
1224 \b # start at word boundary
1225 ( # begin $1 {
29f227c9 1226 $urls : # need resource and a colon
1227 (?!:) # Ignore File::, among others.
54310121 1228 [$any] +? # followed by on or more
1229 # of any valid character, but
1230 # be conservative and take only
1231 # what you need to....
1232 ) # end $1 }
1233 (?= # look-ahead non-consumptive assertion
1234 [$punc]* # either 0 or more puntuation
1235 [^$any] # followed by a non-url char
1236 | # or else
1237 $ # then end of the string
1238 )
1239 }{<A HREF="$1">$1</A>}igox;
1240
1241 $result = "<PRE>" # text should be as it is (verbatim)
1242 . "$rest\n"
1243 . "</PRE>\n";
1244 } else { # formatted text
1245 # parse through the string, stopping each time we find a
1246 # pod-escape. once the string has been throughly processed
1247 # we can output it.
ec978fad 1248 while (length $rest) {
54310121 1249 # check to see if there are any possible pod directives in
1250 # the remaining part of the text.
1251 if ($rest =~ m/[BCEIFLSZ]</) {
1252 warn "\$rest\t= $rest\n" unless
1253 $rest =~ /\A
1254 ([^<]*?)
1255 ([BCEIFLSZ]?)
1256 <
1257 (.*)\Z/xs;
1258
1259 $s1 = $1; # pure text
1260 $s2 = $2; # the type of pod-escape that follows
1261 $s3 = '<'; # '<'
1262 $s4 = $3; # the rest of the string
1263 } else {
1264 $s1 = $rest;
1265 $s2 = "";
1266 $s3 = "";
1267 $s4 = "";
1268 }
1269
1270 if ($s3 eq '<' && $s2) { # a pod-escape
1271 $result .= ($escapeQuotes ? process_puretext($s1, \$quote) : $s1);
1272 $podcommand = "$s2<";
1273 $rest = $s4;
1274
1275 # find the matching '>'
1276 $match = 1;
1277 $bf = 0;
1278 while ($match && !$bf) {
1279 $bf = 1;
1280 if ($rest =~ /\A([^<>]*[BCEIFLSZ]<)(.*)\Z/s) {
1281 $bf = 0;
1282 $match++;
1283 $podcommand .= $1;
1284 $rest = $2;
1285 } elsif ($rest =~ /\A([^>]*>)(.*)\Z/s) {
1286 $bf = 0;
1287 $match--;
1288 $podcommand .= $1;
1289 $rest = $2;
1290 }
1291 }
1292
1293 if ($match != 0) {
1294 warn <<WARN;
1295$0: $podfile: cannot find matching > for $s2 in paragraph $paragraph.
1296WARN
1297 $result .= substr $podcommand, 0, 2;
1298 $rest = substr($podcommand, 2) . $rest;
1299 next;
1300 }
1301
1302 # pull out the parameters to the pod-escape
1303 $podcommand =~ /^([BCFEILSZ]?)<(.*)>$/s;
1304 $tag = $1;
1305 $params = $2;
1306
1307 # process the text within the pod-escape so that any escapes
1308 # which must occur do.
1309 process_text(\$params, 0) unless $tag eq 'L';
1310
1311 $s1 = $params;
1312 if (!$tag || $tag eq " ") { # <> : no tag
1313 $s1 = "&lt;$params&gt;";
1314 } elsif ($tag eq "L") { # L<> : link
1315 $s1 = process_L($params);
1316 } elsif ($tag eq "I" || # I<> : italicize text
1317 $tag eq "B" || # B<> : bold text
1318 $tag eq "F") { # F<> : file specification
1319 $s1 = process_BFI($tag, $params);
1320 } elsif ($tag eq "C") { # C<> : literal code
1321 $s1 = process_C($params, 1);
1322 } elsif ($tag eq "E") { # E<> : escape
1323 $s1 = process_E($params);
1324 } elsif ($tag eq "Z") { # Z<> : zero-width character
1325 $s1 = process_Z($params);
1326 } elsif ($tag eq "S") { # S<> : non-breaking space
1327 $s1 = process_S($params);
1328 } elsif ($tag eq "X") { # S<> : non-breaking space
1329 $s1 = process_X($params);
1330 } else {
1331 warn "$0: $podfile: unhandled tag '$tag' in paragraph $paragraph\n";
1332 }
1333
1334 $result .= "$s1";
1335 } else {
1336 # for pure text we must deal with implicit links and
1337 # double-quotes among other things.
1338 $result .= ($escapeQuotes ? process_puretext("$s1$s2$s3", \$quote) : "$s1$s2$s3");
1339 $rest = $s4;
1340 }
1341 }
1342 }
1343 $$text = $result;
1344}
1345
1346sub html_escape {
1347 my $rest = $_[0];
a3c03ba2 1348 $rest =~ s/&(?!\w+;|#)/&amp;/g; # XXX not bulletproof
54310121 1349 $rest =~ s/</&lt;/g;
1350 $rest =~ s/>/&gt;/g;
1351 $rest =~ s/"/&quot;/g;
1352 return $rest;
1353}
1354
1355#
1356# process_puretext - process pure text (without pod-escapes) converting
1357# double-quotes and handling implicit C<> links.
1358#
1359sub process_puretext {
1360 my($text, $quote) = @_;
1361 my(@words, $result, $rest, $lead, $trail);
1362
1363 # convert double-quotes to single-quotes
1364 $text =~ s/\A([^"]*)"/$1''/s if $$quote;
1365 while ($text =~ s/\A([^"]*)["]([^"]*)["]/$1``$2''/sg) {}
1366
1367 $$quote = ($text =~ m/"/ ? 1 : 0);
1368 $text =~ s/\A([^"]*)"/$1``/s if $$quote;
1369
1370 # keep track of leading and trailing white-space
1371 $lead = ($text =~ /\A(\s*)/s ? $1 : "");
1372 $trail = ($text =~ /(\s*)\Z/s ? $1 : "");
1373
1374 # collapse all white space into a single space
1375 $text =~ s/\s+/ /g;
1376 @words = split(" ", $text);
1377
1378 # process each word individually
1379 foreach my $word (@words) {
1380 # see if we can infer a link
1381 if ($word =~ /^\w+\(/) {
1382 # has parenthesis so should have been a C<> ref
1383 $word = process_C($word);
1384# $word =~ /^[^()]*]\(/;
1385# if (defined $items{$1} && $items{$1}) {
1386# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$1}#item_"
1387# . htmlify(0,$word)
1388# . "\">$word</A></CODE>";
1389# } elsif (defined $items{$word} && $items{$word}) {
1390# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$word}#item_"
1391# . htmlify(0,$word)
1392# . "\">$word</A></CODE>";
1393# } else {
1394# $word = "\n<CODE><A HREF=\"#item_"
1395# . htmlify(0,$word)
1396# . "\">$word</A></CODE>";
1397# }
1398 } elsif ($word =~ /^[\$\@%&*]+\w+$/) {
1399 # perl variables, should be a C<> ref
1400 $word = process_C($word, 1);
1401 } elsif ($word =~ m,^\w+://\w,) {
1402 # looks like a URL
5a039dd3 1403 # Don't relativize it: leave it as the author intended
54310121 1404 $word = qq(<A HREF="$word">$word</A>);
af47ee55 1405 } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
54310121 1406 # looks like an e-mail address
7b8d334a 1407 my ($w1, $w2, $w3) = ("", $word, "");
1408 ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
1409 ($w1, $w2, $w3) = ("&lt;", $1, "&gt;$2") if $word =~ /^<(.*?)>(,?)/;
1410 $word = qq($w1<A HREF="mailto:$w2">$w2</A>$w3);
54310121 1411 } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase?
7b8d334a 1412 $word = html_escape($word) if $word =~ /["&<>]/;
54310121 1413 $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape;
1414 } else {
7b8d334a 1415 $word = html_escape($word) if $word =~ /["&<>]/;
54310121 1416 }
1417 }
1418
1419 # build a new string based upon our conversion
1420 $result = "";
1421 $rest = join(" ", @words);
1422 while (length($rest) > 75) {
1423 if ( $rest =~ m/^(.{0,75})\s(.*?)$/o ||
1424 $rest =~ m/^(\S*)\s(.*?)$/o) {
1425
1426 $result .= "$1\n";
1427 $rest = $2;
1428 } else {
1429 $result .= "$rest\n";
1430 $rest = "";
1431 }
1432 }
1433 $result .= $rest if $rest;
1434
1435 # restore the leading and trailing white-space
1436 $result = "$lead$result$trail";
1437
1438 return $result;
1439}
1440
1441#
1442# pre_escape - convert & in text to $amp;
1443#
1444sub pre_escape {
1445 my($str) = @_;
db085819 1446 $$str =~ s/&(?!\w+;|#)/&amp;/g; # XXX not bulletproof
54310121 1447}
1448
1449#
39e571d4 1450# dosify - convert filenames to 8.3
1451#
1452sub dosify {
1453 my($str) = @_;
fe4c6be1 1454 return lc($str) if $^O eq 'VMS'; # VMS just needs casing
39e571d4 1455 if ($Is83) {
1456 $str = lc $str;
1457 $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
1458 $str =~ s/(\w+)/substr ($1,0,8)/ge;
1459 }
1460 return $str;
1461}
1462
1463#
54310121 1464# process_L - convert a pod L<> directive to a corresponding HTML link.
1465# most of the links made are inferred rather than known about directly
1466# (i.e it's not known whether the =head\d section exists in the target file,
1467# or whether a .pod file exists in the case of split files). however, the
1468# guessing usually works.
1469#
1470# Unlike the other directives, this should be called with an unprocessed
1471# string, else tags in the link won't be matched.
1472#
1473sub process_L {
1474 my($str) = @_;
39e571d4 1475 my($s1, $s2, $linktext, $page, $page83, $section, $link); # work strings
54310121 1476
1477 $str =~ s/\n/ /g; # undo word-wrapped tags
1478 $s1 = $str;
1479 for ($s1) {
b74bceb9 1480 # LREF: a la HREF L<show this text|man/section>
1481 $linktext = $1 if s:^([^|]+)\|::;
1482
54310121 1483 # make sure sections start with a /
1484 s,^",/",g;
1485 s,^,/,g if (!m,/, && / /);
1486
1487 # check if there's a section specified
1488 if (m,^(.*?)/"?(.*?)"?$,) { # yes
1489 ($page, $section) = ($1, $2);
1490 } else { # no
1491 ($page, $section) = ($str, "");
1492 }
1493
1494 # check if we know that this is a section in this page
1495 if (!defined $pages{$page} && defined $sections{$page}) {
1496 $section = $page;
1497 $page = "";
1498 }
29f227c9 1499
1500 # remove trailing punctuation, like ()
1501 $section =~ s/\W*$// ;
54310121 1502 }
1503
39e571d4 1504 $page83=dosify($page);
1505 $page=$page83 if (defined $pages{$page83});
54310121 1506 if ($page eq "") {
1507 $link = "#" . htmlify(0,$section);
b74bceb9 1508 $linktext = $section unless defined($linktext);
350ccacd 1509 } elsif ( $page =~ /::/ ) {
1510 $linktext = ($section ? "$section" : "$page");
1511 $page =~ s,::,/,g;
29f227c9 1512 # Search page cache for an entry keyed under the html page name,
1513 # then look to see what directory that page might be in. NOTE:
1514 # this will only find one page. A better solution might be to produce
1515 # an intermediate page that is an index to all such pages.
1516 my $page_name = $page ;
1517 $page_name =~ s,^.*/,, ;
1518 if ( defined( $pages{ $page_name } ) &&
1519 $pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
1520 ) {
1521 $page = $1 ;
1522 }
1523 else {
1524 # NOTE: This branch assumes that all A::B pages are located in
1525 # $htmlroot/A/B.html . This is often incorrect, since they are
1526 # often in $htmlroot/lib/A/B.html or such like. Perhaps we could
1527 # analyze the contents of %pages and figure out where any
1528 # cousins of A::B are, then assume that. So, if A::B isn't found,
1529 # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
1530 # lib/A/B.pm. This is also limited, but it's an improvement.
1531 # Maybe a hints file so that the links point to the correct places
1532 # non-theless?
1533 # Also, maybe put a warn "$0: cannot resolve..." here.
1534 }
350ccacd 1535 $link = "$htmlroot/$page.html";
1536 $link .= "#" . htmlify(0,$section) if ($section);
54310121 1537 } elsif (!defined $pages{$page}) {
34db337b 1538 warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n" unless $quiet;
54310121 1539 $link = "";
b74bceb9 1540 $linktext = $page unless defined($linktext);
54310121 1541 } else {
b74bceb9 1542 $linktext = ($section ? "$section" : "the $page manpage") unless defined($linktext);
54310121 1543 $section = htmlify(0,$section) if $section ne "";
1544
1545 # if there is a directory by the name of the page, then assume that an
1546 # appropriate section will exist in the subdirectory
29f227c9 1547# if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
1548 if ($section ne "" && $pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
54310121 1549 $link = "$htmlroot/$1/$section.html";
1550
1551 # since there is no directory by the name of the page, the section will
1552 # have to exist within a .html of the same name. thus, make sure there
1553 # is a .pod or .pm that might become that .html
1554 } else {
1555 $section = "#$section";
1556 # check if there is a .pod with the page name
1557 if ($pages{$page} =~ /([^:]*)\.pod:/) {
1558 $link = "$htmlroot/$1.html$section";
1559 } elsif ($pages{$page} =~ /([^:]*)\.pm:/) {
1560 $link = "$htmlroot/$1.html$section";
1561 } else {
1562 warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ".
1563 "no .pod or .pm found\n";
1564 $link = "";
b74bceb9 1565 $linktext = $section unless defined($linktext);
54310121 1566 }
1567 }
1568 }
1569
1570 process_text(\$linktext, 0);
1571 if ($link) {
29f227c9 1572 # Here, we take advantage of the knowledge that $htmlfileurl ne ''
1573 # implies $htmlroot eq ''. This means that the link in question
1574 # needs a prefix of $htmldir if it begins with '/'. The test for
1575 # the initial '/' is done to avoid '#'-only links, and to allow
1576 # for other kinds of links, like file:, ftp:, etc.
1577 my $url ;
1578 if ( $htmlfileurl ne '' ) {
1579 $link = "$htmldir$link"
1580 if ( $link =~ m{^/} ) ;
1581
1582 $url = relativize_url( $link, $htmlfileurl ) ;
1583# print( " b: [$link,$htmlfileurl,$url]\n" ) ;
1584 }
1585 else {
1586 $url = $link ;
1587 }
1588
5a039dd3 1589 $s1 = "<A HREF=\"$url\">$linktext</A>";
54310121 1590 } else {
1591 $s1 = "<EM>$linktext</EM>";
1592 }
1593 return $s1;
1594}
1595
1596#
29f227c9 1597# relativize_url - convert an absolute URL to one relative to a base URL.
1598# Assumes both end in a filename.
1599#
1600sub relativize_url {
1601 my ($dest,$source) = @_ ;
1602
1603 my ($dest_volume,$dest_directory,$dest_file) =
1604 File::Spec::Unix->splitpath( $dest ) ;
1605 $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
1606
1607 my ($source_volume,$source_directory,$source_file) =
1608 File::Spec::Unix->splitpath( $source ) ;
1609 $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
1610
1611 my $rel_path = '' ;
1612 if ( $dest ne '' ) {
1613 $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
1614 }
1615
1616 if ( $rel_path ne '' &&
1617 substr( $rel_path, -1 ) ne '/' &&
1618 substr( $dest_file, 0, 1 ) ne '#'
1619 ) {
1620 $rel_path .= "/$dest_file" ;
1621 }
1622 else {
1623 $rel_path .= "$dest_file" ;
1624 }
1625
1626 return $rel_path ;
1627}
1628
1629#
54310121 1630# process_BFI - process any of the B<>, F<>, or I<> pod-escapes and
1631# convert them to corresponding HTML directives.
1632#
1633sub process_BFI {
1634 my($tag, $str) = @_;
1635 my($s1); # work string
1636 my(%repltext) = ( 'B' => 'STRONG',
1637 'F' => 'EM',
1638 'I' => 'EM');
1639
1640 # extract the modified text and convert to HTML
1641 $s1 = "<$repltext{$tag}>$str</$repltext{$tag}>";
1642 return $s1;
1643}
1644
1645#
1646# process_C - process the C<> pod-escape.
1647#
1648sub process_C {
1649 my($str, $doref) = @_;
1650 my($s1, $s2);
1651
1652 $s1 = $str;
1653 $s1 =~ s/\([^()]*\)//g; # delete parentheses
be173d55 1654 $s2 = $s1;
54310121 1655 $s1 =~ s/\W//g; # delete bogus characters
7b8d334a 1656 $str = html_escape($str);
54310121 1657
1658 # if there was a pod file that we found earlier with an appropriate
1659 # =item directive, then create a link to that page.
1660 if ($doref && defined $items{$s1}) {
5a039dd3 1661 if ( $items{$s1} ) {
1662 my $link = "$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) ;
29f227c9 1663 # Here, we take advantage of the knowledge that $htmlfileurl ne ''
1664 # implies $htmlroot eq ''.
1665 my $url ;
1666 if ( $htmlfileurl ne '' ) {
1667 $link = "$htmldir$link" ;
1668 $url = relativize_url( $link, $htmlfileurl ) ;
1669 }
1670 else {
1671 $url = $link ;
1672 }
5a039dd3 1673 $s1 = "<A HREF=\"$url\">$str</A>" ;
1674 }
1675 else {
1676 $s1 = "<A HREF=\"#item_" . htmlify(0,$s2) . "\">$str</A>" ;
1677 }
54310121 1678 $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,;
1679 confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/;
1680 } else {
1681 $s1 = "<CODE>$str</CODE>";
1682 # warn "$0: $podfile: cannot resolve C<$str> in paragraph $paragraph\n" if $verbose
1683 }
1684
1685
1686 return $s1;
1687}
1688
1689#
1690# process_E - process the E<> pod directive which seems to escape a character.
1691#
1692sub process_E {
1693 my($str) = @_;
1694
1695 for ($str) {
1696 s,([^/].*),\&$1\;,g;
1697 }
1698
1699 return $str;
1700}
1701
1702#
1703# process_Z - process the Z<> pod directive which really just amounts to
1704# ignoring it. this allows someone to start a paragraph with an =
1705#
1706sub process_Z {
1707 my($str) = @_;
1708
1709 # there is no equivalent in HTML for this so just ignore it.
1710 $str = "";
1711 return $str;
1712}
1713
1714#
1715# process_S - process the S<> pod directive which means to convert all
1716# spaces in the string to non-breaking spaces (in HTML-eze).
1717#
1718sub process_S {
1719 my($str) = @_;
1720
1721 # convert all spaces in the text to non-breaking spaces in HTML.
1722 $str =~ s/ /&nbsp;/g;
1723 return $str;
1724}
1725
1726#
1727# process_X - this is supposed to make an index entry. we'll just
1728# ignore it.
1729#
1730sub process_X {
1731 return '';
1732}
1733
1734
1735#
29f227c9 1736# Adapted from Nick Ing-Simmons' PodToHtml package.
1737sub relative_url {
1738 my $source_file = shift ;
1739 my $destination_file = shift;
1740
1741 my $source = URI::file->new_abs($source_file);
1742 my $uo = URI::file->new($destination_file,$source)->abs;
1743 return $uo->rel->as_string;
1744}
1745
1746
1747#
54310121 1748# finish_list - finish off any pending HTML lists. this should be called
1749# after the entire pod file has been read and converted.
1750#
1751sub finish_list {
7b8d334a 1752 while ($listlevel > 0) {
54310121 1753 print HTML "</DL>\n";
1754 $listlevel--;
1755 }
1756}
1757
1758#
1759# htmlify - converts a pod section specification to a suitable section
1760# specification for HTML. if first arg is 1, only takes 1st word.
1761#
1762sub htmlify {
1763 my($compact, $heading) = @_;
1764
1765 if ($compact) {
1766 $heading =~ /^(\w+)/;
1767 $heading = $1;
1768 }
1769
1770 # $heading = lc($heading);
1771 $heading =~ s/[^\w\s]/_/g;
1772 $heading =~ s/(\s+)/ /g;
1773 $heading =~ s/^\s*(.*?)\s*$/$1/s;
1774 $heading =~ s/ /_/g;
1775 $heading =~ s/\A(.{32}).*\Z/$1/s;
1776 $heading =~ s/\s+\Z//;
1777 $heading =~ s/_{2,}/_/g;
1778
1779 return $heading;
1780}
1781
1782BEGIN {
1783}
1784
17851;
Unnamed repository; edit this file to name it for gitweb.