root/lang/perl/Pod-L10N/trunk/lib/Pod/L10N/Html.pm @ 33798

Revision 33798, 60.3 kB (checked in by argrath, 6 years ago)

Checking in changes prior to tagging of version 0.04. Changelog diff is:

Index: Changes
===================================================================
--- Changes (リビジョン 33792)
+++ Changes (作業コピー)
@@ -1,5 +1,9 @@

Revision history for Perl extension Pod::L10N.


+0.04 Thu Jun 5 18:53:26 JST 2009
+
+ - add pod
+

0.03_02 Thu Jun 5 00:57:10 JST 2009


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