#!/usr/bin/perl
###############################################################################
#
# File:         pod2rtf
# RCS:          $Header: $
# Description:  convert pod files to NeXT rtf files
# Author:       Christian Limpach <chris@nice.ch>
# Created:      Sat Oct 22 01:48:59 1994
# Modified:     Mon Oct 31 02:53:20 1994 (Christian Limpach) chris@nice.ch
# Language:     Perl
# Package:      N/A
# Status:       Experimental (Do Not Distribute)
#
# (C) Copyright 1994, Christian Limpach
#
###############################################################################

# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; either version 2 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# A copy of the GNU General Public License can be obtained from this
# program's author (send electronic mail to chris@nice.ch) or from
# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
# 02139, USA.

# based on pod2html from perl5.000 +
# patches from wjm@metronet.com (Bill Middleton) in <Cy2zCy.Kzz@metronet.com>

$paperw=10520;
$paperh=8440;

$/ = "";
$p=\%p;
@exclusions=("perldiag","perlovl","perldebug","perlform","perlobj","perlstyle","perltrap","perlmod");
$indent=0;
opendir(DIR,".");
@{$p->{"pods"}}=grep(/\.pod$/,readdir(DIR));
closedir(DIR);

# learn the important stuff
$i=0;
foreach $tmpod (@{$p->{"pods"}}){
    ($pod=$tmpod)=~s/\.pod$//;
    $p->{"podnames"}->{$pod}=1;
    next if grep(/^$pod$/,@exclusions);
    open(POD,"<$tmpod");
    while(<POD>){
	$_=&unmangle($_);
	s/[ESIBLCF]<([^>]*)>/$1/g;         # attributes
        if (s/^=//) {
	    s/\n$//s;
	    s/\n/ /g;
	    ($cmd, $_) = split(' ', $_, 2);
 	    if ($cmd =~ /^item/) {
		($what,$rest)=split(' ', $_, 2);
		$what=~s#^(-.).*#$1#;
		$what=~s/\s*$//;
		1 while $what=~s/^\"(.*)\"$/$1/;
		$p->{"items"}->{$what} = $pod."_".$i
		    unless defined $p->{"items"}->{$what};
		$what=~s/^([- a-zA-Z0-9]*).*$/$1/;
		$p->{"linkdests"}->{$pod}->{$what} = $pod."_".$i
		    unless defined $p->{"linkdests"}->{$pod}->{$what};
		$i++
	    }
	    elsif($cmd =~ /^head/){
		$_=~s/\s*$//;
		1 while $_=~s/^\"(.*)\"$/$1/;
		$p->{"items"}->{$_} = $pod."_".$i
		    unless defined $p->{"items"}->{$_};
		$_=~s/^([- a-zA-Z0-9]*).*$/$1/;
		$p->{"linkdests"}->{$pod}->{$_} = $pod."_".$i
		    unless defined $p->{"linkdests"}->{$pod}->{$_};
		$i++
	    }
	}
    }
    close POD;
}

$/="";

$lc=1;
$pard_helvetica="\\pard\\tx960\\tx1920\\tx2880\\tx3840\\tx4800\\tx5760\\tx6720\\tx7680\\tx8640\\tx9600\\f2\\b0\\i0\\ulnone\\fs24\\fc0\\cf0";
$pard_ohlfs="\\pard\\tx960\\tx1920\\tx2880\\tx3840\\tx4800\\tx5760\\tx6720\\tx7680\\tx8640\\tx9600\\f3\\b0\\i0\\ulnone\\fs20\\fc0\\cf0";
$pard_helvetica_list="\\pard\\tx960\\tx3260\\tx9600\\f2\\b0\\i0\\ulnone\\fs24\\fc0\\cf0";
$charsize=160;

