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