winhtml.pm

ARM上的如果你对底层感兴趣

    $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
    $podroot  = $opt_podroot if defined $opt_podroot;

    $doindex  = $opt_index if defined $opt_index;
    $recurse  = $opt_recurse if defined $opt_recurse;
    $title    = $opt_title if defined $opt_title;
    $verbose  = defined $opt_verbose ? 1 : 0;
    $netscape = $opt_netscape if defined $opt_netscape;
}


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.
		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)$/ && ! -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);

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

		    # use the names of files as =item directives too.
		    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);

		    scan_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$/) {	    	    	    	    # .pod
	    s/\.pod$//;
	    $pages{$_}  = "" unless defined $pages{$_};
	    $pages{$_} .= "$dir/$_.pod:";
	    push(@pods, "$dir/$_.pod");
	} elsif (/\.pm$/) { 	    	    	    	    # .pm
	    s/\.pm$//;
	    $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, $title, $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, $title) = ($1,$2,$3);
		    chomp($title);
		    $$sections{htmlify(0,$title)} = 1;

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

			# DTG *** Added </LI> after the </A> to close the list item
		    $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
		              "<A HREF=\"#" . htmlify(0,$title) . "\">" .
			      process_text(\$title, 0) . "</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($pod, @poddata) = @_;
    my($i, $item);
    local $_;

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

    foreach $i (0..$#poddata) {
		$_ = $poddata[$i];

		# remove any formatting instructions
		s,[A-Z]<([^<>]*)>,$1,g;

		# figure out what kind of item it is and get the first word of
		#  it's name.
		if (/^=item\s+(\w*)\s*.*$/s) {
		    if ($1 eq "*") {		# bullet list
				/\A=item\s+\*\s*(.*?)\s*\Z/s;
				$item = $1;
		    } elsif ($1 =~ /^[0-9]+/) {	# numbered list
				/\A=item\s+[0-9]+\.?(.*?)\s*\Z/s;
				$item = $1;
		    } else {
		#		/\A=item\s+(.*?)\s*\Z/s;
				/\A=item\s+(\w*)/s;
				$item = $1;
		    }

		    $items{$item} = "$pod" if $item;
		}
    }
}

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

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

    # can't have a heading full of spaces and speechmarks and so on
    $firstword = $heading; $firstword =~ s/\s*(\w+)\s.*/$1/;

    #print HTML "<P>\n" unless $listlevel;
    print HTML "<HR>\n" unless $listlevel || $top;
    print HTML "<H$level>"; # unless $listlevel;
    #print HTML "<H$level>" unless $listlevel;
    my $convert = $heading; process_text(\$convert, 0);
    print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>";
    print HTML "</H$level>"; # unless $listlevel;
    print HTML "\n";
}

#
# process_item - convert a pod item tag and convert it to HTML format.
#
sub process_item {
    my $text = $_[0];
    my($i, $quote, $name);

    my $need_preamble = 0;
    my $this_entry;


    # lots of documents start a list without doing an =over.  this is
    # bad!  but, the proper thing to do seems to be to just assume
    # they did do an =over.  so warn them once and then continue.
    warn "$0: $podfile: unexpected =item directive in paragraph $paragraph.  ignoring.\n"
		unless $listlevel;
    process_over() unless $listlevel;

    return unless $listlevel;

    # remove formatting instructions from the text
    1 while $text =~ s/[A-Z]<([^<>]*)>/$1/g;
    pre_escape(\$text);

    $need_preamble = $items_seen[$listlevel]++ == 0;

    # check if this is the first =item after an =over
    $i = $listlevel - 1;
    my $need_new = $listlevel >= @listitem;

    if ($text =~ /\A\*/) {		# bullet

	if ($need_preamble) {
	    push(@listend,  "</UL>");
	    print HTML "<UL>\n";
	}

       print HTML "<LI><STRONG>";
       $text =~ /\A\*\s*(.*)\Z/s;
       print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++;
       $quote = 1;
       #print HTML process_puretext($1, \$quote);
       print HTML $1;
       print HTML "</A>" if $1;
       print HTML "</STRONG>";

    } elsif ($text =~ /\A[0-9#]+/) {	# numbered list

	if ($need_preamble) {
	    push(@listend,  "</OL>");
	    print HTML "<OL>\n";
	}

       print HTML "<LI><STRONG>";
       $text =~ /\A[0-9]+\.?(.*)\Z/s;
       print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1;
       $quote = 1;
       #print HTML process_puretext($1, \$quote);
       print HTML $1 if $1;
       print HTML "</A>" if $1;
       print HTML "</STRONG>";

    } else {			# all others

	if ($need_preamble) {
	    push(@listend,  '</DL>');
	    print HTML "<DL>\n";
	}

       print HTML "<DT><STRONG>";
       print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">" 
	    if $text && !$items_named{($text =~ /(\S+)/)[0]}++;
	    # preceding craziness so that the duplicate leading bits in 
	    # perlfunc work to find just the first one.  otherwise
	    # open etc would have many names
       $quote = 1;
       #print HTML process_puretext($text, \$quote);
       print HTML $text;
       print HTML "</A>" if $text;
       print HTML "</STRONG>";

       print HTML '<DD>';
    }

    print HTML "\n";
}

#
# process_over - process a pod over tag and start a corresponding HTML
# list.
#
sub process_over {
    # start a new list
    $listlevel++;
}

#
# process_back - process a pod back tag and convert it to HTML format.
#
sub process_back {
    warn "$0: $podfile: unexpected =back directive in paragraph $paragraph.  ignoring.\n"
	unless $listlevel;
    return unless $listlevel;

    # close off the list.  note, I check to see if $listend[$listlevel] is
    # defined because an =item directive may have never appeared and thus
    # $listend[$listlevel] may have never been initialized.
    $listlevel--;
    print HTML $listend[$listlevel] if defined $listend[$listlevel];
    print HTML "\n";

    # don't need the corresponding perl code anymore
    pop(@listitem);
    pop(@listdata);
    pop(@listend);

    pop(@items_seen);
}

#
# process_cut - process a pod cut tag, thus stop ignoring pod directives.
#
sub process_cut {
    $ignore = 1;
}

#
# process_pod - process a pod pod tag, thus ignore pod directives until we see a
# corresponding cut.
#
sub process_pod {
    # no need to set $ignore to 0 cause the main loop did it
}

#
# process_for - process a =for pod tag.  if it's for html, split
# it out verbatim, otherwise ignore it.
#
sub process_for {
    my($whom, $text) = @_;
    if ( $whom =~ /^(pod2)?html$/i) {
		print HTML $text;
    } 
}

#
# process_begin - process a =begin pod tag.  this pushes