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