Re: Copious warnings from Sys::Syslog
[p5sagit/p5-mst-13.2.git] / lib / Pod / Html.pm
CommitLineData
54310121 1package Pod::Html;
0e4548d5 2use strict;
54310121 3require Exporter;
0e4548d5 4
5use vars qw($VERSION @ISA @EXPORT);
d6a466d7 6$VERSION = 1.04;
0e4548d5 7@ISA = qw(Exporter);
54310121 8@EXPORT = qw(pod2html htmlify);
54310121 9
10use Carp;
0e4548d5 11use Config;
12use Cwd;
af75be11 13use File::Spec;
0e4548d5 14use File::Spec::Unix;
15use Getopt::Long;
54310121 16
3ec07288 17use locale; # make \w work right in non-ASCII lands
18
54310121 19=head1 NAME
20
7b8d334a 21Pod::Html - module to convert pod files to HTML
54310121 22
23=head1 SYNOPSIS
24
7b8d334a 25 use Pod::Html;
54310121 26 pod2html([options]);
27
28=head1 DESCRIPTION
29
30Converts files from pod format (see L<perlpod>) to HTML format. It
31can automatically generate indexes and cross-references, and it keeps
32a cache of things it knows how to cross-reference.
33
34=head1 ARGUMENTS
35
36Pod::Html takes the following arguments:
37
38=over 4
39
0e4548d5 40=item backlink
41
42 --backlink="Back to Top"
43
59ecbafa 44Adds "Back to Top" links in front of every C<head1> heading (except for
45the first). By default, no backlinks are generated.
0e4548d5 46
b42210d7 47=item cachedir
48
49 --cachedir=name
50
51Creates the item and directory caches in the given directory.
52
0e4548d5 53=item css
54
55 --css=stylesheet
56
59ecbafa 57Specify the URL of a cascading style sheet. Also disables all HTML/CSS
58C<style> attributes that are output by default (to avoid conflicts).
0e4548d5 59
60=item flush
61
62 --flush
63
64Flushes the item and directory caches.
65
66=item header
67
68 --header
69 --noheader
70
59ecbafa 71Creates header and footer blocks containing the text of the C<NAME>
72section. By default, no headers are generated.
0e4548d5 73
54310121 74=item help
75
76 --help
77
78Displays the usage message.
79
5a039dd3 80=item htmldir
81
82 --htmldir=name
83
84Sets the directory in which the resulting HTML file is placed. This
29f227c9 85is used to generate relative links to other files. Not passing this
86causes all links to be absolute, since this is the value that tells
87Pod::Html the root of the documentation tree.
5a039dd3 88
54310121 89=item htmlroot
90
91 --htmlroot=name
92
93Sets the base URL for the HTML files. When cross-references are made,
94the HTML root is prepended to the URL.
95
0e4548d5 96=item index
97
98 --index
99 --noindex
100
101Generate an index at the top of the HTML file. This is the default
102behaviour.
103
54310121 104=item infile
105
106 --infile=name
107
108Specify the pod file to convert. Input is taken from STDIN if no
109infile is specified.
110
54310121 111=item libpods
112
113 --libpods=name:...:name
114
115List of page names (eg, "perlfunc") which contain linkable C<=item>s.
116
117=item netscape
118
119 --netscape
0e4548d5 120 --nonetscape
54310121 121
59ecbafa 122B<Deprecated>, has no effect. For backwards compatibility only.
54310121 123
0e4548d5 124=item outfile
54310121 125
0e4548d5 126 --outfile=name
54310121 127
0e4548d5 128Specify the HTML file to create. Output goes to STDOUT if no outfile
129is specified.
54310121 130
0e4548d5 131=item podpath
54310121 132
0e4548d5 133 --podpath=name:...:name
54310121 134
0e4548d5 135Specify which subdirectories of the podroot contain pod files whose
59ecbafa 136HTML converted forms can be linked to in cross references.
54310121 137
0e4548d5 138=item podroot
54310121 139
0e4548d5 140 --podroot=name
54310121 141
0e4548d5 142Specify the base directory for finding library pods.
54310121 143
0e4548d5 144=item quiet
54310121 145
0e4548d5 146 --quiet
147 --noquiet
54310121 148
0e4548d5 149Don't display I<mostly harmless> warning messages. These messages
150will be displayed by default. But this is not the same as C<verbose>
151mode.
54310121 152
0e4548d5 153=item recurse
54310121 154
0e4548d5 155 --recurse
54310121 156 --norecurse
157
0e4548d5 158Recurse into subdirectories specified in podpath (default behaviour).
54310121 159
160=item title
161
162 --title=title
163
164Specify the title of the resulting HTML file.
165
166=item verbose
167
168 --verbose
0e4548d5 169 --noverbose
54310121 170
0e4548d5 171Display progress messages. By default, they won't be displayed.
34db337b 172
54310121 173=back
174
175=head1 EXAMPLE
176
177 pod2html("pod2html",
59ecbafa 178 "--podpath=lib:ext:pod:vms",
54310121 179 "--podroot=/usr/src/perl",
180 "--htmlroot=/perl/nmanual",
181 "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
182 "--recurse",
183 "--infile=foo.pod",
184 "--outfile=/perl/nmanual/foo.html");
185
34db337b 186=head1 ENVIRONMENT
187
59ecbafa 188Uses C<$Config{pod2html}> to setup default options.
34db337b 189
54310121 190=head1 AUTHOR
191
192Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
193
54310121 194=head1 SEE ALSO
195
196L<perlpod>
197
198=head1 COPYRIGHT
199
200This program is distributed under the Artistic License.
201
202=cut
203
b42210d7 204my $cachedir = "."; # The directory to which item and directory
205 # caches will be written.
1f763251 206my $cache_ext = $^O eq 'VMS' ? ".tmp" : ".x~~";
207my $dircache = "pod2htmd$cache_ext";
208my $itemcache = "pod2htmi$cache_ext";
54310121 209
210my @begin_stack = (); # begin/end stack
211
29f227c9 212my @libpods = (); # files to search for links from C<> directives
213my $htmlroot = "/"; # http-server base directory from which all
54310121 214 # relative paths in $podpath stem.
5a039dd3 215my $htmldir = ""; # The directory to which the html pages
216 # will (eventually) be written.
54310121 217my $htmlfile = ""; # write to stdout by default
29f227c9 218my $htmlfileurl = "" ; # The url that other files would use to
5a039dd3 219 # refer to this file. This is only used
220 # to make relative urls that point to
221 # other files.
54310121 222my $podfile = ""; # read from stdin by default
223my @podpath = (); # list of directories containing library pods.
af75be11 224my $podroot = File::Spec->curdir; # filesystem base directory from which all
54310121 225 # relative paths in $podpath stem.
34db337b 226my $css = ''; # Cascading style sheet
54310121 227my $recurse = 1; # recurse on subdirectories in $podpath.
34db337b 228my $quiet = 0; # not quiet by default
54310121 229my $verbose = 0; # not verbose by default
230my $doindex = 1; # non-zero if we should generate an index
0e4548d5 231my $backlink = ''; # text for "back to top" links
54310121 232my $listlevel = 0; # current list depth
2a28b791 233my @listend = (); # the text to use to end the list.
234my $after_lpar = 0; # set to true after a par in an =item
54310121 235my $ignore = 1; # whether or not to format text. we don't
236 # format text until we hit our first pod
237 # directive.
238
239my %items_named = (); # for the multiples of the same item in perlfunc
240my @items_seen = ();
54310121 241my $title; # title to give the pod(s)
34db337b 242my $header = 0; # produce block header/footer
54310121 243my $top = 1; # true if we are at the top of the doc. used
59ecbafa 244 # to prevent the first <hr /> directive.
54310121 245my $paragraph; # which paragraph we're processing (used
246 # for error messages)
2a28b791 247my $ptQuote = 0; # status of double-quote conversion
54310121 248my %pages = (); # associative array used to find the location
249 # of pages referenced by L<> links.
250my %sections = (); # sections within this page
251my %items = (); # associative array used to find the location
252 # of =item directives referenced by C<> links
2a28b791 253my %local_items = (); # local items - avoid destruction of %items
39e571d4 254my $Is83; # is dos with short filenames (8.3)
255
54310121 256sub init_globals {
04f720db 257$dircache = "pod2htmd$cache_ext";
258$itemcache = "pod2htmi$cache_ext";
54310121 259
260@begin_stack = (); # begin/end stack
261
262@libpods = (); # files to search for links from C<> directives
263$htmlroot = "/"; # http-server base directory from which all
264 # relative paths in $podpath stem.
67398a75 265$htmldir = ""; # The directory to which the html pages
266 # will (eventually) be written.
54310121 267$htmlfile = ""; # write to stdout by default
268$podfile = ""; # read from stdin by default
269@podpath = (); # list of directories containing library pods.
af75be11 270$podroot = File::Spec->curdir; # filesystem base directory from which all
54310121 271 # relative paths in $podpath stem.
34db337b 272$css = ''; # Cascading style sheet
54310121 273$recurse = 1; # recurse on subdirectories in $podpath.
34db337b 274$quiet = 0; # not quiet by default
54310121 275$verbose = 0; # not verbose by default
276$doindex = 1; # non-zero if we should generate an index
0e4548d5 277$backlink = ''; # text for "back to top" links
54310121 278$listlevel = 0; # current list depth
2a28b791 279@listend = (); # the text to use to end the list.
280$after_lpar = 0; # set to true after a par in an =item
54310121 281$ignore = 1; # whether or not to format text. we don't
282 # format text until we hit our first pod
283 # directive.
284
285@items_seen = ();
286%items_named = ();
34db337b 287$header = 0; # produce block header/footer
54310121 288$title = ''; # title to give the pod(s)
289$top = 1; # true if we are at the top of the doc. used
59ecbafa 290 # to prevent the first <hr /> directive.
54310121 291$paragraph = ''; # which paragraph we're processing (used
292 # for error messages)
54310121 293%sections = (); # sections within this page
3e3baf6d 294
295# These are not reinitialised here but are kept as a cache.
296# See get_cache and related cache management code.
297#%pages = (); # associative array used to find the location
298 # of pages referenced by L<> links.
299#%items = (); # associative array used to find the location
54310121 300 # of =item directives referenced by C<> links
2a28b791 301%local_items = ();
39e571d4 302$Is83=$^O eq 'dos';
54310121 303}
304
2a28b791 305#
306# clean_data: global clean-up of pod data
307#
308sub clean_data($){
309 my( $dataref ) = @_;
bf202ccd 310 for my $i ( 0..$#{$dataref} ) {
2a28b791 311 ${$dataref}[$i] =~ s/\s+\Z//;
312
313 # have a look for all-space lines
4135c0a0 314 if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
2a28b791 315 my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
316 splice( @$dataref, $i, 1, @chunks );
317 }
318 }
319}
320
321
54310121 322sub pod2html {
323 local(@ARGV) = @_;
324 local($/);
325 local $_;
326
327 init_globals();
328
39e571d4 329 $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
330
54310121 331 # cache of %pages and %items from last time we ran pod2html
54310121 332
333 #undef $opt_help if defined $opt_help;
334
335 # parse the command-line parameters
336 parse_command_line();
337
59ecbafa 338 # escape the backlink argument (same goes for title but is done later...)
339 $backlink = html_escape($backlink) if defined $backlink;
340
54310121 341 # set some variables to their default values if necessary
342 local *POD;
59ecbafa 343 unless (@ARGV && $ARGV[0]) {
54310121 344 $podfile = "-" unless $podfile; # stdin
345 open(POD, "<$podfile")
346 || die "$0: cannot open $podfile file for input: $!\n";
347 } else {
348 $podfile = $ARGV[0]; # XXX: might be more filenames
349 *POD = *ARGV;
59ecbafa 350 }
54310121 351 $htmlfile = "-" unless $htmlfile; # stdout
352 $htmlroot = "" if $htmlroot eq "/"; # so we don't get a //
fe6f1558 353 $htmldir =~ s#/\z## ; # so we don't get a //
29f227c9 354 if ( $htmlroot eq ''
59ecbafa 355 && defined( $htmldir )
29f227c9 356 && $htmldir ne ''
59ecbafa 357 && substr( $htmlfile, 0, length( $htmldir ) ) eq $htmldir
358 )
5a039dd3 359 {
29f227c9 360 # Set the 'base' url for this file, so that we can use it
59ecbafa 361 # as the location from which to calculate relative links
29f227c9 362 # to other files. If this is '', then absolute links will
363 # be used throughout.
364 $htmlfileurl= "$htmldir/" . substr( $htmlfile, length( $htmldir ) + 1);
5a039dd3 365 }
54310121 366
367 # read the pod a paragraph at a time
368 warn "Scanning for sections in input file(s)\n" if $verbose;
369 $/ = "";
370 my @poddata = <POD>;
371 close(POD);
2a28b791 372 clean_data( \@poddata );
54310121 373
374 # scan the pod for =head[1-6] directives and build an index
375 my $index = scan_headings(\%sections, @poddata);
376
3e3baf6d 377 unless($index) {
31e56455 378 warn "No headings in $podfile\n" if $verbose;
3e3baf6d 379 }
380
54310121 381 # open the output file
382 open(HTML, ">$htmlfile")
383 || die "$0: cannot open $htmlfile file for output: $!\n";
384
d011ffae 385 # put a title in the HTML file if one wasn't specified
386 if ($title eq '') {
387 TITLE_SEARCH: {
59ecbafa 388 for (my $i = 0; $i < @poddata; $i++) {
d011ffae 389 if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
59ecbafa 390 for my $para ( @poddata[$i, $i+1] ) {
d011ffae 391 last TITLE_SEARCH
392 if ($title) = $para =~ /(\S+\s+-+.*\S)/s;
393 }
59ecbafa 394 }
54310121 395
59ecbafa 396 }
d011ffae 397 }
398 }
fe6f1558 399 if (!$title and $podfile =~ /\.pod\z/) {
3e3baf6d 400 # probably a split pod so take first =head[12] as title
59ecbafa 401 for (my $i = 0; $i < @poddata; $i++) {
3e3baf6d 402 last if ($title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
59ecbafa 403 }
3e3baf6d 404 warn "adopted '$title' as title for $podfile\n"
405 if $verbose and $title;
59ecbafa 406 }
7b8d334a 407 if ($title) {
408 $title =~ s/\s*\(.*\)//;
409 } else {
f8f99792 410 warn "$0: no title for $podfile.\n" unless $quiet;
fe6f1558 411 $podfile =~ /^(.*)(\.[^.\/]+)?\z/s;
54310121 412 $title = ($podfile eq "-" ? 'No Title' : $1);
3e3baf6d 413 warn "using $title" if $verbose;
54310121 414 }
59ecbafa 415 $title = html_escape($title);
416
417 my $csslink = '';
418 my $bodystyle = ' style="background-color: white"';
419 my $tdstyle = ' style="background-color: #cccccc"';
420
421 if ($css) {
422 $csslink = qq(\n<link rel="stylesheet" href="$css" type="text/css" />);
423 $csslink =~ s,\\,/,g;
424 $csslink =~ s,(/.):,$1|,;
425 $bodystyle = '';
426 $tdstyle = '';
427 }
428
429 my $block = $header ? <<END_OF_BLOCK : '';
430<table border="0" width="100%" cellspacing="0" cellpadding="3">
431<tr><td class="block"$tdstyle valign="middle">
432<big><strong><span class="block">&nbsp;$title</span></strong></big>
433</td></tr>
434</table>
34db337b 435END_OF_BLOCK
436
54310121 437 print HTML <<END_OF_HEAD;
59ecbafa 438<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
439<html xmlns="http://www.w3.org/1999/xhtml">
8d481ee5 440<head>
59ecbafa 441<title>$title</title>$csslink
442<link rev="made" href="mailto:$Config{perladmin}" />
443</head>
444
445<body$bodystyle>
34db337b 446$block
54310121 447END_OF_HEAD
448
3e3baf6d 449 # load/reload/validate/cache %pages and %items
450 get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse);
54310121 451
452 # scan the pod for =item directives
2a28b791 453 scan_items( \%local_items, "", @poddata);
54310121 454
455 # put an index at the top of the file. note, if $doindex is 0 we
456 # still generate an index, but surround it with an html comment.
457 # that way some other program can extract it if desired.
458 $index =~ s/--+/-/g;
59ecbafa 459 print HTML "<p><a name=\"__index__\"></a></p>\n";
54310121 460 print HTML "<!-- INDEX BEGIN -->\n";
461 print HTML "<!--\n" unless $doindex;
462 print HTML $index;
463 print HTML "-->\n" unless $doindex;
464 print HTML "<!-- INDEX END -->\n\n";
59ecbafa 465 print HTML "<hr />\n" if $doindex and $index;
54310121 466
467 # now convert this file
2a28b791 468 my $after_item; # set to true after an =item
59ecbafa 469 my $need_dd = 0;
2a28b791 470 warn "Converting input file $podfile\n" if $verbose;
471 foreach my $i (0..$#poddata){
472 $ptQuote = 0; # status of quote conversion
473
54310121 474 $_ = $poddata[$i];
475 $paragraph = $i+1;
476 if (/^(=.*)/s) { # is it a pod directive?
477 $ignore = 0;
2a28b791 478 $after_item = 0;
59ecbafa 479 $need_dd = 0;
54310121 480 $_ = $1;
481 if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
482 process_begin($1, $2);
483 } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
484 process_end($1, $2);
485 } elsif (/^=cut/) { # =cut
486 process_cut();
487 } elsif (/^=pod/) { # =pod
488 process_pod();
489 } else {
490 next if @begin_stack && $begin_stack[-1] ne 'html';
491
7b8d334a 492 if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
2a28b791 493 process_head( $1, $2, $doindex && $index );
494 } elsif (/^=item\s*(.*\S)?/sm) { # =item text
59ecbafa 495 $need_dd = process_item( $1 );
2a28b791 496 $after_item = 1;
54310121 497 } elsif (/^=over\s*(.*)/) { # =over N
498 process_over();
499 } elsif (/^=back/) { # =back
500 process_back();
a45bd81d 501 } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for
54310121 502 process_for($1,$2);
503 } else {
504 /^=(\S*)\s*/;
505 warn "$0: $podfile: unknown pod directive '$1' in "
506 . "paragraph $paragraph. ignoring.\n";
507 }
508 }
509 $top = 0;
510 }
511 else {
512 next if $ignore;
513 next if @begin_stack && $begin_stack[-1] ne 'html';
59ecbafa 514 print HTML and next if @begin_stack && $begin_stack[-1] eq 'html';
515 print HTML "<dd>\n" if $need_dd;
54310121 516 my $text = $_;
2a28b791 517 if( $text =~ /\A\s+/ ){
518 process_pre( \$text );
59ecbafa 519 print HTML "<pre>\n$text</pre>\n";
2a28b791 520
521 } else {
522 process_text( \$text );
523
524 # experimental: check for a paragraph where all lines
525 # have some ...\t...\t...\n pattern
526 if( $text =~ /\t/ ){
527 my @lines = split( "\n", $text );
528 if( @lines > 1 ){
529 my $all = 2;
530 foreach my $line ( @lines ){
531 if( $line =~ /\S/ && $line !~ /\t/ ){
532 $all--;
533 last if $all == 0;
534 }
535 }
536 if( $all > 0 ){
59ecbafa 537 $text =~ s/\t+/<td>/g;
538 $text =~ s/^/<tr><td>/gm;
539 $text = '<table cellspacing="0" cellpadding="0">' .
540 $text . '</table>';
2a28b791 541 }
542 }
543 }
544 ## end of experimental
545
546 if( $after_item ){
547 print HTML "$text\n";
548 $after_lpar = 1;
549 } else {
59ecbafa 550 print HTML "<p>$text</p>\n";
2a28b791 551 }
552 }
59ecbafa 553 print HTML "</dd>\n" if $need_dd;
2a28b791 554 $after_item = 0;
54310121 555 }
556 }
557
558 # finish off any pending directives
559 finish_list();
2a28b791 560
561 # link to page index
59ecbafa 562 print HTML "<p><a href=\"#__index__\"><small>$backlink</small></a></p>\n"
0e4548d5 563 if $doindex and $index and $backlink;
2a28b791 564
54310121 565 print HTML <<END_OF_TAIL;
34db337b 566$block
59ecbafa 567</body>
54310121 568
59ecbafa 569</html>
54310121 570END_OF_TAIL
571
572 # close the html file
573 close(HTML);
574
575 warn "Finished\n" if $verbose;
576}
577
578##############################################################################
579
580my $usage; # see below
581sub usage {
582 my $podfile = shift;
583 warn "$0: $podfile: @_\n" if @_;
584 die $usage;
585}
586
587$usage =<<END_OF_USAGE;
588Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
589 --podpath=<name>:...:<name> --podroot=<name>
590 --libpods=<name>:...:<name> --recurse --verbose --index
b42210d7 591 --netscape --norecurse --noindex --cachedir=<name>
54310121 592
0e4548d5 593 --backlink - set text for "back to top" links (default: none).
b42210d7 594 --cachedir - directory for the item and directory cache files.
0e4548d5 595 --css - stylesheet URL
596 --flush - flushes the item and directory caches.
597 --[no]header - produce block header/footer (default is no headers).
598 --help - prints this message.
599 --htmldir - directory for resulting HTML files.
600 --htmlroot - http-server base directory from which all relative paths
601 in podpath stem (default is /).
602 --[no]index - generate an index at the top of the resulting html
603 (default behaviour).
604 --infile - filename for the pod to convert (input taken from stdin
605 by default).
606 --libpods - colon-separated list of pages to search for =item pod
607 directives in as targets of C<> and implicit links (empty
608 by default). note, these are not filenames, but rather
609 page names like those that appear in L<> links.
0e4548d5 610 --outfile - filename for the resulting html file (output sent to
611 stdout by default).
612 --podpath - colon-separated list of directories containing library
613 pods (empty by default).
614 --podroot - filesystem base directory from which all relative paths
615 in podpath stem (default is .).
616 --[no]quiet - supress some benign warning messages (default is off).
617 --[no]recurse - recurse on those subdirectories listed in podpath
618 (default behaviour).
619 --title - title that will appear in resulting html file.
620 --[no]verbose - self-explanatory (off by default).
59ecbafa 621 --[no]netscape - deprecated, has no effect. for backwards compatibility only.
54310121 622
623END_OF_USAGE
624
625sub parse_command_line {
b42210d7 626 my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
627 $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
628 $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
629 $opt_recurse,$opt_title,$opt_verbose);
0e4548d5 630
34db337b 631 unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
54310121 632 my $result = GetOptions(
0e4548d5 633 'backlink=s' => \$opt_backlink,
b42210d7 634 'cachedir=s' => \$opt_cachedir,
0e4548d5 635 'css=s' => \$opt_css,
29f227c9 636 'flush' => \$opt_flush,
0e4548d5 637 'header!' => \$opt_header,
29f227c9 638 'help' => \$opt_help,
639 'htmldir=s' => \$opt_htmldir,
54310121 640 'htmlroot=s' => \$opt_htmlroot,
29f227c9 641 'index!' => \$opt_index,
54310121 642 'infile=s' => \$opt_infile,
643 'libpods=s' => \$opt_libpods,
644 'netscape!' => \$opt_netscape,
645 'outfile=s' => \$opt_outfile,
646 'podpath=s' => \$opt_podpath,
647 'podroot=s' => \$opt_podroot,
0e4548d5 648 'quiet!' => \$opt_quiet,
54310121 649 'recurse!' => \$opt_recurse,
650 'title=s' => \$opt_title,
0e4548d5 651 'verbose!' => \$opt_verbose,
54310121 652 );
653 usage("-", "invalid parameters") if not $result;
654
655 usage("-") if defined $opt_help; # see if the user asked for help
656 $opt_help = ""; # just to make -w shut-up.
657
54310121 658 @podpath = split(":", $opt_podpath) if defined $opt_podpath;
659 @libpods = split(":", $opt_libpods) if defined $opt_libpods;
660
0e4548d5 661 $backlink = $opt_backlink if defined $opt_backlink;
b42210d7 662 $cachedir = $opt_cachedir if defined $opt_cachedir;
0e4548d5 663 $css = $opt_css if defined $opt_css;
664 $header = $opt_header if defined $opt_header;
665 $htmldir = $opt_htmldir if defined $opt_htmldir;
666 $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
667 $doindex = $opt_index if defined $opt_index;
668 $podfile = $opt_infile if defined $opt_infile;
0e4548d5 669 $htmlfile = $opt_outfile if defined $opt_outfile;
670 $podroot = $opt_podroot if defined $opt_podroot;
671 $quiet = $opt_quiet if defined $opt_quiet;
672 $recurse = $opt_recurse if defined $opt_recurse;
673 $title = $opt_title if defined $opt_title;
674 $verbose = $opt_verbose if defined $opt_verbose;
675
54310121 676 warn "Flushing item and directory caches\n"
677 if $opt_verbose && defined $opt_flush;
b42210d7 678 $dircache = "$cachedir/pod2htmd$cache_ext";
679 $itemcache = "$cachedir/pod2htmi$cache_ext";
54310121 680 unlink($dircache, $itemcache) if defined $opt_flush;
54310121 681}
682
3e3baf6d 683
684my $saved_cache_key;
685
686sub get_cache {
687 my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
688 my @cache_key_args = @_;
689
690 # A first-level cache:
691 # Don't bother reading the cache files if they still apply
692 # and haven't changed since we last read them.
693
694 my $this_cache_key = cache_key(@cache_key_args);
695
696 return if $saved_cache_key and $this_cache_key eq $saved_cache_key;
697
698 # load the cache of %pages and %items if possible. $tests will be
699 # non-zero if successful.
700 my $tests = 0;
701 if (-f $dircache && -f $itemcache) {
702 warn "scanning for item cache\n" if $verbose;
703 $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
704 }
705
706 # if we didn't succeed in loading the cache then we must (re)build
707 # %pages and %items.
708 if (!$tests) {
709 warn "scanning directories in pod-path\n" if $verbose;
710 scan_podpath($podroot, $recurse, 0);
711 }
712 $saved_cache_key = cache_key(@cache_key_args);
713}
714
715sub cache_key {
716 my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
717 return join('!', $dircache, $itemcache, $recurse,
29f227c9 718 @$podpath, $podroot, stat($dircache), stat($itemcache));
3e3baf6d 719}
720
54310121 721#
3e3baf6d 722# load_cache - tries to find if the caches stored in $dircache and $itemcache
54310121 723# are valid caches of %pages and %items. if they are valid then it loads
724# them and returns a non-zero value.
725#
3e3baf6d 726sub load_cache {
54310121 727 my($dircache, $itemcache, $podpath, $podroot) = @_;
728 my($tests);
729 local $_;
730
731 $tests = 0;
732
733 open(CACHE, "<$itemcache") ||
734 die "$0: error opening $itemcache for reading: $!\n";
735 $/ = "\n";
736
737 # is it the same podpath?
738 $_ = <CACHE>;
739 chomp($_);
3e3baf6d 740 $tests++ if (join(":", @$podpath) eq $_);
54310121 741
742 # is it the same podroot?
743 $_ = <CACHE>;
744 chomp($_);
745 $tests++ if ($podroot eq $_);
746
747 # load the cache if its good
748 if ($tests != 2) {
749 close(CACHE);
54310121 750 return 0;
751 }
752
753 warn "loading item cache\n" if $verbose;
754 while (<CACHE>) {
755 /(.*?) (.*)$/;
756 $items{$1} = $2;
757 }
758 close(CACHE);
759
760 warn "scanning for directory cache\n" if $verbose;
761 open(CACHE, "<$dircache") ||
762 die "$0: error opening $dircache for reading: $!\n";
763 $/ = "\n";
764 $tests = 0;
765
766 # is it the same podpath?
767 $_ = <CACHE>;
768 chomp($_);
3e3baf6d 769 $tests++ if (join(":", @$podpath) eq $_);
54310121 770
771 # is it the same podroot?
772 $_ = <CACHE>;
773 chomp($_);
774 $tests++ if ($podroot eq $_);
775
776 # load the cache if its good
777 if ($tests != 2) {
778 close(CACHE);
54310121 779 return 0;
780 }
781
782 warn "loading directory cache\n" if $verbose;
783 while (<CACHE>) {
784 /(.*?) (.*)$/;
785 $pages{$1} = $2;
786 }
787
788 close(CACHE);
789
790 return 1;
791}
792
793#
794# scan_podpath - scans the directories specified in @podpath for directories,
795# .pod files, and .pm files. it also scans the pod files specified in
796# @libpods for =item directives.
797#
798sub scan_podpath {
3e3baf6d 799 my($podroot, $recurse, $append) = @_;
54310121 800 my($pwd, $dir);
801 my($libpod, $dirname, $pod, @files, @poddata);
802
3e3baf6d 803 unless($append) {
804 %items = ();
805 %pages = ();
806 }
807
54310121 808 # scan each directory listed in @podpath
809 $pwd = getcwd();
810 chdir($podroot)
811 || die "$0: error changing to directory $podroot: $!\n";
812 foreach $dir (@podpath) {
813 scan_dir($dir, $recurse);
814 }
815
816 # scan the pods listed in @libpods for =item directives
817 foreach $libpod (@libpods) {
818 # if the page isn't defined then we won't know where to find it
819 # on the system.
820 next unless defined $pages{$libpod} && $pages{$libpod};
821
822 # if there is a directory then use the .pod and .pm files within it.
29f227c9 823 # NOTE: Only finds the first so-named directory in the tree.
824# if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
825 if ($pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
54310121 826 # find all the .pod and .pm files within the directory
827 $dirname = $1;
828 opendir(DIR, $dirname) ||
829 die "$0: error opening directory $dirname: $!\n";
fe6f1558 830 @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
54310121 831 closedir(DIR);
832
833 # scan each .pod and .pm file for =item directives
834 foreach $pod (@files) {
835 open(POD, "<$dirname/$pod") ||
836 die "$0: error opening $dirname/$pod for input: $!\n";
837 @poddata = <POD>;
838 close(POD);
2a28b791 839 clean_data( \@poddata );
54310121 840
2a28b791 841 scan_items( \%items, "$dirname/$pod", @poddata);
54310121 842 }
843
844 # use the names of files as =item directives too.
2a28b791 845### Don't think this should be done this way - confuses issues.(WL)
846### foreach $pod (@files) {
847### $pod =~ /^(.*)(\.pod|\.pm)$/;
848### $items{$1} = "$dirname/$1.html" if $1;
849### }
54310121 850 } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ ||
851 $pages{$libpod} =~ /([^:]*\.pm):/) {
852 # scan the .pod or .pm file for =item directives
853 $pod = $1;
854 open(POD, "<$pod") ||
855 die "$0: error opening $pod for input: $!\n";
856 @poddata = <POD>;
857 close(POD);
2a28b791 858 clean_data( \@poddata );
54310121 859
2a28b791 860 scan_items( \%items, "$pod", @poddata);
54310121 861 } else {
862 warn "$0: shouldn't be here (line ".__LINE__."\n";
863 }
864 }
865 @poddata = (); # clean-up a bit
866
867 chdir($pwd)
868 || die "$0: error changing to directory $pwd: $!\n";
869
870 # cache the item list for later use
871 warn "caching items for later use\n" if $verbose;
872 open(CACHE, ">$itemcache") ||
873 die "$0: error open $itemcache for writing: $!\n";
874
875 print CACHE join(":", @podpath) . "\n$podroot\n";
876 foreach my $key (keys %items) {
877 print CACHE "$key $items{$key}\n";
878 }
879
880 close(CACHE);
881
882 # cache the directory list for later use
883 warn "caching directories for later use\n" if $verbose;
884 open(CACHE, ">$dircache") ||
885 die "$0: error open $dircache for writing: $!\n";
886
887 print CACHE join(":", @podpath) . "\n$podroot\n";
888 foreach my $key (keys %pages) {
889 print CACHE "$key $pages{$key}\n";
890 }
891
892 close(CACHE);
893}
894
895#
896# scan_dir - scans the directory specified in $dir for subdirectories, .pod
897# files, and .pm files. notes those that it finds. this information will
898# be used later in order to figure out where the pages specified in L<>
899# links are on the filesystem.
900#
901sub scan_dir {
902 my($dir, $recurse) = @_;
903 my($t, @subdirs, @pods, $pod, $dirname, @dirs);
904 local $_;
905
906 @subdirs = ();
907 @pods = ();
908
909 opendir(DIR, $dir) ||
910 die "$0: error opening directory $dir: $!\n";
911 while (defined($_ = readdir(DIR))) {
912 if (-d "$dir/$_" && $_ ne "." && $_ ne "..") { # directory
913 $pages{$_} = "" unless defined $pages{$_};
914 $pages{$_} .= "$dir/$_:";
915 push(@subdirs, $_);
fe6f1558 916 } elsif (/\.pod\z/) { # .pod
917 s/\.pod\z//;
54310121 918 $pages{$_} = "" unless defined $pages{$_};
919 $pages{$_} .= "$dir/$_.pod:";
920 push(@pods, "$dir/$_.pod");
d3f9d0fb 921 } elsif (/\.html\z/) { # .html
922 s/\.html\z//;
923 $pages{$_} = "" unless defined $pages{$_};
924 $pages{$_} .= "$dir/$_.pod:";
fe6f1558 925 } elsif (/\.pm\z/) { # .pm
926 s/\.pm\z//;
54310121 927 $pages{$_} = "" unless defined $pages{$_};
928 $pages{$_} .= "$dir/$_.pm:";
929 push(@pods, "$dir/$_.pm");
930 }
931 }
932 closedir(DIR);
933
934 # recurse on the subdirectories if necessary
935 if ($recurse) {
936 foreach my $subdir (@subdirs) {
937 scan_dir("$dir/$subdir", $recurse);
938 }
939 }
940}
941
942#
943# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
944# build an index.
945#
946sub scan_headings {
947 my($sections, @data) = @_;
2a28b791 948 my($tag, $which_head, $otitle, $listdepth, $index);
54310121 949
be173d55 950 # here we need local $ignore = 0;
951 # unfortunately, we can't have it, because $ignore is lexical
952 $ignore = 0;
953
54310121 954 $listdepth = 0;
955 $index = "";
956
957 # scan for =head directives, note their name, and build an index
958 # pointing to each of them.
959 foreach my $line (@data) {
59ecbafa 960 if ($line =~ /^=(head)([1-6])\s+(.*)/) {
961 ($tag, $which_head, $otitle) = ($1,$2,$3);
2a28b791 962
59ecbafa 963 my $title = depod( $otitle );
964 my $name = htmlify( $title );
965 $$sections{$name} = 1;
966 $name =~ s/\s/_/g; # htmlify keeps spaces but we don't want them here..
967 $title = process_text( \$otitle );
54310121 968
102c538a 969 while ($which_head != $listdepth) {
970 if ($which_head > $listdepth) {
59ecbafa 971 $index .= "\n" . ("\t" x $listdepth) . "<ul>\n";
102c538a 972 $listdepth++;
973 } elsif ($which_head < $listdepth) {
974 $listdepth--;
59ecbafa 975 $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
102c538a 976 }
54310121 977 }
54310121 978
59ecbafa 979 $index .= "\n" . ("\t" x $listdepth) . "<li>" .
980 "<a href=\"#" . $name . "\">" .
981 $title . "</a></li>";
54310121 982 }
983 }
984
985 # finish off the lists
986 while ($listdepth--) {
59ecbafa 987 $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
54310121 988 }
989
990 # get rid of bogus lists
59ecbafa 991 $index =~ s,\t*<ul>\s*</ul>\n,,g;
54310121 992
bb9460ed 993 $ignore = 1; # restore old value;
be173d55 994
54310121 995 return $index;
996}
997
998#
999# scan_items - scans the pod specified by $pod for =item directives. we
1000# will use this information later on in resolving C<> links.
1001#
1002sub scan_items {
2a28b791 1003 my( $itemref, $pod, @poddata ) = @_;
54310121 1004 my($i, $item);
1005 local $_;
1006
fe6f1558 1007 $pod =~ s/\.pod\z//;
54310121 1008 $pod .= ".html" if $pod;
1009
1010 foreach $i (0..$#poddata) {
2a28b791 1011 my $txt = depod( $poddata[$i] );
1012
1013 # figure out what kind of item it is.
1014 # Build string for referencing this item.
1015 if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bullet
1016 next unless $1;
1017 $item = $1;
1018 } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
1019 $item = $1;
1020 } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # plain item
1021 $item = $1;
1022 } else {
1023 next;
54310121 1024 }
2a28b791 1025 my $fid = fragment_id( $item );
1026 $$itemref{$fid} = "$pod" if $fid;
54310121 1027 }
1028}
1029
1030#
1031# process_head - convert a pod head[1-6] tag and convert it to HTML format.
1032#
1033sub process_head {
2a28b791 1034 my($tag, $heading, $hasindex) = @_;
54310121 1035
1036 # figure out the level of the =head
1037 $tag =~ /head([1-6])/;
1038 my $level = $1;
1039
2a28b791 1040 if( $listlevel ){
1041 warn "$0: $podfile: unterminated list at =head in paragraph $paragraph. ignoring.\n";
1042 while( $listlevel ){
1043 process_back();
1044 }
1045 }
1046
59ecbafa 1047 print HTML "<p>\n";
2a28b791 1048 if( $level == 1 && ! $top ){
59ecbafa 1049 print HTML "<a href=\"#__index__\"><small>$backlink</small></a>\n"
1050 if $hasindex and $backlink;
1051 print HTML "</p>\n<hr />\n"
1052 } else {
1053 print HTML "</p>\n";
2a28b791 1054 }
1055
0d396dd4 1056 my $name = anchorify( depod( $heading ) );
2a28b791 1057 my $convert = process_text( \$heading );
59ecbafa 1058 print HTML "<h$level><a name=\"$name\">$convert</a></h$level>\n";
54310121 1059}
1060
2a28b791 1061
54310121 1062#
2a28b791 1063# emit_item_tag - print an =item's text
1064# Note: The global $EmittedItem is used for inhibiting self-references.
54310121 1065#
2a28b791 1066my $EmittedItem;
1067
1068sub emit_item_tag($$$){
1069 my( $otext, $text, $compact ) = @_;
1070 my $item = fragment_id( $text );
54310121 1071
2a28b791 1072 $EmittedItem = $item;
1073 ### print STDERR "emit_item_tag=$item ($text)\n";
54310121 1074
59ecbafa 1075 print HTML '<strong>';
2a28b791 1076 if ($items_named{$item}++) {
1077 print HTML process_text( \$otext );
1078 } else {
0d396dd4 1079 my $name = 'item_' . $item;
1080 $name = anchorify($name);
59ecbafa 1081 print HTML qq{<a name="$name">}, process_text( \$otext ), '</a>';
2a28b791 1082 }
59ecbafa 1083 print HTML "</strong><br />\n";
2a28b791 1084 undef( $EmittedItem );
1085}
1086
1087sub emit_li {
1088 my( $tag ) = @_;
1089 if( $items_seen[$listlevel]++ == 0 ){
1090 push( @listend, "</$tag>" );
1091 print HTML "<$tag>\n";
1092 }
59ecbafa 1093 my $emitted = $tag eq 'dl' ? 'dt' : 'li';
1094 print HTML "<$emitted>";
1095 return $emitted;
2a28b791 1096}
1097
1098#
1099# process_item - convert a pod item tag and convert it to HTML format.
1100#
1101sub process_item {
1102 my( $otext ) = @_;
59ecbafa 1103 my $need_dd = 0; # set to 1 if we need a <dd></dd> after an item
54310121 1104
1105 # lots of documents start a list without doing an =over. this is
1106 # bad! but, the proper thing to do seems to be to just assume
1107 # they did do an =over. so warn them once and then continue.
2a28b791 1108 if( $listlevel == 0 ){
1109 warn "$0: $podfile: unexpected =item directive in paragraph $paragraph. ignoring.\n";
1110 process_over();
1111 }
54310121 1112
2a28b791 1113 # formatting: insert a paragraph if preceding item has >1 paragraph
1114 if( $after_lpar ){
59ecbafa 1115 print HTML "<p></p>\n";
2a28b791 1116 $after_lpar = 0;
1117 }
54310121 1118
1119 # remove formatting instructions from the text
2a28b791 1120 my $text = depod( $otext );
1121
59ecbafa 1122 my $emitted; # the tag actually emitted, used for closing
1123
2a28b791 1124 # all the list variants:
1125 if( $text =~ /\A\*/ ){ # bullet
59ecbafa 1126 $emitted = emit_li( 'ul' );
1127 if ($text =~ /\A\*\s+(.+)\Z/s ) { # with additional text
1128 my $tag = $1;
1129 $otext =~ s/\A\*\s+//;
1130 emit_item_tag( $otext, $tag, 1 );
1131 }
54310121 1132
2a28b791 1133 } elsif( $text =~ /\A\d+/ ){ # numbered list
59ecbafa 1134 $emitted = emit_li( 'ol' );
1135 if ($text =~ /\A(?>\d+\.?)\s*(.+)\Z/s ) { # with additional text
1136 my $tag = $1;
1137 $otext =~ s/\A\d+\.?\s*//;
1138 emit_item_tag( $otext, $tag, 1 );
1139 }
54310121 1140
2a28b791 1141 } else { # definition list
59ecbafa 1142 $emitted = emit_li( 'dl' );
1143 if ($text =~ /\A(.+)\Z/s ){ # should have text
1144 emit_item_tag( $otext, $text, 1 );
1145 }
1146 $need_dd = 1;
54310121 1147 }
59ecbafa 1148 print HTML "</$emitted>" if $emitted;
54310121 1149 print HTML "\n";
59ecbafa 1150 return $need_dd;
54310121 1151}
1152
1153#
2a28b791 1154# process_over - process a pod over tag and start a corresponding HTML list.
54310121 1155#
1156sub process_over {
1157 # start a new list
1158 $listlevel++;
2a28b791 1159 push( @items_seen, 0 );
1160 $after_lpar = 0;
54310121 1161}
1162
1163#
1164# process_back - process a pod back tag and convert it to HTML format.
1165#
1166sub process_back {
2a28b791 1167 if( $listlevel == 0 ){
1168 warn "$0: $podfile: unexpected =back directive in paragraph $paragraph. ignoring.\n";
1169 return;
1170 }
54310121 1171
1172 # close off the list. note, I check to see if $listend[$listlevel] is
1173 # defined because an =item directive may have never appeared and thus
1174 # $listend[$listlevel] may have never been initialized.
1175 $listlevel--;
2a28b791 1176 if( defined $listend[$listlevel] ){
59ecbafa 1177 print HTML '<p></p>' if $after_lpar;
2a28b791 1178 print HTML $listend[$listlevel];
1179 print HTML "\n";
1180 pop( @listend );
1181 }
1182 $after_lpar = 0;
54310121 1183
2a28b791 1184 # clean up item count
1185 pop( @items_seen );
54310121 1186}
1187
1188#
2a28b791 1189# process_cut - process a pod cut tag, thus start ignoring pod directives.
54310121 1190#
1191sub process_cut {
1192 $ignore = 1;
1193}
1194
1195#
d1be9408 1196# process_pod - process a pod tag, thus stop ignoring pod directives
2a28b791 1197# until we see a corresponding cut.
54310121 1198#
1199sub process_pod {
1200 # no need to set $ignore to 0 cause the main loop did it
1201}
1202
1203#
2a28b791 1204# process_for - process a =for pod tag. if it's for html, spit
c4d9b39d 1205# it out verbatim, if illustration, center it, otherwise ignore it.
54310121 1206#
1207sub process_for {
1208 my($whom, $text) = @_;
1209 if ( $whom =~ /^(pod2)?html$/i) {
1210 print HTML $text;
c4d9b39d 1211 } elsif ($whom =~ /^illustration$/i) {
1212 1 while chomp $text;
1213 for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
1214 $text .= $ext, last if -r "$text$ext";
1215 }
59ecbafa 1216 print HTML qq{<p align="center"><img src="$text" alt="$text illustration" /></p>};
c4d9b39d 1217 }
54310121 1218}
1219
1220#
1221# process_begin - process a =begin pod tag. this pushes
1222# whom we're beginning on the begin stack. if there's a
1223# begin stack, we only print if it us.
1224#
1225sub process_begin {
1226 my($whom, $text) = @_;
1227 $whom = lc($whom);
1228 push (@begin_stack, $whom);
1229 if ( $whom =~ /^(pod2)?html$/) {
1230 print HTML $text if $text;
1231 }
1232}
1233
1234#
1235# process_end - process a =end pod tag. pop the
1236# begin stack. die if we're mismatched.
1237#
1238sub process_end {
1239 my($whom, $text) = @_;
1240 $whom = lc($whom);
1241 if ($begin_stack[-1] ne $whom ) {
1242 die "Unmatched begin/end at chunk $paragraph\n"
59ecbafa 1243 }
2a28b791 1244 pop( @begin_stack );
54310121 1245}
1246
1247#
59ecbafa 1248# process_pre - indented paragraph, made into <pre></pre>
54310121 1249#
2a28b791 1250sub process_pre {
1251 my( $text ) = @_;
1252 my( $rest );
54310121 1253 return if $ignore;
1254
54310121 1255 $rest = $$text;
1256
2a28b791 1257 # insert spaces in place of tabs
1258 $rest =~ s#.*#
be173d55 1259 my $line = $&;
1260 1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
1261 $line;
1262 #eg;
54310121 1263
2a28b791 1264 # convert some special chars to HTML escapes
59ecbafa 1265 $rest = html_escape($rest);
2a28b791 1266
1267 # try and create links for all occurrences of perl.* within
1268 # the preformatted text.
1269 $rest =~ s{
1270 (\s*)(perl\w+)
1271 }{
1272 if ( defined $pages{$2} ){ # is a link
59ecbafa 1273 qq($1<a href="$htmlroot/$pages{$2}">$2</a>);
2a28b791 1274 } elsif (defined $pages{dosify($2)}) { # is a link
59ecbafa 1275 qq($1<a href="$htmlroot/$pages{dosify($2)}">$2</a>);
2a28b791 1276 } else {
1277 "$1$2";
1278 }
1279 }xeg;
1280 $rest =~ s{
59ecbafa 1281 (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
2a28b791 1282 }{
1283 my $url ;
1284 if ( $htmlfileurl ne '' ){
59ecbafa 1285 # Here, we take advantage of the knowledge
2a28b791 1286 # that $htmlfileurl ne '' implies $htmlroot eq ''.
1287 # Since $htmlroot eq '', we need to prepend $htmldir
1288 # on the fron of the link to get the absolute path
1289 # of the link's target. We check for a leading '/'
1290 # to avoid corrupting links that are #, file:, etc.
1291 my $old_url = $3 ;
1292 $old_url = "$htmldir$old_url" if $old_url =~ m{^\/};
1293 $url = relativize_url( "$old_url.html", $htmlfileurl );
1294 } else {
1295 $url = "$3.html" ;
1296 }
1297 "$1$url" ;
1298 }xeg;
1299
1300 # Look for embedded URLs and make them into links. We don't
1301 # relativize them since they are best left as the author intended.
1302
1303 my $urls = '(' . join ('|', qw{
54310121 1304 http
1305 telnet
1306 mailto
1307 news
1308 gopher
1309 file
1310 wais
1311 ftp
59ecbafa 1312 } )
54310121 1313 . ')';
59ecbafa 1314
2a28b791 1315 my $ltrs = '\w';
1316 my $gunk = '/#~:.?+=&%@!\-';
add5afb0 1317 my $punc = '.:!?\-;';
2a28b791 1318 my $any = "${ltrs}${gunk}${punc}";
54310121 1319
2a28b791 1320 $rest =~ s{
54310121 1321 \b # start at word boundary
1322 ( # begin $1 {
29f227c9 1323 $urls : # need resource and a colon
1324 (?!:) # Ignore File::, among others.
add5afb0 1325 [$any] +? # followed by one or more of any valid
1326 # character, but be conservative and
1327 # take only what you need to....
54310121 1328 ) # end $1 }
1329 (?= # look-ahead non-consumptive assertion
add5afb0 1330 [$punc]* # either 0 or more punctuation
1331 (?: # followed
1332 [^$any] # by a non-url char
1333 | # or
1334 $ # end of the string
1335 ) #
54310121 1336 | # or else
1337 $ # then end of the string
1338 )
59ecbafa 1339 }{<a href="$1">$1</a>}igox;
54310121 1340
2a28b791 1341 # text should be as it is (verbatim)
1342 $$text = $rest;
1343}
54310121 1344
54310121 1345
2a28b791 1346#
1347# pure text processing
1348#
1349# pure_text/inIS_text: differ with respect to automatic C<> recognition.
1350# we don't want this to happen within IS
1351#
1352sub pure_text($){
1353 my $text = shift();
1354 process_puretext( $text, \$ptQuote, 1 );
54310121 1355}
1356
2a28b791 1357sub inIS_text($){
1358 my $text = shift();
1359 process_puretext( $text, \$ptQuote, 0 );
1360}
54310121 1361
1362#
1363# process_puretext - process pure text (without pod-escapes) converting
1364# double-quotes and handling implicit C<> links.
1365#
1366sub process_puretext {
2a28b791 1367 my($text, $quote, $notinIS) = @_;
54310121 1368
2a28b791 1369 ## Guessing at func() or [$@%&]*var references in plain text is destined
1370 ## to produce some strange looking ref's. uncomment to disable:
1371 ## $notinIS = 0;
1372
1373 my(@words, $lead, $trail);
54310121 1374
2a28b791 1375 # convert double-quotes to single-quotes
1376 if( $$quote && $text =~ s/"/''/s ){
1377 $$quote = 0;
1378 }
1379 while ($text =~ s/"([^"]*)"/``$1''/sg) {};
1380 $$quote = 1 if $text =~ s/"/``/s;
54310121 1381
1382 # keep track of leading and trailing white-space
2a28b791 1383 $lead = ($text =~ s/\A(\s+)//s ? $1 : "");
1384 $trail = ($text =~ s/(\s+)\Z//s ? $1 : "");
54310121 1385
2a28b791 1386 # split at space/non-space boundaries
1387 @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text );
54310121 1388
1389 # process each word individually
1390 foreach my $word (@words) {
2a28b791 1391 # skip space runs
1392 next if $word =~ /^\s*$/;
54310121 1393 # see if we can infer a link
02369fa5 1394 if( $notinIS && $word =~ /^(\w+)\((.*)\)$/ ) {
54310121 1395 # has parenthesis so should have been a C<> ref
2a28b791 1396 ## try for a pagename (perlXXX(1))?
02369fa5 1397 my( $func, $args ) = ( $1, $2 );
1398 if( $args =~ /^\d+$/ ){
2a28b791 1399 my $url = page_sect( $word, '' );
1400 if( defined $url ){
59ecbafa 1401 $word = "<a href=\"$url\">the $word manpage</a>";
2a28b791 1402 next;
1403 }
1404 }
02369fa5 1405 ## try function name for a link, append tt'ed argument list
1406 $word = emit_C( $func, '', "($args)");
2a28b791 1407
1408#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing.
1409## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) {
1410## # perl variables, should be a C<> ref
1411## $word = emit_C( $word );
1412
54310121 1413 } elsif ($word =~ m,^\w+://\w,) {
1414 # looks like a URL
5a039dd3 1415 # Don't relativize it: leave it as the author intended
59ecbafa 1416 $word = qq(<a href="$word">$word</a>);
af47ee55 1417 } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
54310121 1418 # looks like an e-mail address
7b8d334a 1419 my ($w1, $w2, $w3) = ("", $word, "");
1420 ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
1421 ($w1, $w2, $w3) = ("&lt;", $1, "&gt;$2") if $word =~ /^<(.*?)>(,?)/;
59ecbafa 1422 $word = qq($w1<a href="mailto:$w2">$w2</a>$w3);
1423 } else {
7b8d334a 1424 $word = html_escape($word) if $word =~ /["&<>]/;
54310121 1425 }
1426 }
1427
2a28b791 1428 # put everything back together
1429 return $lead . join( '', @words ) . $trail;
1430}
1431
54310121 1432
2a28b791 1433#
1434# process_text - handles plaintext that appears in the input pod file.
1435# there may be pod commands embedded within the text so those must be
1436# converted to html commands.
1437#
7ba65c74 1438
c68ea5d1 1439sub process_text1($$;$$);
1440sub pattern ($) { $_[0] ? '[^\S\n]+'.('>' x ($_[0] + 1)) : '>' }
1441sub closing ($) { local($_) = shift; (defined && s/\s+$//) ? length : 0 }
7ba65c74 1442
2a28b791 1443sub process_text {
1444 return if $ignore;
1445 my( $tref ) = @_;
1446 my $res = process_text1( 0, $tref );
1447 $$tref = $res;
1448}
1449
c68ea5d1 1450sub process_text1($$;$$){
1451 my( $lev, $rstr, $func, $closing ) = @_;
2a28b791 1452 my $res = '';
1453
60a48b2d 1454 unless (defined $func) {
1455 $func = '';
1456 $lev++;
1457 }
1458
2a28b791 1459 if( $func eq 'B' ){
1460 # B<text> - boldface
59ecbafa 1461 $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>';
2a28b791 1462
1463 } elsif( $func eq 'C' ){
59ecbafa 1464 # C<code> - can be a ref or <code></code>
2a28b791 1465 # need to extract text
c68ea5d1 1466 my $par = go_ahead( $rstr, 'C', $closing );
2a28b791 1467
1468 ## clean-up of the link target
1469 my $text = depod( $par );
1470
1471 ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ;
59ecbafa 1472 ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n";
2a28b791 1473
1474 $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
1475
1476 } elsif( $func eq 'E' ){
1477 # E<x> - convert to character
be3174d2 1478 $$rstr =~ s/^([^>]*)>//;
1479 my $escape = $1;
1480 $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i;
1481 $res = "&$escape;";
2a28b791 1482
1483 } elsif( $func eq 'F' ){
1484 # F<filename> - italizice
59ecbafa 1485 $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
2a28b791 1486
1487 } elsif( $func eq 'I' ){
1488 # I<text> - italizice
59ecbafa 1489 $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
2a28b791 1490
1491 } elsif( $func eq 'L' ){
1492 # L<link> - link
59ecbafa 1493 ## L<text|cross-ref> => produce text, use cross-ref for linking
2a28b791 1494 ## L<cross-ref> => make text from cross-ref
1495 ## need to extract text
c68ea5d1 1496 my $par = go_ahead( $rstr, 'L', $closing );
2a28b791 1497
1498 # some L<>'s that shouldn't be:
1499 # a) full-blown URL's are emitted as-is
1500 if( $par =~ m{^\w+://}s ){
1501 return make_URL_href( $par );
1502 }
1503 # b) C<...> is stripped and treated as C<>
1504 if( $par =~ /^C<(.*)>$/ ){
1505 my $text = depod( $1 );
1506 return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
1507 }
1508
1509 # analyze the contents
1510 $par =~ s/\n/ /g; # undo word-wrapped tags
1511 my $opar = $par;
1512 my $linktext;
1513 if( $par =~ s{^([^|]+)\|}{} ){
1514 $linktext = $1;
1515 }
59ecbafa 1516
2a28b791 1517 # make sure sections start with a /
1518 $par =~ s{^"}{/"};
1519
1520 my( $page, $section, $ident );
1521
1522 # check for link patterns
1523 if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident
59ecbafa 1524 # we've got a name/ident (no quotes)
2a28b791 1525 ( $page, $ident ) = ( $1, $2 );
1526 ### print STDERR "--> L<$par> to page $page, ident $ident\n";
1527
1528 } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section"
1529 # even though this should be a "section", we go for ident first
1530 ( $page, $ident ) = ( $1, $2 );
1531 ### print STDERR "--> L<$par> to page $page, section $section\n";
1532
1533 } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes
1534 ( $page, $section ) = ( '', $par );
1535 ### print STDERR "--> L<$par> to void page, section $section\n";
1536
1537 } else {
1538 ( $page, $section ) = ( $par, '' );
1539 ### print STDERR "--> L<$par> to page $par, void section\n";
1540 }
1541
1542 # now, either $section or $ident is defined. the convoluted logic
1543 # below tries to resolve L<> according to what the user specified.
1544 # failing this, we try to find the next best thing...
1545 my( $url, $ltext, $fid );
1546
1547 RESOLVE: {
1548 if( defined $ident ){
1549 ## try to resolve $ident as an item
1550 ( $url, $fid ) = coderef( $page, $ident );
1551 if( $url ){
1552 if( ! defined( $linktext ) ){
1553 $linktext = $ident;
1554 $linktext .= " in " if $ident && $page;
1555 $linktext .= "the $page manpage" if $page;
1556 }
1557 ### print STDERR "got coderef url=$url\n";
1558 last RESOLVE;
1559 }
1560 ## no luck: go for a section (auto-quoting!)
1561 $section = $ident;
1562 }
1563 ## now go for a section
1564 my $htmlsection = htmlify( $section );
1565 $url = page_sect( $page, $htmlsection );
1566 if( $url ){
1567 if( ! defined( $linktext ) ){
1568 $linktext = $section;
1569 $linktext .= " in " if $section && $page;
1570 $linktext .= "the $page manpage" if $page;
1571 }
1572 ### print STDERR "got page/section url=$url\n";
1573 last RESOLVE;
1574 }
59ecbafa 1575 ## no luck: go for an ident
2a28b791 1576 if( $section ){
1577 $ident = $section;
1578 } else {
1579 $ident = $page;
1580 $page = undef();
1581 }
1582 ( $url, $fid ) = coderef( $page, $ident );
1583 if( $url ){
1584 if( ! defined( $linktext ) ){
1585 $linktext = $ident;
1586 $linktext .= " in " if $ident && $page;
1587 $linktext .= "the $page manpage" if $page;
1588 }
1589 ### print STDERR "got section=>coderef url=$url\n";
1590 last RESOLVE;
1591 }
1592
1593 # warning; show some text.
1594 $linktext = $opar unless defined $linktext;
f8f99792 1595 warn "$0: $podfile: cannot resolve L<$opar> in paragraph $paragraph.\n";
2a28b791 1596 }
1597
d1be9408 1598 # now we have a URL or just plain code
2a28b791 1599 $$rstr = $linktext . '>' . $$rstr;
1600 if( defined( $url ) ){
59ecbafa 1601 $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>';
2a28b791 1602 } else {
59ecbafa 1603 $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
2a28b791 1604 }
1605
1606 } elsif( $func eq 'S' ){
1607 # S<text> - non-breaking spaces
1608 $res = process_text1( $lev, $rstr );
1609 $res =~ s/ /&nbsp;/g;
1610
1611 } elsif( $func eq 'X' ){
1612 # X<> - ignore
1613 $$rstr =~ s/^[^>]*>//;
1614
1615 } elsif( $func eq 'Z' ){
59ecbafa 1616 # Z<> - empty
f8f99792 1617 warn "$0: $podfile: invalid X<> in paragraph $paragraph.\n"
2a28b791 1618 unless $$rstr =~ s/^>//;
1619
1620 } else {
c68ea5d1 1621 my $term = pattern $closing;
1622 while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
2a28b791 1623 # all others: either recurse into new function or
c68ea5d1 1624 # terminate at closing angle bracket(s)
2a28b791 1625 my $pt = $1;
c68ea5d1 1626 $pt .= $2 if !$3 && $lev == 1;
2a28b791 1627 $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
c68ea5d1 1628 return $res if !$3 && $lev > 1;
1629 if( $3 ){
1630 $res .= process_text1( $lev, $rstr, $3, closing $4 );
1631 }
2a28b791 1632 }
1633 if( $lev == 1 ){
1634 $res .= pure_text( $$rstr );
54310121 1635 } else {
f8f99792 1636 warn "$0: $podfile: undelimited $func<> in paragraph $paragraph.\n";
54310121 1637 }
1638 }
2a28b791 1639 return $res;
1640}
54310121 1641
2a28b791 1642#
1643# go_ahead: extract text of an IS (can be nested)
1644#
c68ea5d1 1645sub go_ahead($$$){
1646 my( $rstr, $func, $closing ) = @_;
2a28b791 1647 my $res = '';
c68ea5d1 1648 my @closing = ($closing);
1649 while( $$rstr =~
1650 s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|@{[pattern $closing[0]]})//s ){
2a28b791 1651 $res .= $1;
c68ea5d1 1652 unless( $3 ){
1653 shift @closing;
1654 return $res unless @closing;
2a28b791 1655 } else {
c68ea5d1 1656 unshift @closing, closing $4;
2a28b791 1657 }
1658 $res .= $2;
1659 }
f8f99792 1660 warn "$0: $podfile: undelimited $func<> in paragraph $paragraph.\n";
2a28b791 1661 return $res;
54310121 1662}
1663
1664#
2a28b791 1665# emit_C - output result of C<text>
1666# $text is the depod-ed text
54310121 1667#
02369fa5 1668sub emit_C($;$$){
1669 my( $text, $nocode, $args ) = @_;
60a48b2d 1670 $args = '' unless defined $args;
2a28b791 1671 my $res;
1672 my( $url, $fid ) = coderef( undef(), $text );
1673
1674 # need HTML-safe text
02369fa5 1675 my $linktext = html_escape( "$text$args" );
2a28b791 1676
1677 if( defined( $url ) &&
1678 (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){
59ecbafa 1679 $res = "<a href=\"$url\"><code>$linktext</code></a>";
2a28b791 1680 } elsif( 0 && $nocode ){
1681 $res = $linktext;
1682 } else {
59ecbafa 1683 $res = "<code>$linktext</code>";
2a28b791 1684 }
1685 return $res;
54310121 1686}
1687
1688#
2a28b791 1689# html_escape: make text safe for HTML
1690#
1691sub html_escape {
1692 my $rest = $_[0];
1693 $rest =~ s/&/&amp;/g;
1694 $rest =~ s/</&lt;/g;
1695 $rest =~ s/>/&gt;/g;
1696 $rest =~ s/"/&quot;/g;
59ecbafa 1697 $rest =~ s/'/&apos;/g;
2a28b791 1698 return $rest;
59ecbafa 1699}
2a28b791 1700
1701
1702#
39e571d4 1703# dosify - convert filenames to 8.3
1704#
1705sub dosify {
1706 my($str) = @_;
fe4c6be1 1707 return lc($str) if $^O eq 'VMS'; # VMS just needs casing
39e571d4 1708 if ($Is83) {
1709 $str = lc $str;
1710 $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
1711 $str =~ s/(\w+)/substr ($1,0,8)/ge;
1712 }
1713 return $str;
1714}
1715
1716#
d1be9408 1717# page_sect - make a URL from the text of a L<>
54310121 1718#
2a28b791 1719sub page_sect($$) {
1720 my( $page, $section ) = @_;
1721 my( $linktext, $page83, $link); # work strings
1722
1723 # check if we know that this is a section in this page
1724 if (!defined $pages{$page} && defined $sections{$page}) {
1725 $section = $page;
1726 $page = "";
1727 ### print STDERR "reset page='', section=$section\n";
54310121 1728 }
1729
39e571d4 1730 $page83=dosify($page);
1731 $page=$page83 if (defined $pages{$page83});
54310121 1732 if ($page eq "") {
0d396dd4 1733 $link = "#" . anchorify( $section );
350ccacd 1734 } elsif ( $page =~ /::/ ) {
350ccacd 1735 $page =~ s,::,/,g;
29f227c9 1736 # Search page cache for an entry keyed under the html page name,
1737 # then look to see what directory that page might be in. NOTE:
1738 # this will only find one page. A better solution might be to produce
1739 # an intermediate page that is an index to all such pages.
1740 my $page_name = $page ;
fe6f1558 1741 $page_name =~ s,^.*/,,s ;
59ecbafa 1742 if ( defined( $pages{ $page_name } ) &&
1743 $pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
29f227c9 1744 ) {
1745 $page = $1 ;
1746 }
1747 else {
1748 # NOTE: This branch assumes that all A::B pages are located in
1749 # $htmlroot/A/B.html . This is often incorrect, since they are
1750 # often in $htmlroot/lib/A/B.html or such like. Perhaps we could
1751 # analyze the contents of %pages and figure out where any
1752 # cousins of A::B are, then assume that. So, if A::B isn't found,
1753 # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
1754 # lib/A/B.pm. This is also limited, but it's an improvement.
1755 # Maybe a hints file so that the links point to the correct places
2a28b791 1756 # nonetheless?
1757
29f227c9 1758 }
350ccacd 1759 $link = "$htmlroot/$page.html";
0d396dd4 1760 $link .= "#" . anchorify( $section ) if ($section);
54310121 1761 } elsif (!defined $pages{$page}) {
54310121 1762 $link = "";
54310121 1763 } else {
0d396dd4 1764 $section = anchorify( $section ) if $section ne "";
2a28b791 1765 ### print STDERR "...section=$section\n";
54310121 1766
1767 # if there is a directory by the name of the page, then assume that an
1768 # appropriate section will exist in the subdirectory
29f227c9 1769# if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
1770 if ($section ne "" && $pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
54310121 1771 $link = "$htmlroot/$1/$section.html";
2a28b791 1772 ### print STDERR "...link=$link\n";
54310121 1773
1774 # since there is no directory by the name of the page, the section will
1775 # have to exist within a .html of the same name. thus, make sure there
1776 # is a .pod or .pm that might become that .html
1777 } else {
2a28b791 1778 $section = "#$section" if $section;
1779 ### print STDERR "...section=$section\n";
1780
54310121 1781 # check if there is a .pod with the page name
1782 if ($pages{$page} =~ /([^:]*)\.pod:/) {
1783 $link = "$htmlroot/$1.html$section";
1784 } elsif ($pages{$page} =~ /([^:]*)\.pm:/) {
1785 $link = "$htmlroot/$1.html$section";
1786 } else {
54310121 1787 $link = "";
54310121 1788 }
1789 }
1790 }
1791
54310121 1792 if ($link) {
29f227c9 1793 # Here, we take advantage of the knowledge that $htmlfileurl ne ''
1794 # implies $htmlroot eq ''. This means that the link in question
1795 # needs a prefix of $htmldir if it begins with '/'. The test for
1796 # the initial '/' is done to avoid '#'-only links, and to allow
1797 # for other kinds of links, like file:, ftp:, etc.
1798 my $url ;
1799 if ( $htmlfileurl ne '' ) {
fe6f1558 1800 $link = "$htmldir$link" if $link =~ m{^/}s;
2a28b791 1801 $url = relativize_url( $link, $htmlfileurl );
1802# print( " b: [$link,$htmlfileurl,$url]\n" );
29f227c9 1803 }
1804 else {
1805 $url = $link ;
1806 }
2a28b791 1807 return $url;
29f227c9 1808
54310121 1809 } else {
2a28b791 1810 return undef();
54310121 1811 }
54310121 1812}
1813
1814#
29f227c9 1815# relativize_url - convert an absolute URL to one relative to a base URL.
1816# Assumes both end in a filename.
1817#
1818sub relativize_url {
1819 my ($dest,$source) = @_ ;
1820
59ecbafa 1821 my ($dest_volume,$dest_directory,$dest_file) =
29f227c9 1822 File::Spec::Unix->splitpath( $dest ) ;
1823 $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
1824
59ecbafa 1825 my ($source_volume,$source_directory,$source_file) =
29f227c9 1826 File::Spec::Unix->splitpath( $source ) ;
1827 $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
1828
1829 my $rel_path = '' ;
1830 if ( $dest ne '' ) {
1831 $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
1832 }
1833
59ecbafa 1834 if ( $rel_path ne '' &&
29f227c9 1835 substr( $rel_path, -1 ) ne '/' &&
59ecbafa 1836 substr( $dest_file, 0, 1 ) ne '#'
29f227c9 1837 ) {
1838 $rel_path .= "/$dest_file" ;
1839 }
1840 else {
1841 $rel_path .= "$dest_file" ;
1842 }
1843
1844 return $rel_path ;
1845}
1846
54310121 1847
1848#
2a28b791 1849# coderef - make URL from the text of a C<>
54310121 1850#
2a28b791 1851sub coderef($$){
1852 my( $page, $item ) = @_;
1853 my( $url );
1854
1855 my $fid = fragment_id( $item );
2a28b791 1856 if( defined( $page ) ){
1857 # we have been given a $page...
1858 $page =~ s{::}{/}g;
1859
1860 # Do we take it? Item could be a section!
228a48a5 1861 my $base = $items{$fid} || "";
2a28b791 1862 $base =~ s{[^/]*/}{};
1863 if( $base ne "$page.html" ){
1864 ### print STDERR "coderef( $page, $item ): items{$fid} = $items{$fid} = $base => discard page!\n";
1865 $page = undef();
1866 }
54310121 1867
2a28b791 1868 } else {
1869 # no page - local items precede cached items
67398a75 1870 if( defined( $fid ) ){
1871 if( exists $local_items{$fid} ){
1872 $page = $local_items{$fid};
1873 } else {
1874 $page = $items{$fid};
1875 }
2a28b791 1876 }
1877 }
54310121 1878
1879 # if there was a pod file that we found earlier with an appropriate
1880 # =item directive, then create a link to that page.
2a28b791 1881 if( defined $page ){
1882 if( $page ){
228a48a5 1883 if( exists $pages{$page} and $pages{$page} =~ /([^:.]*)\.[^:]*:/){
2a28b791 1884 $page = $1 . '.html';
29f227c9 1885 }
2a28b791 1886 my $link = "$htmlroot/$page#item_$fid";
54310121 1887
2a28b791 1888 # Here, we take advantage of the knowledge that $htmlfileurl
1889 # ne '' implies $htmlroot eq ''.
1890 if ( $htmlfileurl ne '' ) {
1891 $link = "$htmldir$link" ;
1892 $url = relativize_url( $link, $htmlfileurl ) ;
1893 } else {
1894 $url = $link ;
1895 }
1896 } else {
1897 $url = "#item_" . $fid;
1898 }
54310121 1899
2a28b791 1900 confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/;
59ecbafa 1901 }
2a28b791 1902 return( $url, $fid );
54310121 1903}
1904
54310121 1905
1906
1907#
29f227c9 1908# Adapted from Nick Ing-Simmons' PodToHtml package.
1909sub relative_url {
1910 my $source_file = shift ;
1911 my $destination_file = shift;
1912
1913 my $source = URI::file->new_abs($source_file);
1914 my $uo = URI::file->new($destination_file,$source)->abs;
1915 return $uo->rel->as_string;
1916}
1917
1918
1919#
54310121 1920# finish_list - finish off any pending HTML lists. this should be called
1921# after the entire pod file has been read and converted.
1922#
1923sub finish_list {
7b8d334a 1924 while ($listlevel > 0) {
59ecbafa 1925 print HTML "</dl>\n";
54310121 1926 $listlevel--;
1927 }
1928}
1929
1930#
1931# htmlify - converts a pod section specification to a suitable section
2a28b791 1932# specification for HTML. Note that we keep spaces and special characters
1933# except ", ? (Netscape problem) and the hyphen (writer's problem...).
54310121 1934#
1935sub htmlify {
2a28b791 1936 my( $heading) = @_;
1937 $heading =~ s/(\s+)/ /g;
1938 $heading =~ s/\s+\Z//;
1939 $heading =~ s/\A\s+//;
1940 # The hyphen is a disgrace to the English language.
1941 $heading =~ s/[-"?]//g;
1942 $heading = lc( $heading );
1943 return $heading;
1944}
54310121 1945
2a28b791 1946#
0d396dd4 1947# similar to htmlify, but turns spaces into underscores
1948#
1949sub anchorify {
1950 my ($anchor) = @_;
1951 $anchor = htmlify($anchor);
1952 $anchor =~ s/\s/_/g; # fixup spaces left by htmlify
1953 return $anchor;
1954}
1955
1956#
2a28b791 1957# depod - convert text by eliminating all interior sequences
1958# Note: can be called with copy or modify semantics
1959#
1960my %E2c;
67398a75 1961$E2c{lt} = '<';
1962$E2c{gt} = '>';
1963$E2c{sol} = '/';
2a28b791 1964$E2c{verbar} = '|';
67398a75 1965$E2c{amp} = '&'; # in Tk's pods
2a28b791 1966
c68ea5d1 1967sub depod1($;$$);
7ba65c74 1968
2a28b791 1969sub depod($){
1970 my $string;
1971 if( ref( $_[0] ) ){
1972 $string = ${$_[0]};
1973 ${$_[0]} = depod1( \$string );
1974 } else {
1975 $string = $_[0];
1976 depod1( \$string );
59ecbafa 1977 }
2a28b791 1978}
54310121 1979
c68ea5d1 1980sub depod1($;$$){
1981 my( $rstr, $func, $closing ) = @_;
2a28b791 1982 my $res = '';
228a48a5 1983 return $res unless defined $$rstr;
2a28b791 1984 if( ! defined( $func ) ){
1985 # skip to next begin of an interior sequence
c68ea5d1 1986 while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?// ){
2a28b791 1987 # recurse into its text
c68ea5d1 1988 $res .= $1 . depod1( $rstr, $2, closing $3);
2a28b791 1989 }
1990 $res .= $$rstr;
1991 } elsif( $func eq 'E' ){
1992 # E<x> - convert to character
be3174d2 1993 $$rstr =~ s/^([^>]*)>//;
228a48a5 1994 $res .= $E2c{$1} || "";
2a28b791 1995 } elsif( $func eq 'X' ){
1996 # X<> - ignore
1997 $$rstr =~ s/^[^>]*>//;
1998 } elsif( $func eq 'Z' ){
59ecbafa 1999 # Z<> - empty
2a28b791 2000 $$rstr =~ s/^>//;
2001 } else {
2002 # all others: either recurse into new function or
2003 # terminate at closing angle bracket
c68ea5d1 2004 my $term = pattern $closing;
2005 while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)// ){
2a28b791 2006 $res .= $1;
c68ea5d1 2007 last unless $3;
2008 $res .= depod1( $rstr, $3, closing $4 );
2a28b791 2009 }
2010 ## If we're here and $2 ne '>': undelimited interior sequence.
2011 ## Ignored, as this is called without proper indication of where we are.
2012 ## Rely on process_text to produce diagnostics.
2013 }
2014 return $res;
2015}
54310121 2016
2a28b791 2017#
2018# fragment_id - construct a fragment identifier from:
2019# a) =item text
2020# b) contents of C<...>
2021#
2022my @hc;
2023sub fragment_id {
2024 my $text = shift();
2025 $text =~ s/\s+\Z//s;
2026 if( $text ){
2027 # a method or function?
2028 return $1 if $text =~ /(\w+)\s*\(/;
2029 return $1 if $text =~ /->\s*(\w+)\s*\(?/;
2030
2031 # a variable name?
2032 return $1 if $text =~ /^([$@%*]\S+)/;
2033
2034 # some pattern matching operator?
2035 return $1 if $text =~ m|^(\w+/).*/\w*$|;
2036
2037 # fancy stuff... like "do { }"
2038 return $1 if $text =~ m|^(\w+)\s*{.*}$|;
2039
2040 # honour the perlfunc manpage: func [PAR[,[ ]PAR]...]
2041 # and some funnies with ... Module ...
2042 return $1 if $text =~ m{^([a-z\d]+)(\s+[A-Z\d,/& ]+)?$};
2043 return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
2044
2045 # text? normalize!
2046 $text =~ s/\s+/_/sg;
2047 $text =~ s{(\W)}{
2048 defined( $hc[ord($1)] ) ? $hc[ord($1)]
2049 : ( $hc[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe;
2050 $text = substr( $text, 0, 50 );
2051 } else {
2052 return undef();
2053 }
54310121 2054}
2055
2a28b791 2056#
2057# make_URL_href - generate HTML href from URL
2058# Special treatment for CGI queries.
2059#
2060sub make_URL_href($){
2061 my( $url ) = @_;
59ecbafa 2062 if( $url !~
2063 s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){
2064 $url = "<a href=\"$url\">$url</a>";
2a28b791 2065 }
2066 return $url;
54310121 2067}
2068
20691;