#	Crunch option documentation from CWEB/TeX .w format
    #	to (more or less) TROFF format for a manual page.
    
    #	    	by John Walker   --   October 2002
    
    #	perl cwebtex2man.pl input_file.w output_file.1
    
    #	This is not remotely general; it assumes the precise
    #	format used by the documentation of this program
    #	and still requires some manual fix-up.
    
    if ($#ARGV != 1) {
    	print(STDERR "Usage: perl cwebtex2man.pl input_file.w output_file.1\n");
	exit(2);
    }
    
    $ifname = $ARGV[0];
    $ofname = $ARGV[1];
    
    $product = 'annoyance-filter';
    
    open(FI, "<$ifname") || die("Cannot open input file $ifname");
    $indent = ' 10';	    	# Indentation for first .TP command
    $prevpp = $lastpp = 0;
    open(OF, ">$ofname") || die("Cannot create output file $ofname");
    while ($l = <FI>) {
    	$l =~ s/\s+$//;
	if ($l =~ m/^%/) {
	    next;   	    	# Line with % in column is comment--ignore
	}
	if (length($l) == 0) {
	    if ($lastpp == 0) {
	    	print(OF ".PP\n"); # Input blank line is paragraph break
		$lastpp = 1;
	    }
	    next;
	}
	$prevpp = $lastpp;
	$lastpp = 0;
#	print "L: $l\n";
	if ($l =~ m/^\\opt\{/) {
#	    print("Opt: $l\n");
    	    print(OF ".TP$indent\n");
	    $indent = '';
	    $l =~ s/\{\\rm, \}/,/;
#print("Lmod: ($l)\n");
	    $l =~ s/\\opt\{([^\s\}]+)//;
	    $oname = $1;
#print("Oname: ($oname)  L = ($l)\n");
	    $l =~ s/^\s+//; 	    # Strip leading spaces
	    undef $optarg;
	    if ($l =~ s/\{\\it ([^\}]+)\}//) {
	    	$optarg = $1;
#print("Optarg = ($optarg)\n");
	    }
	    $l =~ s/^\}\{//;
#print("Rline: ($l)\n");
	    
	    #	Emit option line for single or variant options
	    
	    $oname =~ s/-/\\-/g;    # Convert hyphens to TROFF dashes
	    $twopts = 0;
	    if ($oname =~ m/,/) {
	    	$twopts = 1;
		if (defined $optarg) {
	    	    $oname =~ s/,/, /; # Insert space after comma
	    	    $oname = "\"$oname\"";  # Quote entire option
		} else {
		    $oname =~ s/,/ ", " /;  # Expand to use with .BR
		}
	    }
	    
	    #	Now we're ready to generate the option line
	    
#print("ONAME: ($oname)\n");
	    if (defined $optarg) {
	    	print(OF ".BI $oname \" $optarg\"\n");
	    } else {
	    	if ($twopts) {
		    print(OF ".BR $oname\n");
		} else {
		    print(OF ".B $oname\n");
		}
	    }
	    
	    &xform;
	    if (length($l) > 0) {
	    	print(OF "$l\n");   # Copy on balance of \opt line, if any
	    }
	} else {
	    &xform;
	    if (length($l) > 0) {
	    	print(OF "$l\n");	    	# Body copy line
	    }
	}
    }
    close(OF);

#   Transform body copy, converting control sequences
    
