html.pm

UNIX下perl实现代码

			my $all = 2;
			foreach my $line ( @lines ){
			    if( $line =~ /\S/ && $line !~ /\t/ ){
				$all--;
				last if $all == 0;
			    }
			}
			if( $all > 0 ){
			    $text =~ s/\t+/<TD>/g;
			    $text =~ s/^/<TR><TD>/gm;
			    $text = '<TABLE CELLSPACING=0 CELLPADDING=0>' .
                                    $text . '</TABLE>';
			}
		    }
		}
		## end of experimental

		if( $after_item ){
		    print HTML "$text\n";
		    $after_lpar = 1;
		} else {
		    print HTML "<P>$text</P>\n";
		}
	    }
	    $after_item = 0;
	}
    }

    # finish off any pending directives
    finish_list();

    # link to page index
    print HTML "<P><A HREF=\"#__index__\"><SMALL>$backlink</SMALL></A></P>\n"
	if $doindex and $index and $backlink;

    print HTML <<END_OF_TAIL;
$block
</BODY>

</HTML>
END_OF_TAIL

    # close the html file
    close(HTML);

    warn "Finished\n" if $verbose;
}

##############################################################################

my $usage;			# see below
sub usage {
    my $podfile = shift;
    warn "$0: $podfile: @_\n" if @_;
    die $usage;
}

$usage =<<END_OF_USAGE;
Usage:  $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
           --podpath=<name>:...:<name> --podroot=<name>
           --libpods=<name>:...:<name> --recurse --verbose --index
           --netscape --norecurse --noindex

  --backlink     - set text for "back to top" links (default: none).
  --css          - stylesheet URL
  --flush        - flushes the item and directory caches.
  --[no]header   - produce block header/footer (default is no headers).
  --help         - prints this message.
  --htmldir      - directory for resulting HTML files.
  --htmlroot     - http-server base directory from which all relative paths
                   in podpath stem (default is /).
  --[no]index    - generate an index at the top of the resulting html
                   (default behaviour).
  --infile       - filename for the pod to convert (input taken from stdin
                   by default).
  --libpods      - colon-separated list of pages to search for =item pod
                   directives in as targets of C<> and implicit links (empty
                   by default).  note, these are not filenames, but rather
                   page names like those that appear in L<> links.
  --[no]netscape - will use netscape html directives when applicable.
                   (default is not to use them).
  --outfile      - filename for the resulting html file (output sent to
                   stdout by default).
  --podpath      - colon-separated list of directories containing library
                   pods (empty by default).
  --podroot      - filesystem base directory from which all relative paths
                   in podpath stem (default is .).
  --[no]quiet    - supress some benign warning messages (default is off).
  --[no]recurse  - recurse on those subdirectories listed in podpath
                   (default behaviour).
  --title        - title that will appear in resulting html file.
  --[no]verbose  - self-explanatory (off by default).

END_OF_USAGE

