[perl5.git] / pod / pod2html.PL

#!/usr/local/bin/perl

use Config;
use File::Basename qw(&basename &dirname);

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
chdir(dirname($0));
($file = basename($0)) =~ s/\.PL$//;
$file =~ s/\.pl$//
	if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"

open OUT,">$file" or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

print OUT <<"!GROK!THIS!";
$Config{startperl}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	if \$running_under_some_shell;
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

print OUT <<'!NO!SUBS!';

#
# pod2html - convert pod format to html
# Version 1.15
# usage: pod2html [podfiles]
# Will read the cwd and parse all files with .pod extension
# if no arguments are given on the command line.
#
# Many helps, suggestions, and fixes from the perl5 porters, and all over.
# Bill Middleton - wjm@metronet.com
#
# Please send patches/fixes/features to me
#
#
# 
*RS = */;
*ERRNO = *!;

################################################################################
# Invoke with various levels of debugging possible
################################################################################
while ($ARGV[0] =~ /^-d(.*)/) {
    shift;
    $Debug{ lc($1 || shift) }++;
}

# ck for podnames on command line
while ($ARGV[0]) {
    push(@Pods,shift);
}

################################################################################
# CONFIGURE
#
# The beginning of the url for the anchors to the other sections.
# Edit $type to suit.  It's configured for relative url's now.
# Other possibilities are:
# $type = '<A HREF="file://localhost/usr/local/htmldir/'; # file url
# $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server
#
################################################################################

$type = '<A HREF="';		
$dir = ".";             # location of pods

# look in these pods for things not found within the current pod
# be careful tho, namespace collisions cause stupid links

@inclusions = qw[
     perlfunc perlvar perlrun perlop 
];
################################################################################
# END CONFIGURE
################################################################################

$A = {};  # The beginning of all things

unless (@Pods) {
    opendir(DIR,$dir)  or  die "Can't opendir $dir: $ERRNO";
    @Pods = grep(/\.pod$/,readdir(DIR));
    closedir(DIR) or die "Can't closedir $dir: $ERRNO";
}
@Pods or die "aak, expected pods";

# loop twice through the pods, first to learn the links, then to produce html
for $count (0,1) {
    print STDERR "Scanning pods...\n" unless $count;
    foreach $podfh ( @Pods ) {
	($pod = $podfh) =~ s/\.(?:pod|pm)$//;
	Debug("files", "opening 2 $podfh" );
	print "Creating $pod.html from $podfh\n" if $count;
	$RS = "\n=";         # grok pods by item (Nonstandard but effecient)
	open($podfh,"<".$podfh)  || die "can't open $podfh: $ERRNO";
	@all = <$podfh>;
	close($podfh);
	$RS = "\n";

	$all[0] =~ s/^=//;
	for (@all) { s/=$// }
	$Podnames{$pod} = 1;
	$in_list = 0;
	$html = $pod.".html";
	if ($count) {              # give us a html and rcs header
	    open(HTML,">$html") || die "can't create $html: $ERRNO";
	    print HTML '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n";
	    print HTML "<CENTER>" unless $NO_NS;
	    print HTML "<TITLE>$pod</TITLE>";
	    print HTML "</CENTER>" unless $NO_NS;
	    print HTML "\n</HEAD>\n<BODY>";
	}
	for ($i = 0; $i <= $#all; $i++) {       # decide what to do with each chunk
	    $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ;
	    ($cmd, $title, $rest) = ($1,$2,$3);
	    if ($cmd eq "item") {
		if ($count ) { # producing html
		    do_list("over",$all[$i],\$in_list,\$depth) unless $depth;
		    do_item($title,$rest,$in_list);
		}
		else {  
		    # scan item
		    scan_thing("item",$title,$pod);
		}
	    }
	    elsif ($cmd =~ /^head([12])/) {
		$num = $1;
		if ($count) { # producing html
		    do_hdr($num,$title,$rest,$depth);
		}
		else {
		    # header scan
		    scan_thing($cmd,$title,$pod); # skip head1
		}
	    }
	    elsif ($cmd =~ /^over/) {
		$count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth);
	    }
	    elsif ($cmd =~ /^back/) {
		if ($count) {  # producing html
		    ($depth) or next; # just skip it
		    do_list("back",$all[$i+1],\$in_list,\$depth);
		    do_rest($title.$rest);
		}
	    }
	    elsif ($cmd =~ /^cut/) {
		next;
	    }
            elsif ($cmd =~ /^for/) {  # experimental pragma html
                if ($count) {  # producing html
                    if ($title =~ s/^html//) {
                        $in_html =1;
                        do_rest($title.$rest);
                    }
                }
            }
            elsif ($cmd =~ /^begin/) {  # experimental pragma html
                if ($count) {  # producing html
                    if ($title =~ s/^html//) {
                        print HTML $title,"\n",$rest;
                    }
                    elsif ($title =~ /^end/) {
                        next;
                    }
                }
            }
	    elsif ($Debug{"misc"}) { 
		warn("unrecognized header: $cmd");
	    }
	}
        # close open lists without '=back' stmts
	if ($count) {  # producing html
	    while ($depth) {
		 do_list("back",$all[$i+1],\$in_list,\$depth);
	    }
	    print HTML "\n</BODY>\n</HTML>\n";
	}
    }
}

