winhtml.pm

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

# whom we're beginning on the begin stack.  if there's a
# begin stack, we only print if it us.
#
sub process_begin {
    my($whom, $text) = @_;
    $whom = lc($whom);
    push (@begin_stack, $whom);
    if ( $whom =~ /^(pod2)?html$/) {
	print HTML $text if $text;
    }
}

#
# process_end - process a =end pod tag.  pop the
# begin stack.  die if we're mismatched.
#
sub process_end {
    my($whom, $text) = @_;
    $whom = lc($whom);
    if ($begin_stack[-1] ne $whom ) {
		die "Unmatched begin/end at chunk $paragraph\n"
    } 
    pop @begin_stack;
}

#
# process_text - handles plaintext that appears in the input pod file.
# there may be pod commands embedded within the text so those must be
# converted to html commands.
#
sub process_text {
    my($text, $escapeQuotes) = @_;
    my($result, $rest, $s1, $s2, $s3, $s4, $match, $bf);
    my($podcommand, $params, $tag, $quote);

    return if $ignore;

    $quote  = 0;    	    	# status of double-quote conversion
    $result = "";
    $rest = $$text;

    if ($rest =~ /^\s+/) {	# preformatted text, no pod directives
	$rest =~ s/\n+\Z//;
	$rest =~ s#.*#
	    my $line = $&;
	    1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
	    $line;
	#eg;

	$rest   =~ s/&/&/g;
	$rest   =~ s/</&lt;/g;
	$rest   =~ s/>/&gt;/g;
	$rest   =~ s/"/&quot;/g;

	# try and create links for all occurrences of perl.* within
	# the preformatted text.
	$rest =~ s{
		    (\s*)(perl\w+)
		  }{
		    if (defined $pages{$2}) {	# is a link
			qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>);
		    } else {
			"$1$2";
		    }
		  }xeg;
	$rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g;

	my $urls = '(' . join ('|', qw{
                http
                telnet
		mailto
		news
                gopher
                file
                wais
                ftp
            } ) 
        . ')';
  
  my $ltrs = '\w';
  my $gunk = '/#~:.?+=&%@!\-';
  my $punc = '.:?\-';
  my $any  = "${ltrs}${gunk}${punc}";

  $rest =~ s{
        \b                          # start at word boundary
        (                           # begin $1  {
          $urls     :               # need resource and a colon
          [$any] +?                 # followed by on or more
                                    #  of any valid character, but
                                    #  be conservative and take only
                                    #  what you need to....
        )                           # end   $1  }
        (?=                         # look-ahead non-consumptive assertion
                [$punc]*            # either 0 or more puntuation
                [^$any]             #   followed by a non-url char
            |                       # or else
                $                   #   then end of the string
        )
      }{<A HREF="$1">$1</A>}igox;

	$result =   "<PRE>"	# text should be as it is (verbatim)
		  . "$rest\n"
		  . "</PRE>\n";
    } else {			# formatted text
	# parse through the string, stopping each time we find a
	# pod-escape.  once the string has been throughly processed
	# we can output it.
	while ($rest) {
	    # check to see if there are any possible pod directives in
	    # the remaining part of the text.
	    if ($rest =~ m/[BCEIFLSZ]</) {
		warn "\$rest\t= $rest\n" unless
		    $rest =~ /\A
			   ([^<]*?)
			   ([BCEIFLSZ]?)
			   <
			   (.*)\Z/xs;

		$s1 = $1;	# pure text
		$s2 = $2;	# the type of pod-escape that follows
		$s3 = '<';	# '<'
		$s4 = $3;	# the rest of the string
	    } else {
		$s1 = $rest;
		$s2 = "";
		$s3 = "";
		$s4 = "";
	    }

	    if ($s3 eq '<' && $s2) {	# a pod-escape
		$result    .= ($escapeQuotes ? process_puretext($s1, \$quote) : $s1);
		$podcommand = "$s2<";
		$rest       = $s4;

		# find the matching '>'
		$match = 1;
		$bf = 0;
		while ($match && !$bf) {
		    $bf = 1;
		    if ($rest =~ /\A([^<>]*[BCEIFLSZ]<)(.*)\Z/s) {
			$bf = 0;
			$match++;
			$podcommand .= $1;
			$rest        = $2;
		    } elsif ($rest =~ /\A([^>]*>)(.*)\Z/s) {
			$bf = 0;
			$match--;
			$podcommand .= $1;
			$rest        = $2;
		    }
		}

		if ($match != 0) {
		    warn <<WARN;
$0: $podfile: cannot find matching > for $s2 in paragraph $paragraph.
WARN
		    $result .= substr $podcommand, 0, 2;
		    $rest = substr($podcommand, 2) . $rest;
		    next;
		}

		# pull out the parameters to the pod-escape
		$podcommand =~ /^([BCFEILSZ]?)<(.*)>$/s;
		$tag    = $1;
		$params = $2;

		# process the text within the pod-escape so that any escapes
		# which must occur do.
		process_text(\$params, 0) unless $tag eq 'L';

		$s1 = $params;
		if (!$tag || $tag eq " ") {	#  <> : no tag
		    $s1 = "&lt;$params&gt;";
		} elsif ($tag eq "L") {		# L<> : link 
		    $s1 = process_L($params);
		} elsif ($tag eq "I" ||		# I<> : italicize text
			 $tag eq "B" ||		# B<> : bold text
			 $tag eq "F") {		# F<> : file specification
		    $s1 = process_BFI($tag, $params);
		} elsif ($tag eq "C") {		# C<> : literal code
		    $s1 = process_C($params, 1);
		} elsif ($tag eq "E") {		# E<> : escape
		    $s1 = process_E($params);
		} elsif ($tag eq "Z") {		# Z<> : zero-width character
		    $s1 = process_Z($params);
		} elsif ($tag eq "S") {		# S<> : non-breaking space
		    $s1 = process_S($params);
		} elsif ($tag eq "X") {		# S<> : non-breaking space
		    $s1 = process_X($params);
		} else {
		    warn "$0: $podfile: unhandled tag '$tag' in paragraph $paragraph\n";
		}

		$result .= "$s1";
	    } else {
		# for pure text we must deal with implicit links and
		# double-quotes among other things.
		$result .= ($escapeQuotes ? process_puretext("$s1$s2$s3", \$quote) : "$s1$s2$s3");
		$rest    = $s4;
	    }
	}
    }
    $$text = $result;
}