sub parse_command_line {
    my ($opt_backlink,$opt_css,$opt_flush,$opt_header,$opt_help,$opt_htmldir,
	$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,
	$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,$opt_recurse,
	$opt_title,$opt_verbose);

    unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
    my $result = GetOptions(
			    'backlink=s' => \$opt_backlink,
			    'css=s'      => \$opt_css,
			    'flush'      => \$opt_flush,
			    'header!'    => \$opt_header,
			    'help'       => \$opt_help,
			    'htmldir=s'  => \$opt_htmldir,
			    'htmlroot=s' => \$opt_htmlroot,
			    'index!'     => \$opt_index,
			    'infile=s'   => \$opt_infile,
			    'libpods=s'  => \$opt_libpods,
			    'netscape!'  => \$opt_netscape,
			    'outfile=s'  => \$opt_outfile,
			    'podpath=s'  => \$opt_podpath,
			    'podroot=s'  => \$opt_podroot,
			    'quiet!'     => \$opt_quiet,
			    'recurse!'   => \$opt_recurse,
			    'title=s'    => \$opt_title,
			    'verbose!'   => \$opt_verbose,
			   );
    usage("-", "invalid parameters") if not $result;

    usage("-") if defined $opt_help;	# see if the user asked for help
    $opt_help = "";			# just to make -w shut-up.

    @podpath  = split(":", $opt_podpath) if defined $opt_podpath;
    @libpods  = split(":", $opt_libpods) if defined $opt_libpods;

    $backlink = $opt_backlink if defined $opt_backlink;
    $css      = $opt_css      if defined $opt_css;
    $header   = $opt_header   if defined $opt_header;
    $htmldir  = $opt_htmldir  if defined $opt_htmldir;
    $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
    $doindex  = $opt_index    if defined $opt_index;
    $podfile  = $opt_infile   if defined $opt_infile;
    $netscape = $opt_netscape if defined $opt_netscape;
    $htmlfile = $opt_outfile  if defined $opt_outfile;
    $podroot  = $opt_podroot  if defined $opt_podroot;
    $quiet    = $opt_quiet    if defined $opt_quiet;
    $recurse  = $opt_recurse  if defined $opt_recurse;
    $title    = $opt_title    if defined $opt_title;
    $verbose  = $opt_verbose  if defined $opt_verbose;

    warn "Flushing item and directory caches\n"
	if $opt_verbose && defined $opt_flush;
    unlink($dircache, $itemcache) if defined $opt_flush;
}


my $saved_cache_key;

sub get_cache {
    my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
    my @cache_key_args = @_;

    # A first-level cache:
    # Don't bother reading the cache files if they still apply
    # and haven't changed since we last read them.

    my $this_cache_key = cache_key(@cache_key_args);

    return if $saved_cache_key and $this_cache_key eq $saved_cache_key;

    # load the cache of %pages and %items if possible.  $tests will be
    # non-zero if successful.
    my $tests = 0;
    if (-f $dircache && -f $itemcache) {
	warn "scanning for item cache\n" if $verbose;
	$tests = load_cache($dircache, $itemcache, $podpath, $podroot);
    }

    # if we didn't succeed in loading the cache then we must (re)build
    #  %pages and %items.
    if (!$tests) {
	warn "scanning directories in pod-path\n" if $verbose;
	scan_podpath($podroot, $recurse, 0);
    }
    $saved_cache_key = cache_key(@cache_key_args);
}

sub cache_key {
    my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
    return join('!', $dircache, $itemcache, $recurse,
	@$podpath, $podroot, stat($dircache), stat($itemcache));
}

#
# load_cache - tries to find if the caches stored in $dircache and $itemcache
#  are valid caches of %pages and %items.  if they are valid then it loads
#  them and returns a non-zero value.
#
sub load_cache {
    my($dircache, $itemcache, $podpath, $podroot) = @_;
    my($tests);
    local $_;

    $tests = 0;

    open(CACHE, "<$itemcache") ||
	die "$0: error opening $itemcache for reading: $!\n";
    $/ = "\n";

    # is it the same podpath?
    $_ = <CACHE>;
    chomp($_);
    $tests++ if (join(":", @$podpath) eq $_);

    # is it the same podroot?
    $_ = <CACHE>;
    chomp($_);
    $tests++ if ($podroot eq $_);

    # load the cache if its good
    if ($tests != 2) {
	close(CACHE);
	return 0;
    }

    warn "loading item cache\n" if $verbose;
    while (<CACHE>) {
	/(.*?) (.*)$/;
	$items{$1} = $2;
    }
    close(CACHE);

    warn "scanning for directory cache\n" if $verbose;
    open(CACHE, "<$dircache") ||
	die "$0: error opening $dircache for reading: $!\n";
    $/ = "\n";
    $tests = 0;

    # is it the same podpath?
    $_ = <CACHE>;
    chomp($_);
    $tests++ if (join(":", @$podpath) eq $_);

    # is it the same podroot?
    $_ = <CACHE>;
    chomp($_);
    $tests++ if ($podroot eq $_);

    # load the cache if its good
    if ($tests != 2) {
	close(CACHE);
	return 0;
    }

    warn "loading directory cache\n" if $verbose;
    while (<CACHE>) {
	/(.*?) (.*)$/;
	$pages{$1} = $2;
    }

    close(CACHE);

    return 1;
}