sub do_list{   # setup a list type, depending on some grok logic
    my($which,$next_one,$list_type,$depth) = @_;
    my($key);
    if ($which eq "over") {
	unless ($next_one =~ /^item\s+(.*)/) {
	    warn "Bad list, $1\n" if $Debug{"misc"};
	}
	$key = $1;

	if      ($key =~ /^1\.?/) {
	    $$list_type = "OL";
	} elsif ($key =~ /\*\s*$/) {
	    $$list_type = "UL";
	} elsif ($key =~ /\*?\s*\w/) {
	    $$list_type = "DL";
	} else {
	    warn "unknown list type for item $key" if $Debug{"misc"};
	}

	print HTML qq{\n};
	print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>};
	$$depth++;
    }
    elsif ($which eq "back") {
	print HTML qq{\n</$$list_type>\n};
	$$depth--;
    }
}

sub do_hdr{   # headers
    my($num,$title,$rest,$depth) = @_;
    print HTML qq{<p><hr>\n} if $num == 1;
    process_thing(\$title,"NAME");
    print HTML qq{\n<H$num> };
    print HTML $title; 
    print HTML qq{</H$num>\n};
    do_rest($rest);
}

sub do_item{  # list items
    my($title,$rest,$list_type) = @_;
    my $bullet_only = $title eq '*' and $list_type eq 'UL';
    process_thing(\$title,"NAME");
    if ($list_type eq "DL") {
	print HTML qq{\n<DT><STRONG>\n};
	print HTML $title; 
	print HTML qq{\n</STRONG>\n};
	print HTML qq{<DD>\n};
    }
    else {
	print HTML qq{\n<LI>};
	unless ($bullet_only or $list_type eq "OL") {
	    print HTML $title,"\n";
	}
    }
    do_rest($rest);
}

sub do_rest{   # the rest of the chunk handled here
    my($rest) = @_;
    my(@lines,$p,$q,$line,,@paras,$inpre);
    @paras = split(/\n\n\n*/,$rest);  
    for ($p = 0; $p <= $#paras; $p++) {
	$paras[$p] =~ s/^\n//mg;
	@lines = split(/\n/,$paras[$p]);
        if ($in_html) {  # handle =for html paragraphs
            print HTML $paras[0];
            $in_html = 0;
            next;
        }
	elsif ($lines[0] =~ /^\s+\w*\t.*/) {  # listing or unordered list
	    print HTML qq{<UL>};
	    foreach $line (@lines) { 
		($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
		print HTML defined($Podnames{$key}) 
				?  "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n" 
				: "<LI>$line</LI>\n";
	    }
	    print HTML qq{</UL>\n};
	}
	elsif ($lines[0] =~ /^\s/) {       # preformatted code
	    if ($paras[$p] =~/>>|<</) {
		print HTML qq{\n<PRE>\n};
		$inpre=1;
	    }
	    else {                         # Still cant beat XMP.  Yes, I know 
		print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions?
		$inpre = 0;
	    }
	    while (defined($paras[$p])) {
	        @lines = split(/\n/,$paras[$p]);
		foreach $q (@lines) {      # mind your p's and q's here :-)
		    if ($paras[$p] =~ />>|<</) {
			if ($inpre) {
			    process_thing(\$q,"HTML");
			}
			else {
			    print HTML qq{\n</XMP>\n};
			    print HTML qq{<PRE>\n};
			    $inpre=1;
			    process_thing(\$q,"HTML");
			}
		    }
		    1 while $q =~  s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
		    print HTML  $q,"\n";
		}
		last if $paras[$p+1] !~ /^\s/;
		$p++;
	    }
	    print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
	}
	else {                             # other text
	    @lines = split(/\n/,$paras[$p]);
	    foreach $line (@lines) {
                process_thing(\$line,"HTML");
		print HTML qq{$line\n};
	    }
	}
	print HTML qq{<p>};
    }
}

sub process_thing{       # process a chunk, order important
    my($thing,$htype) = @_;
    pre_escapes($thing);
    find_refs($thing,$htype);
    post_escapes($thing);
}

sub scan_thing{           # scan a chunk for later references
    my($cmd,$title,$pod) = @_;
    $_ = $title;
    s/\n$//;
    s/E<(\d+)>/&#$1;/g;
    s/E<(.*?)>/&$1;/g;
    # remove any formatting information for the headers
    s/[SFCBI]<(.*?)>/$1/g;         
    # the "don't format me" thing
    s/Z<>//g;
    if ($cmd eq "item") {
        /^\*/ and  return; 	# skip bullets
        /^\d+\./ and  return; 	# skip numbers
        s/(-[a-z]).*/$1/i;
	trim($_);
        return if defined $A->{$pod}->{"Items"}->{$_};
        $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_);
        $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_};
        Debug("items", "item $_");
        if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_ 
    	    && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1)) 
        {
    	    $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
    	    Debug("items", "item $1 REF TO $_");
        } 
        if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) {
    	    my $pf = $1 . '//';
    	    $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s";
    	    if ($pf ne $_) {
    	        $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
    	        Debug("items", "item $pf REF TO $_");
    	    }
	}
    }
    elsif ($cmd =~ /^head[12]/) {                
        return if defined($A->{$pod}->{"Headers"}->{$_});
        $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
        Debug("headers", "header $_");
    } 
    else {
        warn "unrecognized header: $cmd" if $Debug;
    } 
}