sub xform {
    $pl = '[\(`]+$';	    	# Punctuation subsumed at left
    $pr = '^[\'\),\.]+';    	# Punctuation subsumed at right
    
    while ($l =~ m/\\([^\s\{]+)/) {
    	$before = $l;
    	$texcmd = $1;
#print("Texcmd = ($texcmd)\n");

    	#   Handle \bigskip escape
	
	if ($texcmd eq 'bigskip') {
	    $l =~ m/(^[^\\]*)\\([^\s\{]+)(.*)$/;
	    $left = $1;
	    $arg = $2;
	    $right = $3;
	    if (length($left) > 0) {
	    	print(OF "$left\n");
	    }
    	    $l = $right;
	    if ((length($left) == 0) && (length($right) == 0)) {
	    	$lastpp = $prevpp;
	    }

    	#   Handle \.{text} escape

	} elsif ($texcmd eq '.') {
#print("Dot escape\n");
	    $l =~ m/^([^\\]*)\\\.\{([^\}]*)\}(.*)$/;
#print ("Dot escape  ($1) : ($2) : ($3)\n");
	    #	Store parsed left, command, and right into variables
	    $left = $1;
	    $arg = $2;
	    $right = $3;
	    $arg =~ s/-/\\-/g;    # Convert hyphens to TROFF dashes
    	    $fcmd = 'B';
	    
	    &subsume;
	    
	#   Handle {\it text} sequence
	
	} elsif ($texcmd eq 'it') {
	    $l =~ m/(^[^\{]*)\{\\it\s+([^\}]*)\}(.*)$/;
	    #	Store parsed left, command, and right into variables
	    $left = $1;
	    $arg = $2;
	    $right = $3;
    	    $fcmd = 'I';
	    
	    &subsume;

    	#   Handle \UNIX/ macro
	
	} elsif ($texcmd eq 'UNIX/') {
	    $l =~ m/(^[^\\]*)\\([^\s\{]+)(.*)$/;
	    $left = $1;
	    $arg = 'Unix';
	    $right = $3;
    	    $fcmd = 'B';
	    
	    &subsume;
	    	    
	#   Handle \aletter{c}{description} sequence.
	#   This is even more of a special case than the
	#   ones above.
	
	} elsif ($texcmd eq 'aletter') {
#print("aletter ($l)\n");
	    $l =~ m/^([^\\]*)\\aletter\{([^\}]*)\}\{([^\}]*)\}(.*)$/;
	    $left = $1;
	    $arg1 = $2;
	    $arg2 = $3;
	    $right = $4;
#print("aletter ($left) ($arg1) ($arg2) ($arg3)\n");
    	    $left =~ s/\s+$//;
    	    $right =~ s/^\s+//;
	    if (length($left) > 0) {
	    	print(OF "$left\n");
	    }
	    print(OF ".br\n");
	    print(OF ".BR \"            $arg1        \" \"$arg2\"\n"); 
	    $l = $right;
	} else {
    	    print(STDERR "!! Undefined command ($texcmd) in ($l)\n");
    	    
	    $l =~ m/(^[^\\]*)\\([^\s\{]+)(.*)$/;
	    $left = $1;
	    $arg = $2;
	    $right = $3;
	    $left .= "(***$arg***)";
	    print(OF "$left\n");
    	    $l = $right;
	}
#print("Before: >>$before<<\n");
#print("After: Left: >>$left<<  Arg: >>$arg<<  Right: >>$right<<\n");
    }
    
    #	Check for trailing right bracket marking end of
    #	option description text and delete.
    
    $l =~ s/\s*\}$//;
    
    #	Translate em-dashes
    
    $l =~ s/---/\\\(em/g;
}

#   Subsume adjacent punctuation into sequence

sub subsume {

    $pl = '[\(`]+$';	    	# Punctuation subsumed at left
    $pr = '^[\'\),\.]+';    	# Punctuation subsumed at right
    
    #	Strip white space from bleeding ends of left and right parts
    $left =~ s/\s+$//;
    $right =~ s/^\s+//;	
    
    #	Check for and subsume parentheses and quotes around literal text
    $lp = $rp = '';
    if (($left =~ m/$pl/) || ($right =~ m/$pr/)) {
	$fcmd = "R$fcmd";
	if ($left =~ s/($pl)//) {
	    $lp = $1;
	    $left =~ s/\s+$//;
	}
	if ($right =~ s/($pr)//) {
	    $rp = $1;
	    $right =~ s/^\s+//;
	}
#print("RI lp = ($lp) left = ($left)  rp = ($rp) right = ($right)\n");
    }

    if (length($left) > 0) {
    	print(OF "$left\n");
    }
    $arg =~ s/\\\$/\$/g;
    if (length($fcmd) == 2) {
	printf(OF ".$fcmd \"$lp\" \"$arg\" \"$rp\"\n");
    } else {
	print(OF ".$fcmd \"$arg\"\n");
    }
#print("I2 = ($left)  A = ($arg)  R = ($right)\n");
    $l = $right;
}