#
# scan_podpath - scans the directories specified in @podpath for directories,
#  .pod files, and .pm files.  it also scans the pod files specified in
#  @libpods for =item directives.
#
sub scan_podpath {
    my($podroot, $recurse, $append) = @_;
    my($pwd, $dir);
    my($libpod, $dirname, $pod, @files, @poddata);

    unless($append) {
	%items = ();
	%pages = ();
    }

    # scan each directory listed in @podpath
    $pwd = getcwd();
    chdir($podroot)
	|| die "$0: error changing to directory $podroot: $!\n";
    foreach $dir (@podpath) {
	scan_dir($dir, $recurse);
    }

    # scan the pods listed in @libpods for =item directives
    foreach $libpod (@libpods) {
	# if the page isn't defined then we won't know where to find it
	# on the system.
	next unless defined $pages{$libpod} && $pages{$libpod};

	# if there is a directory then use the .pod and .pm files within it.
	# NOTE: Only finds the first so-named directory in the tree.
#	if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
	if ($pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
	    #  find all the .pod and .pm files within the directory
	    $dirname = $1;
	    opendir(DIR, $dirname) ||
		die "$0: error opening directory $dirname: $!\n";
	    @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
	    closedir(DIR);

	    # scan each .pod and .pm file for =item directives
	    foreach $pod (@files) {
		open(POD, "<$dirname/$pod") ||
		    die "$0: error opening $dirname/$pod for input: $!\n";
		@poddata = <POD>;
		close(POD);
		clean_data( \@poddata );

		scan_items( \%items, "$dirname/$pod", @poddata);
	    }

	    # use the names of files as =item directives too.
### Don't think this should be done this way - confuses issues.(WL)
###	    foreach $pod (@files) {
###		$pod =~ /^(.*)(\.pod|\.pm)$/;
###		$items{$1} = "$dirname/$1.html" if $1;
###	    }
	} elsif ($pages{$libpod} =~ /([^:]*\.pod):/ ||
		 $pages{$libpod} =~ /([^:]*\.pm):/) {
	    # scan the .pod or .pm file for =item directives
	    $pod = $1;
	    open(POD, "<$pod") ||
		die "$0: error opening $pod for input: $!\n";
	    @poddata = <POD>;
	    close(POD);
	    clean_data( \@poddata );

	    scan_items( \%items, "$pod", @poddata);
	} else {
	    warn "$0: shouldn't be here (line ".__LINE__."\n";
	}
    }
    @poddata = ();	# clean-up a bit

    chdir($pwd)
	|| die "$0: error changing to directory $pwd: $!\n";

    # cache the item list for later use
    warn "caching items for later use\n" if $verbose;
    open(CACHE, ">$itemcache") ||
	die "$0: error open $itemcache for writing: $!\n";

    print CACHE join(":", @podpath) . "\n$podroot\n";
    foreach my $key (keys %items) {
	print CACHE "$key $items{$key}\n";
    }

    close(CACHE);

    # cache the directory list for later use
    warn "caching directories for later use\n" if $verbose;
    open(CACHE, ">$dircache") ||
	die "$0: error open $dircache for writing: $!\n";

    print CACHE join(":", @podpath) . "\n$podroot\n";
    foreach my $key (keys %pages) {
	print CACHE "$key $pages{$key}\n";
    }

    close(CACHE);
}