sub picrefs { 
    my($char, $bigkey, $lilkey,$htype) = @_;
    my($key,$ref,$podname);
    for $podname ($pod,@inclusions) {
	for $ref ( "Items", "Headers" ) {
	    if (defined $A->{$podname}->{$ref}->{$bigkey}) {
		$value = $A->{$podname}->{$ref}->{$key = $bigkey};
		Debug("subs", "bigkey is $bigkey, value is $value\n");
	    } 
	    elsif (defined $A->{$podname}->{$ref}->{$lilkey}) {
		$value = $A->{$podname}->{$ref}->{$key = $lilkey};
		return "" if $lilkey eq '';
		Debug("subs", "lilkey is $lilkey, value is $value\n");
	    } 
	} 
	if (length($key)) {
            ($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/;
	    if ($htype eq "NAME") {  
		return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
	    }
	    else {
		return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
	    }
	} 
    }
    if ($char =~ /[IF]/) {
	return "<EM>$bigkey</EM>";
    } elsif ($char =~ /C/) {
	return "<CODE>$bigkey</CODE>";
    } else {
	return "<STRONG>$bigkey</STRONG>";
    }
} 

sub find_refs { 
    my($thing,$htype) = @_;
    my($orig) = $$thing;
    # LREF: a manpage(3f) we don't know about
    for ($$thing) {
	#s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g;
        s@(\S+?://\S*[^.,;!?\s])@noremap(qq{<A HREF="$1">$1</A>})@ge;
        s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{<A HREF="MAILTO:$1">$1</A>}),gie;
	s/L<([^>]*)>/lrefs($1,$htype)/ge;
	s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
	s/(S)<([^\/]\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
	s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge;
	s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge;
    }
    if ($$thing eq $orig && $htype eq "NAME") { 
	$$thing = picrefs("I", $$thing, "", $htype);
    }

}

sub lrefs {
    my($page, $item) = split(m#/#, $_[0], 2);
    my($htype) = $_[1];
    my($podname);
    my($section) = $page =~ /\((.*)\)/;
    my $selfref;
    if ($page =~ /^[A-Z]/ && $item) {
	$selfref++;
	$item = "$page/$item";
	$page = $pod;
    }  elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
	$selfref++;
	$item = $page;
	$page = $pod;
    } 
    $item =~ s/\(\)$//;
    if (!$item) {
    	if (!defined $section && defined $Podnames{$page}) {
	    return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n";
	} else {
	    (warn "Bizarre entry $page/$item") if $Debug;
	    return "the <EM>$_[0]</EM>  manpage\n";
	} 
    } 

    if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
	$text = "<EM>$item</EM>";
	$ref = "Headers";
    } else {
	$text = "<EM>$item</EM>";
	$ref = "Items";
    } 
    for $podname ($pod, @inclusions) {
	undef $value;
	if ($ref eq "Items") {
	    if (defined($value = $A->{$podname}->{$ref}->{$item})) {
		($pod2,$num) = split(/_/,$value,2);
		return (($pod eq $pod2) && ($htype eq "NAME"))
	    	? "\n<A NAME=\"".$value."\">\n$text</A>\n"
	    	: "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
            }
        } 
	elsif ($ref eq "Headers") {
	    if (defined($value = $A->{$podname}->{$ref}->{$item})) {
		($pod2,$num) = split(/_/,$value,2);
		return (($pod eq $pod2) && ($htype eq "NAME")) 
	    	? "\n<A NAME=\"".$value."\">\n$text</A>\n"
	    	: "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
            }
	}
    }
    warn "No $ref reference for $item (@_)" if $Debug;
    return $text;
} 

sub varrefs {
    my ($var,$htype) = @_;
    for $podname ($pod,@inclusions) {
	if ($value = $A->{$podname}->{"Items"}->{$var}) {
	    ($pod2,$num) = split(/_/,$value,2);
	    Debug("vars", "way cool -- var ref on $var");
	    return (($pod eq $pod2) && ($htype eq "NAME"))  # INHERIT $_, $pod
		? "\n<A NAME=\"".$value."\">\n$var</A>\n"
		: "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
	}
    }
    Debug( "vars", "bummer, $var not a var");
    return "<STRONG>$var</STRONG>";
} 

sub gensym {
    my ($podname, $key) = @_;
    $key =~ s/\s.*//;
    ($key = lc($key)) =~ tr/a-z/_/cs;
    my $name = "${podname}_${key}_0";
    $name =~ s/__/_/g;
    while ($sawsym{$name}++) {
        $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
    }
    return $name;
} 

sub pre_escapes {  # twiddle these, and stay up late  :-)
    my($thing) = @_;
    for ($$thing) { 
    s/([\200-\377])/noremap("&".ord($1).";")/ge;
	s/"(.*?)"/``$1''/gs;
	s/&/noremap("&amp;")/ge;
	s/<</noremap("&lt;&lt;")/eg;
	s/([^ESIBLCF])</$1\&lt\;/g;
	s/E<(\d+)>/\&#$1\;/g;                     # embedded numeric special
	s/E<([^\/][^<>]*)>/\&$1\;/g;              # embedded special
    }
}
sub noremap {   # adding translator for hibit chars soon
    my $hide = $_[0];
    $hide =~ tr/\000-\177/\200-\377/;  
    $hide;
} 


sub post_escapes {
    my($thing) = @_;
    for ($$thing) {
	s/([^GM])>>/$1\&gt\;\&gt\;/g;
	s/([^D][^"MGA])>/$1\&gt\;/g;
	tr/\200-\377/\000-\177/;
    }
}

sub Debug {
    my $level = shift;
    print STDERR @_,"\n" if $Debug{$level};
} 

sub dumptable  {
    my $t = shift;
    print STDERR "TABLE DUMP $t\n";
    foreach $k (sort keys %$t) {
	printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
    } 
} 
sub trim {
    for (@_) {
        s/^\s+//;
        s/\s\n?$//;
    }
}
!NO!SUBS!

close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
Commit	Line	Data
4633a7c4 LW	1	#!/usr/local/bin/perl
	2
	3	use Config;
	4	use File::Basename qw(&basename &dirname);
	5
	6	# List explicitly here the variables you want Configure to
	7	# generate. Metaconfig only looks for shell variables, so you
	8	# have to mention them as if they were shell variables, not
	9	# %Config entries. Thus you write
	10	# $startperl
	11	# to ensure Configure will look for $Config{startperl}.
	12
	13	# This forces PL files to create target in same directory as PL file.
	14	# This is so that make depend always knows where to find PL derivatives.
	15	chdir(dirname($0));
	16	($file = basename($0)) =~ s/\.PL$//;
	17	$file =~ s/\.pl$//
f360dba1	18	if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
4633a7c4 LW	19
	20	open OUT,">$file" or die "Can't create $file: $!";
	21
	22	print "Extracting $file (with variable substitutions)\n";
	23
	24	# In this section, perl variables will be expanded during extraction.
	25	# You can use $Config{...} to use Configure variables.
	26
	27	print OUT <<"!GROK!THIS!";
5f05dabc	28	$Config{startperl}
	29	eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	30	if \$running_under_some_shell;
4633a7c4 LW	31	!GROK!THIS!
	32
	33	# In the following, perl variables are not expanded during extraction.
	34
	35	print OUT <<'!NO!SUBS!';
5f05dabc	36
4633a7c4 LW	37	#
	38	# pod2html - convert pod format to html
	39	# Version 1.15
	40	# usage: pod2html [podfiles]
	41	# Will read the cwd and parse all files with .pod extension
	42	# if no arguments are given on the command line.
	43	#
	44	# Many helps, suggestions, and fixes from the perl5 porters, and all over.
	45	# Bill Middleton - wjm@metronet.com
	46	#
	47	# Please send patches/fixes/features to me
	48	#
	49	#
	50	#
	51	RS = /;
	52	ERRNO = !;
	53
	54	################################################################################
	55	# Invoke with various levels of debugging possible
	56	################################################################################
	57	while ($ARGV[0] =~ /^-d(.*)/) {
	58	shift;
	59	$Debug{ lc($1 \|\| shift) }++;
	60	}
	61
	62	# ck for podnames on command line
	63	while ($ARGV[0]) {
	64	push(@Pods,shift);
	65	}
	66
	67	################################################################################
	68	# CONFIGURE
	69	#
	70	# The beginning of the url for the anchors to the other sections.
	71	# Edit $type to suit. It's configured for relative url's now.
	72	# Other possibilities are:
	73	# $type = '<A HREF="file://localhost/usr/local/htmldir/'; # file url
	74	# $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server
	75	#
	76	################################################################################
	77
	78	$type = '<A HREF="';
	79	$dir = "."; # location of pods
	80
	81	# look in these pods for things not found within the current pod
	82	# be careful tho, namespace collisions cause stupid links
	83
	84	@inclusions = qw[
	85	perlfunc perlvar perlrun perlop
	86	];
	87	################################################################################
	88	# END CONFIGURE
	89	################################################################################
	90
	91	$A = {}; # The beginning of all things
	92
	93	unless (@Pods) {
	94	opendir(DIR,$dir) or die "Can't opendir $dir: $ERRNO";
	95	@Pods = grep(/\.pod$/,readdir(DIR));
	96	closedir(DIR) or die "Can't closedir $dir: $ERRNO";
	97	}
	98	@Pods or die "aak, expected pods";
	99
	100	# loop twice through the pods, first to learn the links, then to produce html
101	for $count (0,1) {
347a6e91	102	print STDERR "Scanning pods...\n" unless $count;
4633a7c4	103	foreach $podfh ( @Pods ) {
347a6e91	104	($pod = $podfh) =~ s/\.(?:pod\|pm)$//;
4633a7c4 LW	105	Debug("files", "opening 2 $podfh" );
	106	print "Creating $pod.html from $podfh\n" if $count;
	107	$RS = "\n="; # grok pods by item (Nonstandard but effecient)
	108	open($podfh,"<".$podfh) \|\| die "can't open $podfh: $ERRNO";
	109	@all = <$podfh>;
	110	close($podfh);
	111	$RS = "\n";
	112
	113	$all[0] =~ s/^=//;
	114	for (@all) { s/=$// }
	115	$Podnames{$pod} = 1;
	116	$in_list = 0;
	117	$html = $pod.".html";
	118	if ($count) { # give us a html and rcs header
	119	open(HTML,">$html") \|\| die "can't create $html: $ERRNO";
	120	print HTML '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n";
	121	print HTML "<CENTER>" unless $NO_NS;
a4165598	122	print HTML "<TITLE>$pod</TITLE>";
4633a7c4	123	print HTML "</CENTER>" unless $NO_NS;
a4165598	124	print HTML "\n</HEAD>\n<BODY>";
4633a7c4 LW	125	}
	126	for ($i = 0; $i <= $#all; $i++) { # decide what to do with each chunk
	127	$all[$i] =~ /^(\w+)\s(.)\n?([^\0]*)$/ ;
	128	($cmd, $title, $rest) = ($1,$2,$3);
	129	if ($cmd eq "item") {
	130	if ($count ) { # producing html
	131	do_list("over",$all[$i],\$in_list,\$depth) unless $depth;
	132	do_item($title,$rest,$in_list);
	133	}
	134	else {
	135	# scan item
	136	scan_thing("item",$title,$pod);
	137	}
	138	}
	139	elsif ($cmd =~ /^head([12])/) {
	140	$num = $1;
	141	if ($count) { # producing html
	142	do_hdr($num,$title,$rest,$depth);
	143	}
	144	else {
	145	# header scan
	146	scan_thing($cmd,$title,$pod); # skip head1
	147	}
	148	}
	149	elsif ($cmd =~ /^over/) {
	150	$count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth);
	151	}
	152	elsif ($cmd =~ /^back/) {
	153	if ($count) { # producing html
	154	($depth) or next; # just skip it
	155	do_list("back",$all[$i+1],\$in_list,\$depth);
347a6e91	156	do_rest($title.$rest);
4633a7c4 LW	157	}
	158	}
	159	elsif ($cmd =~ /^cut/) {
	160	next;
	161	}
	162	elsif ($cmd =~ /^for/) { # experimental pragma html
	163	if ($count) { # producing html
	164	if ($title =~ s/^html//) {
	165	$in_html =1;
347a6e91	166	do_rest($title.$rest);
4633a7c4 LW	167	}
	168	}
	169	}
	170	elsif ($cmd =~ /^begin/) { # experimental pragma html
	171	if ($count) { # producing html
	172	if ($title =~ s/^html//) {
	173	print HTML $title,"\n",$rest;
	174	}
	175	elsif ($title =~ /^end/) {
	176	next;
	177	}
	178	}
	179	}
	180	elsif ($Debug{"misc"}) {
	181	warn("unrecognized header: $cmd");
	182	}
	183	}
	184	# close open lists without '=back' stmts
	185	if ($count) { # producing html
	186	while ($depth) {
	187	do_list("back",$all[$i+1],\$in_list,\$depth);
	188	}
	189	print HTML "\n</BODY>\n</HTML>\n";
	190	}
	191	}
	192	}
	193
	194	sub do_list{ # setup a list type, depending on some grok logic
	195	my($which,$next_one,$list_type,$depth) = @_;
	196	my($key);
	197	if ($which eq "over") {
	198	unless ($next_one =~ /^item\s+(.*)/) {
	199	warn "Bad list, $1\n" if $Debug{"misc"};
	200	}
	201	$key = $1;
	202
	203	if ($key =~ /^1\.?/) {
	204	$$list_type = "OL";
	205	} elsif ($key =~ /\\s$/) {
	206	$$list_type = "UL";
	207	} elsif ($key =~ /\?\s\w/) {
	208	$$list_type = "DL";
	209	} else {
	210	warn "unknown list type for item $key" if $Debug{"misc"};
	211	}
	212
	213	print HTML qq{\n};
	214	print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>};
	215	$$depth++;
	216	}
	217	elsif ($which eq "back") {
	218	print HTML qq{\n</$$list_type>\n};
	219	$$depth--;
	220	}
	221	}
	222
	223	sub do_hdr{ # headers
	224	my($num,$title,$rest,$depth) = @_;
	225	print HTML qq{<p><hr>\n} if $num == 1;
	226	process_thing(\$title,"NAME");
	227	print HTML qq{\n<H$num> };
	228	print HTML $title;
	229	print HTML qq{</H$num>\n};
	230	do_rest($rest);
231	}
232
233	sub do_item{ # list items
234	my($title,$rest,$list_type) = @_;
235	my $bullet_only = $title eq '*' and $list_type eq 'UL';
236	process_thing(\$title,"NAME");
237	if ($list_type eq "DL") {
238	print HTML qq{\n<DT><STRONG>\n};
239	print HTML $title;
240	print HTML qq{\n</STRONG>\n};
241	print HTML qq{<DD>\n};
242	}
243	else {
244	print HTML qq{\n<LI>};
245	unless ($bullet_only or $list_type eq "OL") {
246	print HTML $title,"\n";
247	}
248	}
249	do_rest($rest);
250	}
251
252	sub do_rest{ # the rest of the chunk handled here
253	my($rest) = @_;
254	my(@lines,$p,$q,$line,,@paras,$inpre);
255	@paras = split(/\n\n\n*/,$rest);
256	for ($p = 0; $p <= $#paras; $p++) {
257	$paras[$p] =~ s/^\n//mg;
258	@lines = split(/\n/,$paras[$p]);
259	if ($in_html) { # handle =for html paragraphs
260	print HTML $paras[0];
261	$in_html = 0;
262	next;
263	}
264	elsif ($lines[0] =~ /^\s+\w\t./) { # listing or unordered list
265	print HTML qq{<UL>};
266	foreach $line (@lines) {
267	($line =~ /^\s+(\w)\t(.)/) && (($key,$rem) = ($1,$2));
268	print HTML defined($Podnames{$key})
269	? "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n"
270	: "<LI>$line</LI>\n";
271	}
272	print HTML qq{</UL>\n};
273	}
274	elsif ($lines[0] =~ /^\s/) { # preformatted code
275	if ($paras[$p] =~/>>\|<</) {
276	print HTML qq{\n<PRE>\n};
277	$inpre=1;
278	}
279	else { # Still cant beat XMP. Yes, I know
280	print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions?
281	$inpre = 0;
282	}
283	while (defined($paras[$p])) {
284	@lines = split(/\n/,$paras[$p]);
285	foreach $q (@lines) { # mind your p's and q's here :-)
286	if ($paras[$p] =~ />>\|<</) {
287	if ($inpre) {
288	process_thing(\$q,"HTML");
289	}
290	else {
291	print HTML qq{\n</XMP>\n};
292	print HTML qq{<PRE>\n};
293	$inpre=1;
294	process_thing(\$q,"HTML");
295	}
296	}
297	1 while $q =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
298	print HTML $q,"\n";
299	}
300	last if $paras[$p+1] !~ /^\s/;
301	$p++;
302	}
303	print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
304	}
305	else { # other text
306	@lines = split(/\n/,$paras[$p]);
307	foreach $line (@lines) {
308	process_thing(\$line,"HTML");
309	print HTML qq{$line\n};
310	}
311	}
312	print HTML qq{<p>};
313	}
314	}
315
316	sub process_thing{ # process a chunk, order important
317	my($thing,$htype) = @_;
318	pre_escapes($thing);
319	find_refs($thing,$htype);
320	post_escapes($thing);
321	}
322
323	sub scan_thing{ # scan a chunk for later references
324	my($cmd,$title,$pod) = @_;
325	$_ = $title;
326	s/\n$//;
7f3dfc00	327	s/E<(\d+)>/&#$1;/g;
4633a7c4 LW	328	s/E<(.*?)>/&$1;/g;
	329	# remove any formatting information for the headers
	330	s/[SFCBI]<(.*?)>/$1/g;
	331	# the "don't format me" thing
	332	s/Z<>//g;
	333	if ($cmd eq "item") {
	334	/^\*/ and return; # skip bullets
	335	/^\d+\./ and return; # skip numbers
	336	s/(-[a-z]).*/$1/i;
	337	trim($_);
	338	return if defined $A->{$pod}->{"Items"}->{$_};
	339	$A->{$pod}->{"Items"}->{$_} = gensym($pod, $_);
	340	$A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_};
	341	Debug("items", "item $_");
	342	if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_
	343	&& !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1))
	344	{
	345	$A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
	346	Debug("items", "item $1 REF TO $_");
	347	}
	348	if ( m{^(tr\|y\|s\|m\|q[qwx])/.*[^/]} ) {
	349	my $pf = $1 . '//';
	350	$pf .= "/" if $1 eq "tr" \|\| $1 eq "y" \|\| $1 eq "s";
	351	if ($pf ne $_) {
	352	$A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
	353	Debug("items", "item $pf REF TO $_");
	354	}
	355	}
	356	}
	357	elsif ($cmd =~ /^head[12]/) {
	358	return if defined($A->{$pod}->{"Headers"}->{$_});
	359	$A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
	360	Debug("headers", "header $_");
	361	}
	362	else {
	363	warn "unrecognized header: $cmd" if $Debug;
	364	}
	365	}
	366
	367
	368	sub picrefs {
	369	my($char, $bigkey, $lilkey,$htype) = @_;
	370	my($key,$ref,$podname);
	371	for $podname ($pod,@inclusions) {
	372	for $ref ( "Items", "Headers" ) {
	373	if (defined $A->{$podname}->{$ref}->{$bigkey}) {
	374	$value = $A->{$podname}->{$ref}->{$key = $bigkey};
	375	Debug("subs", "bigkey is $bigkey, value is $value\n");
	376	}
	377	elsif (defined $A->{$podname}->{$ref}->{$lilkey}) {
	378	$value = $A->{$podname}->{$ref}->{$key = $lilkey};
	379	return "" if $lilkey eq '';
	380	Debug("subs", "lilkey is $lilkey, value is $value\n");
	381	}
	382	}
	383	if (length($key)) {
a4165598	384	($pod2, $num) = $value =~ /^(.*)_(\S+_\d+)$/;
4633a7c4 LW	385	if ($htype eq "NAME") {
	386	return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
	387	}
	388	else {
	389	return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
	390	}
	391	}
	392	}
	393	if ($char =~ /[IF]/) {
	394	return "<EM>$bigkey</EM>";
	395	} elsif ($char =~ /C/) {
	396	return "<CODE>$bigkey</CODE>";
	397	} else {
	398	return "<STRONG>$bigkey</STRONG>";
	399	}
	400	}
	401
	402	sub find_refs {
	403	my($thing,$htype) = @_;
	404	my($orig) = $$thing;
	405	# LREF: a manpage(3f) we don't know about
	406	for ($$thing) {
	407	#s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g;
	408	s@(\S+?://\S*[^.,;!?\s])@noremap(qq{<A HREF="$1">$1</A>})@ge;
	409	s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{<A HREF="MAILTO:$1">$1</A>}),gie;
	410	s/L<([^>]*)>/lrefs($1,$htype)/ge;
	411	s/([CIBF])<(\W?(-?\w).*?)>/picrefs($1, $2, $3, $htype)/ge;
	412	s/(S)<([^\/]\W?(-?\w).*?)>/picrefs($1, $2, $3, $htype)/ge;
	413	s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge;
	414	s/([\$\@%](?!&[gl]t)([\w:]+\|\W\b))/varrefs($1,$htype)/ge;
	415	}
	416	if ($$thing eq $orig && $htype eq "NAME") {
	417	$$thing = picrefs("I", $$thing, "", $htype);
	418	}
	419
	420	}
	421
	422	sub lrefs {
	423	my($page, $item) = split(m#/#, $_[0], 2);
	424	my($htype) = $_[1];
	425	my($podname);
	426	my($section) = $page =~ /\((.*)\)/;
	427	my $selfref;
	428	if ($page =~ /^[A-Z]/ && $item) {
	429	$selfref++;
	430	$item = "$page/$item";
	431	$page = $pod;
	432	} elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
	433	$selfref++;
	434	$item = $page;
	435	$page = $pod;
	436	}
	437	$item =~ s/\(\)$//;
	438	if (!$item) {
	439	if (!defined $section && defined $Podnames{$page}) {
	440	return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n";
	441	} else {
	442	(warn "Bizarre entry $page/$item") if $Debug;
	443	return "the <EM>$_[0]</EM> manpage\n";
	444	}
	445	}
	446
	447	if ($item =~ s/"(.*)"/$1/ \|\| ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
	448	$text = "<EM>$item</EM>";
449	$ref = "Headers";
450	} else {
451	$text = "<EM>$item</EM>";
452	$ref = "Items";
453	}
454	for $podname ($pod, @inclusions) {
455	undef $value;
456	if ($ref eq "Items") {
457	if (defined($value = $A->{$podname}->{$ref}->{$item})) {
458	($pod2,$num) = split(/_/,$value,2);
459	return (($pod eq $pod2) && ($htype eq "NAME"))
460	? "\n<A NAME=\"".$value."\">\n$text</A>\n"
461	: "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
462	}
463	}
464	elsif ($ref eq "Headers") {
465	if (defined($value = $A->{$podname}->{$ref}->{$item})) {
466	($pod2,$num) = split(/_/,$value,2);
467	return (($pod eq $pod2) && ($htype eq "NAME"))
468	? "\n<A NAME=\"".$value."\">\n$text</A>\n"
469	: "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
470	}
471	}
472	}
473	warn "No $ref reference for $item (@_)" if $Debug;
474	return $text;
475	}
476
477	sub varrefs {
478	my ($var,$htype) = @_;
479	for $podname ($pod,@inclusions) {
480	if ($value = $A->{$podname}->{"Items"}->{$var}) {
481	($pod2,$num) = split(/_/,$value,2);
482	Debug("vars", "way cool -- var ref on $var");
483	return (($pod eq $pod2) && ($htype eq "NAME")) # INHERIT $_, $pod
484	? "\n<A NAME=\"".$value."\">\n$var</A>\n"
485	: "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
486	}
487	}
488	Debug( "vars", "bummer, $var not a var");
489	return "<STRONG>$var</STRONG>";
490	}
491
492	sub gensym {
493	my ($podname, $key) = @_;
494	$key =~ s/\s.*//;
495	($key = lc($key)) =~ tr/a-z/_/cs;
496	my $name = "${podname}_${key}_0";
497	$name =~ s/__/_/g;
498	while ($sawsym{$name}++) {
499	$name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
500	}
501	return $name;
502	}
503
504	sub pre_escapes { # twiddle these, and stay up late :-)
505	my($thing) = @_;
506	for ($$thing) {
347a6e91	507	s/([\200-\377])/noremap("&".ord($1).";")/ge;
4633a7c4 LW	508	s/"(.*?)"/``$1''/gs;
	509	s/&/noremap("&")/ge;
	510	s/<</noremap("<<")/eg;
	511	s/([^ESIBLCF])</$1\&lt\;/g;
7f3dfc00	512	s/E<(\d+)>/\&#$1\;/g; # embedded numeric special
4633a7c4 LW	513	s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special
	514	}
	515	}
	516	sub noremap { # adding translator for hibit chars soon
	517	my $hide = $_[0];
	518	$hide =~ tr/\000-\177/\200-\377/;
	519	$hide;
	520	}
	521
	522
	523	sub post_escapes {
	524	my($thing) = @_;
	525	for ($$thing) {
	526	s/([^GM])>>/$1\&gt\;\&gt\;/g;
	527	s/([^D][^"MGA])>/$1\&gt\;/g;
	528	tr/\200-\377/\000-\177/;
	529	}
	530	}
	531
	532	sub Debug {
	533	my $level = shift;
	534	print STDERR @_,"\n" if $Debug{$level};
	535	}
	536
	537	sub dumptable {
	538	my $t = shift;
	539	print STDERR "TABLE DUMP $t\n";
	540	foreach $k (sort keys %$t) {
	541	printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
	542	}
	543	}
	544	sub trim {
	545	for (@_) {
	546	s/^\s+//;
	547	s/\s\n?$//;
	548	}
	549	}
	550	!NO!SUBS!
	551
	552	close OUT or die "Can't close $file: $!";
	553	chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
	554	exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';