sub html_escape {
    my $rest = $_[0];
    $rest   =~ s/&/&amp;/g;
    $rest   =~ s/</&lt;/g;
    $rest   =~ s/>/&gt;/g;
    $rest   =~ s/"/&quot;/g;
    return $rest;
} 

#
# process_puretext - process pure text (without pod-escapes) converting
#  double-quotes and handling implicit C<> links.
#
sub process_puretext {
    my($text, $quote) = @_;
    my(@words, $result, $rest, $lead, $trail);

    # convert double-quotes to single-quotes
    $text =~ s/\A([^"]*)"/$1''/s if $$quote;
    while ($text =~ s/\A([^"]*)["]([^"]*)["]/$1``$2''/sg) {}

    $$quote = ($text =~ m/"/ ? 1 : 0);
    $text =~ s/\A([^"]*)"/$1``/s if $$quote;

    # keep track of leading and trailing white-space
    $lead  = ($text =~ /\A(\s*)/s ? $1 : "");
    $trail = ($text =~ /(\s*)\Z/s ? $1 : "");

    # collapse all white space into a single space
    $text =~ s/\s+/ /g;
    @words = split(" ", $text);

    # process each word individually
    foreach my $word (@words) {
	# see if we can infer a link
	if ($word =~ /^\w+\(/) {
	    # has parenthesis so should have been a C<> ref
	    $word = process_C($word);
#	    $word =~ /^[^()]*]\(/;
#	    if (defined $items{$1} && $items{$1}) {
#		$word =   "\n<CODE><A HREF=\"$htmlroot/$items{$1}#item_"
#			. htmlify(0,$word)
#			. "\">$word</A></CODE>";
#	    } elsif (defined $items{$word} && $items{$word}) {
#		$word =   "\n<CODE><A HREF=\"$htmlroot/$items{$word}#item_"
#			. htmlify(0,$word)
#			. "\">$word</A></CODE>";
#	    } else {
#		$word =   "\n<CODE><A HREF=\"#item_"
#			. htmlify(0,$word)
#			. "\">$word</A></CODE>";
#	    }
	} elsif ($word =~ /^[\$\@%&*]+\w+$/) {
	    # perl variables, should be a C<> ref
	    $word = process_C($word, 1);
	} elsif ($word =~ m,^\w+://\w,) {
	    # looks like a URL
	    $word = qq(<A HREF="$word">$word</A>);
	} elsif ($word =~ /[\w.-]+\@\w+\.\w/) {
	    # looks like an e-mail address
	    $word = qq(<A HREF="MAILTO:$word">$word</A>);
	} elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) {  # all uppercase?
	    $word = html_escape($word) if $word =~ /[&<>]/;
	    $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape;
	} else { 
	    $word = html_escape($word) if $word =~ /[&<>]/;
	}
    }

    # build a new string based upon our conversion
    $result = "";
    $rest   = join(" ", @words);
    while (length($rest) > 75) {
	if ( $rest =~ m/^(.{0,75})\s(.*?)$/o ||
	     $rest =~ m/^(\S*)\s(.*?)$/o) {

	    $result .= "$1\n";
	    $rest    = $2;
	} else {
	    $result .= "$rest\n";
	    $rest    = "";
	}
    }
    $result .= $rest if $rest;

    # restore the leading and trailing white-space
    $result = "$lead$result$trail";

    return $result;
}

#
# pre_escape - convert & in text to $amp;
#
sub pre_escape {
    my($str) = @_;

    $$str =~ s,&,&amp;,g;
}

#
# process_L - convert a pod L<> directive to a corresponding HTML link.
#  most of the links made are inferred rather than known about directly
#  (i.e it's not known whether the =head\d section exists in the target file,
#   or whether a .pod file exists in the case of split files).  however, the
#  guessing usually works.
#
# Unlike the other directives, this should be called with an unprocessed
# string, else tags in the link won't be matched.
#
sub process_L {
    my($str) = @_;
    my($s1, $s2, $linktext, $page, $section, $link);	# work strings

    $str =~ s/\n/ /g;			# undo word-wrapped tags
    $s1 = $str;
    for ($s1) {
	# a :: acts like a /
	s,::,/,;

	# make sure sections start with a /
	s,^",/",g;
	s,^,/,g if (!m,/, && / /);

	# check if there's a section specified
	if (m,^(.*?)/"?(.*?)"?$,) {	# yes
	    ($page, $section) = ($1, $2);
	} else {			# no
	    ($page, $section) = ($str, "");
	}

	# check if we know that this is a section in this page
	if (!defined $pages{$page} && defined $sections{$page}) {
	    $section = $page;
	    $page = "";
	}
    }

    if ($page eq "") {
	$link = "#" . htmlify(0,$section);
	$linktext = $section;
    } elsif (!defined $pages{$page}) {
#	warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n";
	$link = "";
	$linktext = $page;
    } else {
	$linktext  = ($section ? "$section" : "the $page manpage");
	$section = htmlify(0,$section) if $section ne "";

	# if there is a directory by the name of the page, then assume that an
	# appropriate section will exist in the subdirectory
	if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
	    $link = "$htmlroot/$1/$section.html";

	# since there is no directory by the name of the page, the section will
	# have to exist within a .html of the same name.  thus, make sure there
	# is a .pod or .pm that might become that .html
	} else {
	    $section = "#$section";
	    # check if there is a .pod with the page name
	    if ($pages{$page} =~ /([^:]*)\.pod:/) {
		$link = "$htmlroot/$1.html$section";
	    } elsif ($pages{$page} =~ /([^:]*)\.pm:/) {
		$link = "$htmlroot/$1.html$section";
	    } else {
		warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ".
			     "no .pod or .pm found\n";
		$link = "";
		$linktext = $section;
	    }
	}
    }

    process_text(\$linktext, 0);
    if ($link) {
	$s1 = "<A HREF=\"$link\">$linktext</A>";
    } else {
	$s1 = "<EM>$linktext</EM>";
    }
    return $s1;
}

#
# process_BFI - process any of the B<>, F<>, or I<> pod-escapes and
# convert them to corresponding HTML directives.
#
sub process_BFI {
    my($tag, $str) = @_;
    my($s1);			# work string
    my(%repltext) = (	'B' => 'STRONG',
			'F' => 'EM',
			'I' => 'EM');

    # extract the modified text and convert to HTML
    $s1 = "<$repltext{$tag}>$str</$repltext{$tag}>";
    return $s1;
}

#
# process_C - process the C<> pod-escape.
#
sub process_C {
    my($str, $doref) = @_;
    my($s1, $s2);

    $s1 = $str;
    $s1 =~ s/\([^()]*\)//g;	# delete parentheses
    $s2 = $s1;
    $s1 =~ s/\W//g;		# delete bogus characters

    # if there was a pod file that we found earlier with an appropriate
    # =item directive, then create a link to that page.
    if ($doref && defined $items{$s1}) {
	$s1 = ($items{$s1} ?
	       "<A HREF=\"$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) .  "\">$str</A>" :
	       "<A HREF=\"#item_" . htmlify(0,$s2) .  "\">$str</A>");
	$s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,; 
	confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/;
    } else {
	$s1 = "<CODE>$str</CODE>";
	# warn "$0: $podfile: cannot resolve C<$str> in paragraph $paragraph\n" if $verbose
    }


    return $s1;
}

#
# process_E - process the E<> pod directive which seems to escape a character.
#
sub process_E {
    my($str) = @_;

    for ($str) {
	s,([^/].*),\&$1\;,g;
    }

    return $str;
}

#
# process_Z - process the Z<> pod directive which really just amounts to
# ignoring it.  this allows someone to start a paragraph with an =
#
sub process_Z {
    my($str) = @_;

    # there is no equivalent in HTML for this so just ignore it.
    $str = "";
    return $str;
}

#
# process_S - process the S<> pod directive which means to convert all
# spaces in the string to non-breaking spaces (in HTML-eze).
#
sub process_S {
    my($str) = @_;

    # convert all spaces in the text to non-breaking spaces in HTML.
    $str =~ s/ /&nbsp;/g;
    return $str;
}

#
# process_X - this is supposed to make an index entry.  we'll just 
# ignore it.
#
sub process_X {
    return '';
}


#
# finish_list - finish off any pending HTML lists.  this should be called
# after the entire pod file has been read and converted.
#
sub finish_list {
    while ($listlevel >= 0) {
	print HTML "</DL>\n";
	$listlevel--;
    }
}

#
# htmlify - converts a pod section specification to a suitable section
# specification for HTML.  if first arg is 1, only takes 1st word.
#
sub htmlify {
    my($compact, $heading) = @_;

    if ($compact) {
      $heading =~ /^(\w+)/;
      $heading = $1;
    } 

  # $heading = lc($heading);
  $heading =~ s/[^\w\s]/_/g;
  $heading =~ s/(\s+)/ /g;
  $heading =~ s/^\s*(.*?)\s*$/$1/s;
  $heading =~ s/ /_/g;
  $heading =~ s/\A(.{32}).*\Z/$1/s;
  $heading =~ s/\s+\Z//;
  $heading =~ s/_{2,}/_/g;

  return $heading;
}

BEGIN {
}

1;