#
# scan_dir - scans the directory specified in $dir for subdirectories, .pod
#  files, and .pm files.  notes those that it finds.  this information will
#  be used later in order to figure out where the pages specified in L<>
#  links are on the filesystem.
#
sub scan_dir {
    my($dir, $recurse) = @_;
    my($t, @subdirs, @pods, $pod, $dirname, @dirs);
    local $_;

    @subdirs = ();
    @pods = ();

    opendir(DIR, $dir) ||
	die "$0: error opening directory $dir: $!\n";
    while (defined($_ = readdir(DIR))) {
	if (-d "$dir/$_" && $_ ne "." && $_ ne "..") {	    # directory
	    $pages{$_}  = "" unless defined $pages{$_};
	    $pages{$_} .= "$dir/$_:";
	    push(@subdirs, $_);
	} elsif (/\.pod\z/) {	    	    	    	    # .pod
	    s/\.pod\z//;
	    $pages{$_}  = "" unless defined $pages{$_};
	    $pages{$_} .= "$dir/$_.pod:";
	    push(@pods, "$dir/$_.pod");
	} elsif (/\.html\z/) { 	    	    	    	    # .html
	    s/\.html\z//;
	    $pages{$_}  = "" unless defined $pages{$_};
	    $pages{$_} .= "$dir/$_.pod:";
	} elsif (/\.pm\z/) { 	    	    	    	    # .pm
	    s/\.pm\z//;
	    $pages{$_}  = "" unless defined $pages{$_};
	    $pages{$_} .= "$dir/$_.pm:";
	    push(@pods, "$dir/$_.pm");
	}
    }
    closedir(DIR);

    # recurse on the subdirectories if necessary
    if ($recurse) {
	foreach my $subdir (@subdirs) {
	    scan_dir("$dir/$subdir", $recurse);
	}
    }
}

#
# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
#  build an index.
#
sub scan_headings {
    my($sections, @data) = @_;
    my($tag, $which_head, $otitle, $listdepth, $index);

    # here we need	local $ignore = 0;
    #  unfortunately, we can't have it, because $ignore is lexical
    $ignore = 0;

    $listdepth = 0;
    $index = "";

    # scan for =head directives, note their name, and build an index
    #  pointing to each of them.
    foreach my $line (@data) {
	if ($line =~ /^=(head)([1-6])\s+(.*)/) {
	    ($tag, $which_head, $otitle) = ($1,$2,$3);

            my $title = depod( $otitle );
            my $name = htmlify( $title );
	    $$sections{$name} = 1;
	    $title = process_text( \$otitle );

	    while ($which_head != $listdepth) {
		if ($which_head > $listdepth) {
		    $index .= "\n" . ("\t" x $listdepth) . "<UL>\n";
		    $listdepth++;
		} elsif ($which_head < $listdepth) {
		    $listdepth--;
		    $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
		}
	    }

	    $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
	              "<A HREF=\"#" . $name . "\">" .
		      $title . "</A></LI>";
	}
    }

    # finish off the lists
    while ($listdepth--) {
	$index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
    }

    # get rid of bogus lists
    $index =~ s,\t*<UL>\s*</UL>\n,,g;

    $ignore = 1;	# restore old value;

    return $index;
}

#
# scan_items - scans the pod specified by $pod for =item directives.  we
#  will use this information later on in resolving C<> links.
#
sub scan_items {
    my( $itemref, $pod, @poddata ) = @_;
    my($i, $item);
    local $_;

    $pod =~ s/\.pod\z//;
    $pod .= ".html" if $pod;

    foreach $i (0..$#poddata) {
	my $txt = depod( $poddata[$i] );

	# figure out what kind of item it is.
	# Build string for referencing this item.
	if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bullet
	    next unless $1;
	    $item = $1;
        } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
	    $item = $1;
	} elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # plain item
	    $item = $1;
	} else {
	    next;
	}
	my $fid = fragment_id( $item );
	$$itemref{$fid} = "$pod" if $fid;
    }
}

#
# process_head - convert a pod head[1-6] tag and convert it to HTML format.
#
sub process_head {
    my($tag, $heading, $hasindex) = @_;

    # figure out the level of the =head
    $tag =~ /head([1-6])/;
    my $level = $1;

    if( $listlevel ){