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