# parse the pods, produce rtf
foreach $tmpod (@{$p->{"pods"}}){
#foreach $tmpod ("perlfunc.pod"){
    my $justdid="";
    open(POD,"<$tmpod") || die "cant open $pod";
    ($pod=$tmpod)=~s/\.pod$//;
    print STDERR "Creating $pod.rtf from $tmpod\n";
    open(RTF,">$pod.rtf");
    # print rtf header
    print RTF "{\\rtf0\\ansi{\\fonttbl\\f3\\fmodern Ohlfs;\\f2\\fswiss Helvetica;";
    print RTF "\\f1\\ftech Symbol;\\f0\\fnil Times-Roman;}\n";
    print RTF "\\paperw$paperw\n";
    print RTF "\\paperh$paperh\n";
    print RTF "\\margl120\n";
    print RTF "\\margr500\n";
    print RTF "$pard_helvetica\n";
    $cutting = 1;
    while (<POD>) {
	if ($cutting) {
	    next unless /^=/;
	    $cutting = 0;
	}
	chop;
	length || (print RTF "\\\n") && next;
	# Translate verabatim paragraph

	if (/^\s/) {
	    @lines = split(/\n/);
	    if($lines[0]=~/^\s+(\w*)\t(.*)/){  # listing or unordered list
		($key,$rest)=($1,$2);
	    } else { $key="";}
	    if(defined($p->{"podnames"}->{$key})){
		print RTF "$pard_helvetica_list\n";
		foreach $line (@lines){
		    ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rest)=($1,$2));
		    print RTF defined($p->{"podnames"}->{$key}) ?
			"\t\n{{\\NeXTHelpLink$lc \\markername ; \\linkFilename ".
			&unmangle("$key.rtf;")."\\linkMarkername ;}\n\254}".
			&unmangle(" $key\t$rest")."\\\n" :
			&unmangle("\t$key\t$rest")."\\\n";
		    $lc++;
		}
		print RTF "$pard_helvetica\\li$indent\\\n";
		next;
	    }else{		# preformatted text
		print RTF "$pard_ohlfs\\li$indent\n";
		for(@lines){
		    s/^/    /;
    		    1 while s/\t+/' 'x (length($&) * 8 - (length($`)-4) % 8)/e;
		    print RTF  &unmangle($_),"\\\n";
	        }
		print RTF "$pard_helvetica\\li$indent\\\n";
		next;
	    }
	}
	s/&/&&/go;		# escape &'s
	s/E<([^\/][^>]*)>/$HTML_Escapes{$1}/eg;
	#s/E<([^\/][^>]*)>/\&$1\;/g;              # embedded special *NEW*
	#s/S<([^>]*)>/$1/g;              # embedded special
	s/Z<>//g;		# what's a zero-width char good for ?
	$_=&unmangle($_);
	if (s/^=//) {
	    s/\n$//s;
	    ($cmd, $_) = split(' ', $_, 2);
	    if ($cmd eq 'cut') {
		$cutting = 1;
	    }
	    elsif ($cmd =~ /^head([12])/) {
		$size=48 - 8*$1; # gives either 32 or 40
		$hsize=$size/2;
		$what=$_;
		$what=~s/[ESIBLCF]<([^>]*)>/$1/g;
		$what=~s/\s*$//;
		1 while $what=~s/^\"(.*)\"$/$1/;
		if(($justdid ne $what) && defined $p->{"items"}->{$what}) {
		    print RTF "{{\\NeXTHelpMarker$lc \\markername " .
			$p->{"items"}->{$what} .
			";}\n\254}$pard_helvetica\\li$indent ";
		    $lc++;
		    $justdid=$what;
		}
		s/([^&](&&)*)&gt/$1>/go;	# unmangle &gt (uneven number of &'s)
		s/&&/&/go;		# unescape &'s
		print  RTF "\\fs$size\\b ".qq{$_}."\\b0\\fs$hsize\\\n\\fs24\\\n";
	    }
	    elsif ($cmd eq 'head1') {
		$_=&doattexcept("BC", $_);
		s/([^&](&&)*)&gt/$1>/go;	# unmangle &gt (uneven number of &'s)
		s/&&/&/go;		# unescape &'s
		print RTF  qq{\\fs40\\b $_\\b0\\fs20\\\n\\fs24\\\n};
	    }
	    elsif ($cmd eq 'head2') {
		$_=&doattexcept("BC", $_);
		s/([^&](&&)*)&gt/$1>/go;	# unmangle &gt (uneven number of &'s)
		s/&&/&/go;		# unescape &'s
		print RTF  qq{\\fs32\\b $_\\b0\\fs16\\\n\\fs24\\\n};
	    }
	    elsif ($cmd eq 'over') {
		push(@indent,$indent);
		$indent = ($_ + 0)*$charsize;
		print RTF  qq{\\li$indent\n};
	    }
	    elsif ($cmd eq 'back') {
		$indent = pop(@indent);
		warn "Unmatched =back\n" unless defined $indent;
		print RTF qq{\\li$indent\n};
	    }
	    elsif ($cmd eq 'item') {
		($what,$rest)=split(' ', $_, 2);
		$what=~s/[ESIBLCF]<([^>]*)>/$1/g;
		$what=~s#(-.).*#$1#;
		$what=~s/\s*$//;
		1 while $what=~s/^\"(.*)\"$/$1/;
		if(($justdid ne $what) && defined $p->{"items"}->{$what}) {
		    print RTF "{{\\NeXTHelpMarker$lc \\markername " .
			$p->{"items"}->{$what} .
			";}\n\254}$pard_helvetica\\li$indent ";
		    $lc++;
		    $justdid=$what;
		}
		$next_para=1;
		$_=&doattexcept("BC", $_);
		s/([^&](&&)*)&gt/$1>/go;	# unmangle &gt (uneven number of &'s)
		s/&&/&/go;		# unescape &'s
		print  RTF qq{\\b $_\\b0\\\n};
	    }
	    else {
		warn "Unrecognized directive: $cmd\n";
	    }
	}
	else {
	    length || next;
	    $next_para && (print RTF  qq{\\\n});
	    s/\n/ \n/g;
	    $_=&dolinks($_, $pod);
	    $_=&doattribs($_, $pod);
	    s/([^&](&&)*)&gt/$1>/go;	# unmangle &gt (uneven number of &'s)
	    s/&&/&/go;		# unescape &'s
	    print RTF  "$_\\\n\\\n";
	    $next_para && (print  RTF qq{\\\n}) && ($next_para=0);
	}
    }
    print RTF "\n}\n";
    close RTF;
    close POD;
}

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

sub doattribs {
    my($para)=@_;
    my(@ar) = split(/([ESIBLCF]<[^>]*>)/,$para);
    my($this, $word, $key);
    for($this=0;$this<=$#ar;$this++){
	$word=$ar[$this];
	if ($word =~ /^[ESIBLCF]<([^>]*)>/) {
	    $key=$1;
	    if($word =~ /^[BC]/) {
		$ar[$this]="\\b ".$key."\\b0 ";
	    } elsif($word =~ /^[IF]/) {
		$ar[$this]="\\i ".$key."\\i0 ";
	    } elsif($word =~ /^S/) {
		$ar[$this]= ($key =~ s/ /\\~/go);
	    } else {
		$ar[$this]=$key;
	    }
	}
    }
    join('',@ar);
}

sub dolinks {
    my($para,$pod)=@_;
    my(@ar) = split(/([ESIBLCF]<[^>]*>)/,$para);
    my($this, $word, $text, $itext, $key, $destpod);
    for($this=0;$this<=$#ar;$this++){
	$word=$ar[$this];
	if ($word =~ /^[ESIBLCF]<"?([^>]*)"?>/) {
	    ($destpod, $key) = split(/\//,$1,2);
	    do {
		$key=$destpod;
		$destpod=$pod;
	    } unless ($key && $key!~/^$/);
	    if($destpod=~/^$/) {$destpod=$pod;}
	    $key=~s/\s*$//;
	    1 while $key=~s/^\"(.*)\"$/$1/;
	    if($word =~ /^L/) {
		$text=$key;
		$key=~s/^([- a-zA-Z0-9]*).*$/$1/;
		if(defined($p->{"podnames"}->{$key})) {
		    $ar[$this] = "the \n{{\\NeXTHelpLink$lc \\markername ; ".
			"\\linkFilename $key.rtf;\\linkMarkername ;}\n\254} ".
			"$key manpage";
		    $lc++;
		} elsif(defined($p->{"linkdests"}->{$destpod}->{$key})) {
		    if($pod ne $destpod) {
			$itext="the $destpod manpage, ";
		    } else { $itext="";}
		    $ar[$this] = "$itext\n{{\\NeXTHelpLink$lc \\markername ; ".
			"\\linkFilename $destpod.rtf;\\linkMarkername ".
			$p->{"linkdests"}->{$destpod}->{$key}.";}\n\254} $text";
		    $lc++;
		}
	    } else {
		$word=~s/^(.).*$/$1/;
		if(defined($p->{"items"}->{$key})) {
		    ($destpod)=split(/_/,$p->{"items"}->{$key},2);
		    $ar[$this] = "$word<\n{{\\NeXTHelpLink$lc \\markername ; ".
			"\\linkFilename $destpod.rtf;\\linkMarkername ".
			$p->{"items"}->{$key}.";}\n\254} $key>";
		    $lc++;
		}
	    }
	}
    }
    join('',@ar);
}
    
sub doattexcept {
    my($except,$para)=@_;
    $para=~s/[$except]<([^>]*)>/$1/g;
    &doattribs($para);
}

sub unmangle {
    my($word) = @_;
    $word =~ s/\\/\\\\/go;
    $word =~ s/{/\\{/go;		 
    $word =~ s/}/\\}/go;
    $word;
}

BEGIN {
%HTML_Escapes = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'&gt',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    "Aacute"	=>	'\202',		#   capital A, acute accent
    "aacute"	=>	'\326',		#   small a, acute accent
    "Acirc"	=>	'\203',		#   capital A, circumflex accent
    "acirc"	=>	'\327',		#   small a, circumflex accent
    "AElig"	=>	'\341',		#   capital AE diphthong (ligature)
    "aelig"	=>	'\361',		#   small ae diphthong (ligature)
    "Agrave"	=>	'\201',		#   capital A, grave accent
    "agrave"	=>	'\325',		#   small a, grave accent
    "Aring"	=>	'\206',		#   capital A, ring
    "aring"	=>	'\332',		#   small a, ring
    "Atilde"	=>	'\204',		#   capital A, tilde
    "atilde"	=>	'\330',		#   small a, tilde
    "Auml"	=>	'\205',		#   capital A, dieresis or umlaut mark
    "auml"	=>	'\331',		#   small a, dieresis or umlaut mark
    "Ccedil"	=>	'\207',		#   capital C, cedilla
    "ccedil"	=>	'\333',		#   small c, cedilla
    "Eacute"	=>	'\211',		#   capital E, acute accent
    "eacute"	=>	'\335',		#   small e, acute accent
    "Ecirc"	=>	'\212',		#   capital E, circumflex accent
    "ecirc"	=>	'\336',		#   small e, circumflex accent
    "Egrave"	=>	'\210',		#   capital E, grave accent
    "egrave"	=>	'\334',		#   small e, grave accent
    "ETH"	=>	'\220',		#   capital Eth, Icelandic
    "eth"	=>	'\346',		#   small eth, Icelandic
    "Euml"	=>	'\213',		#   capital E, dieresis or umlaut mark
    "euml"	=>	'\337',		#   small e, dieresis or umlaut mark
    "Iacute"	=>	'\215',		#   capital I, acute accent
    "iacute"	=>	'\342',		#   small i, acute accent
    "Icirc"	=>	'\216',		#   capital I, circumflex accent
    "icirc"	=>	'\344',		#   small i, circumflex accent
    "Igrave"	=>	'\214',		#   capital I, grave accent
    "igrave"	=>	'\340',		#   small i, grave accent
    "Iuml"	=>	'\217',		#   capital I, dieresis or umlaut mark
    "iuml"	=>	'\345',		#   small i, dieresis or umlaut mark
    "Ntilde"	=>	'\221',		#   capital N, tilde
    "ntilde"	=>	'\347',		#   small n, tilde
    "Oacute"	=>	'\223',		#   capital O, acute accent
    "oacute"	=>	'\355',		#   small o, acute accent
    "Ocirc"	=>	'\224',		#   capital O, circumflex accent
    "ocirc"	=>	'\356',		#   small o, circumflex accent
    "Ograve"	=>	'\222',		#   capital O, grave accent
    "ograve"	=>	'\354',		#   small o, grave accent
    "Oslash"	=>	'\351',		#   capital O, slash
    "oslash"	=>	'\371',		#   small o, slash
    "Otilde"	=>	'\225',		#   capital O, tilde
    "otilde"	=>	'\357',		#   small o, tilde
    "Ouml"	=>	'\226',		#   capital O, dieresis or umlaut mark
    "ouml"	=>	'\360',		#   small o, dieresis or umlaut mark
    "szlig"	=>	'\373',		#   small sharp s, German (sz ligature)
    "THORN"	=>	'\234',		#   capital THORN, Icelandic
    "thorn"	=>	'\374',		#   small thorn, Icelandic
    "Uacute"	=>	'\230',		#   capital U, acute accent
    "uacute"	=>	'\363',		#   small u, acute accent
    "Ucirc"	=>	'\231',		#   capital U, circumflex accent
    "ucirc"	=>	'\364',		#   small u, circumflex accent
    "Ugrave"	=>	'\227',		#   capital U, grave accent
    "ugrave"	=>	'\362',		#   small u, grave accent
    "Uuml"	=>	'\232',		#   capital U, dieresis or umlaut mark
    "uuml"	=>	'\366',		#   small u, dieresis or umlaut mark
    "Yacute"	=>	'\233',		#   capital Y, acute accent
    "yacute"	=>	'\367',		#   small y, acute accent
    "yuml"	=>	'\375',		#   small y, dieresis or umlaut mark
);
}