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