#!/usr/bin/perl
# htroff.pl: troff-like text formatter for html output
# Copyright (C) TOYODA Eizi, 1998.  All rights reserved.
# see COPYING.TXT for terms of license.

	# number/string registers
	%NUMBER = ("font", 0, "unify", 0, "fillin", 1, "center", 0);
	%STRING = ("font", "", "lastfont", "");
	%OPTION = ();

	# environment detection
	$MSDOS = $NUMBER{"msdos"} = &MSDOS;
	$NUMBER{"jperl"} = &JPERL;
	$Japanese'NOCONV = $NUMBER{"jperl"};
	$Japanese'OUT = $MSDOS ? "Shift_JIS" : "EUC-JP";
	$RCSID = q$Id: htroff.pl,v 1.38 1998/10/09 03:33:05 toyoda Exp $;
	&initFindPath;

	# common variables and messages
	$FOREVER = 100000;
	$ME = "htroff:";
	$CO = "cannot open";
	$NF = "not found";
	$UE = "unexpected";

	# .ig support
	$IGNORE_UNTIL = undef;

	# macro support
	@REQARG = ();		# request arguments: for internal work
	@MACROARG = ();		# macro arguments: for \\$n
	$DEFMACRO = undef;	# if TRUE, lines are stored as macro
	%MACROS = ();		# LF separated macro lines
	%ALIAS = ();		# macro aliases

	# pattern-matching request hook
	%HOOK = ('^\s*$', 'tag P');
	%TAGHOOK = ();

	# conditional support
	$IFVAL = 1;		# if FALSE lines are ignored
	@IFVAL = ();		# $IFVAL of outer block is pushed
	@ELSE = ();		# if TRUE "else" lines are ignored

	# input/output streams
	@PUSHED_INPUT = ();
	@INPUT = ();
	$STRING{"<"} = $INPUT = "";
	$STRING{">"} = $OUTPUT = "STDOUT";

	# predefined number registers
	($NUMBER{"sec"}, $NUMBER{"min"}, $NUMBER{"hour"}, $NUMBER{"dy"},
	 $NUMBER{"mo"}, $NUMBER{"yr"}, $NUMBER{"dw"}, $NUMBER{"yday"},
	 $NUMBER{"dst"}) = localtime time;
	$STRING{"month"} = ("January", "February", "March", "April",
		"May", "June", "July", "August", "September", "October",
		"November", "December")[$NUMBER{"mo"}];
	$NUMBER{"mo"}++;
	$NUMBER{"year"} = $NUMBER{"yr"} + 1900;

	&RegisterMacro("std");
	while ($_ = shift @ARGV) {
		(!/^-/ || /^-$/) && (unshift(@ARGV, $_), last);
		/^--$/ && last;
		/^-m(.*)/ && (&RegisterMacro($1), next);
		/^-o(.*)/ && (&SetOutput($1), next);
		(/^-r(.*)=/ || /^-r(.)/) && ($NUMBER{$1} = $', next);
		(/^-d(.*)=/ || /^-d(.)/) && ($STRING{$1} = $', next);
		/^-V/ && die "$RCSID\n";
		# unknown options are stored for macro use.
		/^-q(.)/ && ($OPTION{$1} = $', next);
		/^-(.)/;
		$OPTION{$1} = $';
	}
	push(@INPUT, @ARGV);

	# event loop
	$CONTINUE = "";
	while ($_ = &getline) {
		&chop;
		$_ = "$CONTINUE$_" unless ($CONTINUE eq "");
		unless (/\\\\$/) {
			s/\\$// && ($CONTINUE = $_, next);
		}
		&ProcessLine;
		$CONTINUE = "";
	}
exit 0;

sub RegisterMacro {
	local($macroname) = @_;
	$OPTION{"-m$macroname"} = 1;
	$OPTION{"-m"} .= "-m$macroname ";
	push(@INPUT, (&FindFile("$macroname.hma") || "DATA::$macroname"));
}

# give line in $_
sub ProcessLine {
	&ExpandEscape;

	# .ig support
	if (defined $IGNORE_UNTIL && /^\.$IGNORE_UNTIL/) {
		$IGNORE_UNTIL = undef;
		return;
	}
	return if defined $IGNORE_UNTIL;

	# macro definition support
	if ($DEFMACRO && /^\0?['.]\.\s*$/) {	# end macro line
		$DEFMACRO = undef;
		return;
	}
	if ($DEFMACRO) {			# begin macro line
		# removing NULs.
		s/\0//g;
		$MACROS{$DEFMACRO} .= "$_\n";
		return;
	}

	# nested if support
	if (/^\0?['.]{\s/) {			# if line
		push(@IFVAL, $IFVAL);
		$IFVAL = $IFVAL && &Boolean($');
		push(@ELSE, $IFVAL);
		return;
	}
	if (/^\0?['.]}{$/ || /^\0?['.]}{\s/) {	# elsif line
		(scalar(@ELSE) == 0) && (warn("$ME $UE .}{"), return);
		$ELSE[$#ELSE] && ($IFVAL = 0, return);
		$ELSE[$#ELSE] = $IFVAL = &Boolean($');
		return;
	}
	if (/^\0?['.]}\s*$/) {			# endif line
		if (scalar @ELSE == 0) {
			warn "$ME .} without .{\n";
			return;
		}
		pop(@ELSE);
		$IFVAL = pop(@IFVAL);
		return;
	}
	$IFVAL || return;

	# normal request/macro lines
	/^['.]/ && return &Request($_);

	# pattern-matching request hook
	$STRING{"line"} = $_;
	foreach (keys %HOOK) {
		$STRING{'line'} =~ /$_/ || next;	
		$STRING{'hook'} = $_;   $STRING{'pre'} = $`;
		$STRING{'match'} = $&;  $STRING{'post'} = $';
		$STRING{'tag'} = undef;
		return &Request(".$HOOK{$_}");
	}

	&writeln($_);
	&CheckFont;
	&CheckUnify;
	&CheckCenter;
}

sub ArgSplit {
	local($_) = @_;
	local(@arg) = ();
	while (length) {
		if (/^"(([^"]|"")*)"\s*/) {
			local($match) = $1;
			$_ = $';
			$match =~ s/""/"/g;
			push(@arg, $match);
		} elsif (/^"/) {
			push(@arg, $');
			$_ = '';
		} elsif (/(\S+)\s*/) {
			push(@arg, $1);
			$_ = $';
		} else {
			last;
		}
	}
	@arg;
}

sub ExprList {
	local($rhs, $lhs);
	local(@EXPR) = (0);
	for (@_) {
		# --- numerical operators
		if ($_ eq "sub") {
			$rhs = pop(@EXPR);
			$EXPR[$#EXPR] -= $rhs;
		} elsif ($_ eq "add") {
			$rhs = pop(@EXPR);
			$EXPR[$#EXPR] += $rhs;
		} elsif ($_ eq "inc") {
			$EXPR[$#EXPR]++;
		} elsif ($_ eq "dec") {
			$EXPR[$#EXPR]--;
		} elsif ($_ eq "equiv") {
			$rhs = pop(@EXPR);
			$EXPR[$#EXPR] = ($EXPR[$#EXPR] == $rhs);
		} elsif ($_ eq "posi") {
			$EXPR[$#EXPR] = ($EXPR[$#EXPR] > 0);
		} elsif ($_ eq "nega") {
			$EXPR[$#EXPR] = ($EXPR[$#EXPR] < 0);
		# --- string operators
		} elsif ($_ eq "length") {
			$EXPR[$#EXPR] = length $EXPR[$#EXPR];
		} elsif ($_ eq "cat") {
			$rhs = pop(@EXPR);
			$EXPR[$#EXPR] .= $rhs;
		} elsif ($_ eq "eq") {
			$rhs = pop(@EXPR);
			$EXPR[$#EXPR] = ($EXPR[$#EXPR] eq $rhs);
		} elsif ($_ eq "lowercase") {
			$EXPR[$#EXPR] =~ tr/A-Z/a-z/;
		} elsif ($_ eq "uppercase") {
			$EXPR[$#EXPR] =~ tr/a-z/A-Z/;
		} elsif ($_ eq "grep" || $_ eq "subpat") {
			$rhs = pop(@EXPR);
			$rhs =~ s/\0//g;
			$EXPR[$#EXPR] =~ /$rhs/;
			$EXPR[$#EXPR] = $& if ($_ eq "grep");
			$EXPR[$#EXPR] = $1 if ($_ eq "subpat");
		} elsif ($_ eq "match") {
			$rhs = pop(@EXPR);
			$rhs =~ s/\0//g;
			$EXPR[$#EXPR] = ($EXPR[$#EXPR] =~ /$rhs/);
		} elsif ($_ eq "file") {
			$EXPR[$#EXPR] = "" unless (-f $EXPR[$#EXPR]);
		} elsif ($_ eq "dir") {
			$EXPR[$#EXPR] = "" unless (-d $EXPR[$#EXPR]);
		} elsif ($_ eq "basename") {
			$EXPR[$#EXPR] =~ /$SUBPAT/;
			$EXPR[$#EXPR] = $1;
		} elsif ($_ eq "dirname") {
			$EXPR[$#EXPR] =~ s/$SUBPAT//;
		# --- boolean operators
		} elsif ($_ eq "not") {
			$EXPR[$#EXPR] = !$EXPR[$#EXPR];
		} elsif ($_ eq "and") {
			$rhs = pop(@EXPR);
			$EXPR[$#EXPR] = ($EXPR[$#EXPR] && $rhs);
		} elsif ($_ eq "or") {
			$rhs = pop(@EXPR);
			$EXPR[$#EXPR] = ($EXPR[$#EXPR] || $rhs);
		} elsif ($_ eq "defined") {
			$EXPR[$#EXPR] = defined $EXPR[$#EXPR];
		# --- constants
		} elsif ($_ eq "undef") {
			push(@EXPR, undef);
		} elsif ($_ eq "null") {
			push(@EXPR, "");
		} elsif ($_ eq "end") {
			push(@EXPR, 0);
		} elsif ($_ eq "begin") {
			push(@EXPR, $FOREVER);
		# --- system operators
		} elsif ($_ eq "option") {
			$EXPR[$#EXPR] = $OPTION{$EXPR[$#EXPR]};
		} elsif ($_ eq "env") {
			$EXPR[$#EXPR] = $ENV{$EXPR[$#EXPR]};
		} elsif ($_ eq "string") {
			$EXPR[$#EXPR] = $STRING{$EXPR[$#EXPR]};
		} elsif ($_ eq "number") {
			$EXPR[$#EXPR] = $NUMBER{$EXPR[$#EXPR]};
		} elsif ($_ eq "macro") {
			$EXPR[$#EXPR] = $MACROS{$EXPR[$#EXPR]};
		} elsif ($_ eq "hook") {
			$EXPR[$#EXPR] = $HOOK{$EXPR[$#EXPR]};
		} elsif ($_ eq "taghook") {
			$EXPR[$#EXPR] = $TAGHOOK{$EXPR[$#EXPR]};
		} elsif ($_ eq "args") {
			push(@EXPR, scalar(@REQARG));
		} elsif ($_ eq "dup") {
			push(@EXPR, $EXPR[$#EXPR]);
		} elsif ($_ eq "pop") {
			pop(@EXPR);
		} elsif ($_ eq "exch") {
			$rhs = pop(@EXPR);
			$lhs = pop(@EXPR);
			push(@EXPR, $rhs, $lhs);
		} elsif ($_ eq "debug") {
			$_ = "$ME TOS = `$EXPR[$#EXPR]'\n";
			&Japanese'EUCToPrintable;
			warn $_;
		} else {
			s/^'//;
			push(@EXPR, $_);
		}
	}
	$EXPR[$#EXPR];
}

sub Boolean {
	local($argl) = @_;
	return 1 if ($argl =~ /^\s*$/);
	&ExprList(&ArgSplit($argl));
}

sub SetFont {
	local($name, $lines) = @_;
	local($ret) = "";
	if ($name eq "P") {
		$name = $STRING{"lastfont"};
		$lines = 0 if ($name eq "");
	}
	$STRING{"lastfont"} = $STRING{"font"};
	if ($lines <= 0) {
		return "" if ($STRING{"font"} eq "");
		$ret = "\\</$STRING{'font'}\\>";
		$STRING{"font"} = "";
		$NUMBER{"font"} = 0;
	} else {
		$ret = "\\</$STRING{'font'}\\>" if ($STRING{"font"} ne "");
		$ret .= "\\<$name\\>";
		$STRING{"font"} = $name;
		$NUMBER{"font"} = $lines;
	}
	$ret;
}

sub CheckFont {
	return if ($NUMBER{"font"} <= 0);
	return if (--$NUMBER{"font"} > 0);
	&tag("/$STRING{'font'}");
	$STRING{"font"} = "";
}

sub SetCenter {
	local($lines) = @_;
	&tag("DIV ALIGN=CENTER") if ($lines && !$NUMBER{"center"});
	&tag("/DIV") if (!$lines && $NUMBER{"center"});
	$NUMBER{"center"} = $lines;
}

sub CheckCenter {
	return if ($NUMBER{"center"} <= 0);
	&tag("BR");
	return if (--$NUMBER{"center"} > 0);
	&tag("/DIV");
}

sub CheckUnify {
	return if ($NUMBER{"unify"} <= 0);
	return if (--$NUMBER{"unify"} > 0);
	&writeln("");
}

sub Request {
	local($request) = @_;
	$request =~ s/^['.]\s*//;
	return if ($request eq "");
	local(@REQARG) = &ArgSplit($request);
	$reqname = shift @REQARG;
	$reqname = $ALIAS{$reqname} if ($ALIAS{$reqname});

	# troff built-in (primitive) requests
	if (defined $MACROS{$reqname}) {
		local(@macro) = split(/\n/, $MACROS{$reqname});
		local(@MACROARG) = @REQARG;
		foreach (@macro) {
			&ProcessLine;
		}
	} elsif ($reqname eq "ig") {
		$IGNORE_UNTIL = $REQARG[0] || "\\.";
	} elsif ($reqname eq "am") {
		$DEFMACRO = $REQARG[0];
	} elsif ($reqname eq "de") {
		$DEFMACRO = $REQARG[0];
		$MACROS{$DEFMACRO} = undef;
	} elsif ($reqname eq "rm") {
		$MACROS{$REQARG[0]} = undef;
	} elsif ($reqname eq "nr") {
		$numreg_name = shift(@REQARG);
		$NUMBER{$numreg_name} = &ExprList(@REQARG);
	} elsif ($reqname eq "ds") {
		$strreg_name = shift(@REQARG);
		$STRING{$strreg_name} = &ExprList(@REQARG);
	} elsif ($reqname eq "as") {
		$strreg_name = shift(@REQARG);
		$STRING{$strreg_name} .= &ExprList(@REQARG);
	} elsif ($reqname eq "bp") {
		&tag("HR");
	} elsif ($reqname eq "br") {
		&tag("BR");
	} elsif ($reqname eq "sp") {
		local($times) = $REQARG[0] || 1;
		for ($i = 0; $i < $times; $i++) {
			&tag("BR");
		}
	} elsif ($reqname eq "nf") {
		$NUMBER{"unify"} = 0;
		&tag("PRE") if $NUMBER{"fillin"};
		$NUMBER{"fillin"} = 0;
	} elsif ($reqname eq "fi") {
		&tag("/PRE") unless $NUMBER{"fillin"};
		$NUMBER{"fillin"} = 1;
	} elsif ($reqname eq "so") {
		push(@PUSHED_INPUT, $INPUT);
		$STRING{"<"} = $INPUT = $REQARG[0];
		open($INPUT, "<$INPUT") || warn "$ME <$INPUT $CO\n";
	} elsif ($reqname eq "ce") {
		&SetCenter($REQARG[0] || 1);
	# --- I don't remember whether they are in troff.
	} elsif ($reqname eq "it") {
		&write(&SetFont("I", ((@REQARG > 0) ? $REQARG[0] : 1)));
	} elsif ($reqname eq "ul") {
		&write(&SetFont("U", ((@REQARG > 0) ? $REQARG[0] : 1)));
	} elsif ($reqname eq "bf") {
		&write(&SetFont("B", ((@REQARG > 0) ? $REQARG[0] : 1)));
	# --- htroff original requests
	} elsif ($reqname eq "shift") {
		shift(@MACROARG);
	} elsif ($reqname eq "getline") {
		($_ = &getline) || return;
		&chop;
		@MACROARG = &ArgSplit($_);
	} elsif ($reqname eq "input") {
		unshift(@INPUT, $REQARG[0]);
	} elsif ($reqname eq "output") {
		&SetOutput($REQARG[0]);
	} elsif ($reqname eq "append") {
		&SetAppend($REQARG[0]);
	} elsif ($reqname eq "alias") {
		$ALIAS{$REQARG[0]} = $REQARG[1];
	} elsif ($reqname eq "hook") {
		$REQARG[0] =~ s/\0//g;
		$HOOK{$REQARG[0]} = $REQARG[1];
		delete $HOOK{$REQARG[0]} if (@REQARG < 2);
	} elsif ($reqname eq "taghook") {
		$REQARG[0] =~ s/\0//g;
		$TAGHOOK{$REQARG[0]} = $REQARG[1];
		delete $TAGHOOK{$REQARG[0]} if (@REQARG < 2);
	} elsif ($reqname eq "char") {
		$char_name = shift(@REQARG);
		$CHAR{$char_name} = shift(@REQARG);
	} elsif ($reqname eq "tag") {
		&tag(@REQARG);
	} elsif ($reqname eq "warn") {
		$_ = join(" ", @REQARG);
		&Japanese'EUCToPrintable;
		warn "$_\n";
	} elsif ($reqname eq "exit") {
		exit &ExprList(@REQARG);
	} elsif ($reqname eq "checkopt") {
		&CheckOpt($REQARG[0]);
	} elsif ($reqname eq "nop") {
		1;	# do nothing
	} else {
		warn "$ME undefined request $reqname.\n";
	}
}

sub CheckOpt {
	local($onechar) = @_;
	$NUMBER{"!"} = 0;
	foreach (keys %OPTION) {
		next if (length $_ == 1) && (index($onechar, $_) >= 0);
		next if /^-/;
		warn "$ME undefined option -$_ used\n";
		$NUMBER{"!"} = 1;
	}
}

sub initFindPath {
	# path delimiter
	$PATHDELIM = $MSDOS ? ";" : ":";
	@FINDPATH = split(/$PATHDELIM/, $ENV{"PATH"});
	unshift @FINDPATH, split(/$PATHDELIM/, $ENV{"FMAC"});
	if (-e $0) {
		# pattern for directory last part
		$SUBPAT = $MSDOS ? '[/\\\\]([^/\\\\]+)$' : '/([^/]+)$';
		($basedir = $0) =~ s/$SUBPAT//;
		unshift(@FINDPATH, $basedir);
	}
}

sub FindFile {
	local($fnam) = @_;
	local($try);
	return $fnam if -f $fnam;
	foreach (@FINDPATH) {
		$try = "$_/$fnam";
		return $try if (-e $try && -r $try);
	}
	undef;
}

sub SetOutput {
	$STRING{">"} = $OUTPUT = $_[0];
	$NUMBER{"!"} = 0;
	if (open($OUTPUT, ">$OUTPUT")) {
		select($OUTPUT);
	} else {
		warn "$ME >$OUTPUT $CO\n";
		$NUMBER{"!"} = $! + 0;
	}
}

sub SetAppend {
	$STRING{">"} = $OUTPUT = $_[0];
	$NUMBER{"!"} = 0;
	if (open($OUTPUT, ">>$OUTPUT")) {
		select($OUTPUT);
	} else {
		warn "$ME >>$OUTPUT $CO\n";
		$NUMBER{"!"} = $! + 0;
	}
}

sub NextFile {
	for (;;) {
		if (@PUSHED_INPUT) {
			return ($STRING{"<"} = $INPUT = pop(@PUSHED_INPUT));
		}
		return undef unless (@INPUT);
		$STRING{"<"} = $INPUT = shift(@INPUT);
		if ($INPUT =~ /^DATA::(.*)/) {
			$macroname = $1;
			$STRING{"<"} = $INPUT = "DATA";
			# skip operation
			for (;;) {
				$line = <$INPUT> || last;
				return $INPUT if $line =~ /^DATA\s+$macroname/;
			}
			warn "$ME macro package $macroname $NF.\n";
		} else {
			open($INPUT, "<$INPUT") && return $INPUT;
			warn "$ME <$INPUT $CO\n";
		}
	}
}

sub getline {
	for (;;) {
		$getline = <$INPUT>;
		next if (($INPUT eq "DATA") && ($getline =~ /^DATA/));
		$getline = ""
			if (($INPUT eq "DATA") && ($getline =~ /^ENDDATA/));
		return $getline if ($getline);
		return undef unless (&NextFile);
	}
}

sub chop {
	s/\r?\n$//;		# in UNIX, MS-DOS newline becomes "\r\n"
	&Japanese'AnyToEUC;
}

sub MacroArgAll {
	local(@arg) = @MACROARG;
	foreach (@arg) {
		s/ /\\0/g;
	}
	join(" ", @arg);
}

# called in head of ProcessLine, so called twice or more for macros.
sub ExpandEscape {
	s/\\\\/\\\0/g;		# "\" guard: removed in &writeln
	s/\\".*//g;		# comment
	s/\\(['.])/\0$1/g;

	# macro argument substitution
	s/\\\$\#/scalar(@MACROARG)/ge;
	s/\\\$\*/join(" ", @MACROARG)/ge;
	s/\\\$\+/&MacroArgAll/ge;
	s/\\\$([1-9])/$MACROARG[$1-1]/g;

	# number register substitution 
	s/\\n\[([^]]+)]/$NUMBER{$1}+0/ge;
	s/\\n\((..)/$NUMBER{$1}+0/ge;
	s/\\n(.)/$NUMBER{$1}+0/ge;

	# string register substitution
	s/\\\*\[([^]]+)]/$STRING{$1}/g;
	s/\\\*\((..)/$STRING{$1}/g;
	s/\\\*(.)/$STRING{$1}/g;
}

sub write {
	local($_) = @_;

	# inline font change
	s/(\\f[IBUR])+\\fR/\\fR/g;	# optimization hack for .RI etc.
	s/(\\fP\\fP)+//g;		# optimization hack
	while (/\\f[IBURP]/) {
		if ($& eq "\\fI") {
			s/\\fI/&SetFont("I", $FOREVER)/e;
		} elsif ($& eq "\\fB") {
			s/\\fB/&SetFont("B", $FOREVER)/e;
		} elsif ($& eq "\\fU") {
			s/\\fU/&SetFont("U", $FOREVER)/e;
		} elsif ($& eq "\\fP") {
			s/\\fP/&SetFont("P", $FOREVER)/e;
		} else {
			s/\\fR/&SetFont("", 0)/e;
		}
	}
	
	# inline size change --- ignored
	s/\\s-?[0-9]+//g;

	# special one-char sequences
	s/\\\&/\0/g;
	s/\\\|/\0/g;
	s/\\\^/ /g;
	s/\\l/ /g;
	s/\\-/-/g;
	s/\\ /\\[nbsp]/g;
	s/\\0/\\[nbsp]/g;

	# defined character escape
	s/\\\((..)/$CHAR{$1}/g;

	# HTML's special characters converted to entity refs.
					s/\\</\\QL/g;	s/\\>/\\QG/g;
	s/&/&amp;/g;	s/"/&quot;/g;	s/</&lt;/g;	s/>/&gt;/g;
	s/\\QA/&/g;	s/\\QQ/"/g;	s/\\QL/</g;	s/\\QG/>/g;

	# SGML entity reference escape --- not compatible with groff
	s/\\\[(\w+)]/&$1;/g;

	# this must be ALL escape expansion
	s/\\e/\\/g;	

	s/\t/"&nbsp;" x 4/ge if $NUMBER{"fillin"};
	s/\0//g;		# remove backslash guard
	&Japanese'EUCToPrintable;
	print "$_";
}

sub writeln {
	local($line) = @_;
	&write($line);
	print "\n" unless $NUMBER{"unify"};
}

sub CheckTag {
	local($name) = @_;
	foreach (keys %TAGHOOK) {
		$name =~ /$_/ || next;	
		$STRING{'tag'} = $name;
		$STRING{'hook'} = $_;
		$STRING{'match'} = undef;
		return &Request(".$TAGHOOK{$_} $name");
	}
}

sub tag {
	local(@arg) = @_;
	&CheckTag($arg[0]);
	&writeln("\\<". join(" ", @arg). "\\>");
}

sub MSDOS {
	# MS-DOS has no /dev/null.
	return 0 if ( -c '/dev/null' );
	# MS-DOS has /DEV/CON even in drive without /DEV.
	return 1 if ( -f '/DEV/CoN' && ! -d '/DEV' );
	# MS-DOS allows CON or NUL have extension.
	return 2 if ( -f '/coN.3b7' && -f '/NuL.j0Q' && -f '/nUl.!#$' );
	0;
}

sub JPERL {
	return 0 unless ("\xE1\xA2" =~ /^.$/);		# normal perl
	return -1 if ("\xA1\xA1" =~ /^.$/);		# EUC jperl
	1;						# SJIS jperl
}


package Japanese;
#
# Japanese conversion package
# usage:
#	1) set $Japanese'OUT to what encoding output used
#	2) set every input line to $_ and call &Japanese'AnyToEUC
#	3) input has no longer any kanji-origin metacharacter like "\*".
#	 so you can safely use it as regular expression.
#	4) set every output line to $_ and call &Japanese'EUCToPrintable
#
#	To turn off conversion, set a nonzero value to $Japanese'NOCONV.
#

sub HtoZ {
	# JIS X 0201 Katakana -> JIS X 0208 conversion
	tr/\xA1-\xFE/\x21-\x7E/;
	tr/\x21-\x25\x30\x5E\x5F/\xA3\xD6\xD7\xA2\xA6\xBC\xAB\xAC/;
	s/[\xA2-\xD7]/\xA1$&/g;
	tr/\x26-\x2F\x31-\x5D/r!\#%')cegC"\$&(*+\-\/13579;=?ADFHJ-NORUX[^-bdfhi-mos/;
	s/[\x21-\x73]/\xA5$&/g;
	tr/\x21-\x73/\xA1-\xF3/;
}

sub block_JtoE {
	if (s/^\(I//) {
		&HtoZ;
		return $_;
	}
	if (s/^\([\@-Z]//) {
		return $_;
	}
	s/^\$[\@B]// || return $_;
	tr/\x21-\x7E/\xA1-\xFE/;
	return $_;
}

sub StoE {
	local($_) = @_;
	if (/^[\xA1-\xDF]/) {
		&HtoZ;
		return $_;
	}
	local($hi, $lo) = unpack("CC", $_);
	$hi -= 0x40 if ($hi > 0x9F);
	$hi -= 0x30;
	$hi *= 2;
	if ($lo <= 0x9E) {
		$lo-- if ($lo >= 0x80);
		$lo += 0x61;
		$hi--;
	} else {
		$lo += 2;
	}
	if ($hi >= 0x115 || $hi == 0x114 && $lo >= 0xBD) {
		$hi -= 0x1B;
		$lo -= 0x1C;
		($lo += 0x5E, $hi--) if ($lo < 0xA1);
	}
	return pack("CC", $hi, $lo);
}

sub EtoS {
	local($c) = @_;
	local($hi, $lo) = unpack("CC", $c);
	if ($hi % 2) {
		$lo -= 0x61;
		$lo++ if ($lo >= 0x7F);
	} else {
		$lo -= 0x02;
	}
	$hi = int(($hi - 1) / 2) + 0x31; 
	$hi += 0x40 if ($hi >= 0xA0);
	return pack("CC", $hi, $lo);
}

sub AnyToEUC {
	return if $NOCONV;
	if (/\x1B[(\$][\@-Z]/) {
		$IN = "ISO-2022-JP";
		$OUT = "ISO-2022-JP" unless $OUT;
		s/\x0E/\x1B\(I/g;
		s/\x0F/\x1B\(B/g;
		@jblock = split(/\x1B/, $_);
		$result = shift @jblock;
		foreach (@jblock) {
			$result .= &block_JtoE;
		}
		$_ = $result;
	}
	if (/[\x81-\x9D][\x81-\xFE]/) {
		$IN = "Shift_JIS";
		$OUT = "Shift_JIS" unless $OUT;
	}
	if ($IN eq "Shift_JIS") {
		s/[\xA0-\xDF]|[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]/&StoE($&)/ge;
	}
	$_;
}

sub block_EtoJ {
	local($_) = @_;
	tr/\xA1-\xFE/\x21-\x7E/;
	s/^/\x1B\x24B/;
	s/$/\x1B\x28B/;
}

sub EUCToPrintable {
	return if $NOCONV;
	$OUT = "(No Conversion)" unless $OUT;
	if ($OUT eq "ISO-2022-JP") {
		s/([\xA1-\xFE][\xA1-\xFE])+/&block_EtoJ($&)/ge;
	} elsif ($OUT eq "Shift_JIS") {
		s/[\xA1-\xFE][\xA1-\xFE]/&EtoS($&)/ge;
	}
}

__END__
DATA std
.\" 
.\" STANDARD MACRO PACKAGE for htroff
.\" Copyright (C) TOYODA Eizi, 1998.  All rights reserved.
.\" see COPYING.TXT for terms of license.
.\" 
.\" --- initialization
.{ -m option defined not
.checkopt "c"
.}
.\"
.\" <BODY> HOOK
.\"
.de BODYhook
.ds cause null
.{ 'match string defined
.ds cause line string
.}
.hook ""
.taghook "."
.tag HTML
.tag HEAD
.nr unify begin
.tag TITLE
\&\\*<
.tag /TITLE
.nr unify end
.tag /HEAD
.{ 'c option defined
.as body " BGCOLOR=\\QQ" 'c option "\\QQ" cat cat
.}
.tag BODY \\*[body]
.{ cause string length
\&\\*[cause]
.}
..
.hook "" BODYhook
.taghook "." BODYhook
.\"
.\" URL LINE HOOKS
.\"
.de urllink
.nr unify start
.ds a 'line string '\\S* grep
.ds b 'line string '\\S*\\s*(.*) subpat
.tag A HREF=\QQ\\*a\QQ
\&\\*a
.nr unify end
.tag /A
.{ 'b string length
\&\\*b
.}
..
.hook "^http://" urllink
.hook "^ftp://" urllink
.hook "^file:" urllink
.de URLlink
.nr unify start
.ds a 'match string "<URL:([^>]+)>" subpat
\&\\*[pre]
.tag A HREF=\QQ\\*a\QQ
\&\\*a
.nr unify end
.tag /A
\&\\*[post]
..
.hook "<URL:[^>]+>" URLlink
.\"
.\" RELATIVE URL
.\"
.de rellink
.ds line 'line string 'relative:(.*) subpat
.urllink
..
.hook "^relative:" rellink
.\"
.\" --- troff compatible requests
.\"
.\" BLANK-STARTING LINE
.\"
.de breakline
.br
\&\\*[line]
..
.hook "^\\s+" breakline
.\"
.\" NOP ALIASES
.\"
.alias	ti br
.alias	ti0 br
.alias	ta nop
.alias	in nop
.alias	ne nop
.alias	ft nop
.alias	hc nop
.alias	di nop
.de if
.{ \\$1 n eq
.shift
\\$*
.}
..
.\" --- groff compatible character definitions
.\"
.char	-D	Dh
.char	Sd	dh
.char	TP	Th
.char	Tp	th
.char	AE	AE
.char	ae	ae
.char	OE	OE
.char	oe	oe
.char	ss	ss
.char	'A	\[Aacute]
.char	'E	\[Eacute]
ENDDATA
DATA dic
.\"
.\" -mdic macro package
.\" Copyright (C) TOYODA Eizi, 1998.  All rights reserved.
.\" see COPYING.TXT for terms of license.
.\"
.\" This package is used with -man, and provides dictionary-style reference
.\"
.\" --- initialization
.\" make -man initializer allow extended option
.nr maninit 1 
.so mdic.tab
.\" --- macros
.\" yet another .TH
.\" usage: .DH title basename date source volume
.de	DH
..
ENDDATA
DATA an
.\"
.\" -man MACRO PACKAGE
.\" Copyright (C) TOYODA Eizi, 1998.  All rights reserved.
.\" see COPYING.TXT for terms of license.
.\"
.\" --- initialization
.checkopt acu
.{ '! number 'maninit number not and
.warn usage: htroff -man [-a] [-u[d]] [-c<color>] files....
.exit 1
.}
.\" --- internally used macros
.de	manout
.{ 'u option 'd eq
.ds manout 'htm\\$2/\\$1.htm lowercase
.}{ '\\$2 "^[2-7]" match 'u option defined not and
.ds manout '\\$1-\\$2.htm lowercase
.}{
.ds manout '\\$1.htm lowercase
.}
..
.\" --- externally used macros
.de	TH
.{ 'a option defined
.manout \\$1 \\$2
.warn htroff -man: output of \\$1(\\$2) written to \\*[manout]...
.output \\*[manout]
.}
.tag HEAD
.nr unify begin
.tag TITLE
man \\$1(\\$2)
.tag /TITLE
.nr unify end
.tag /HEAD
.ds body ""
.{ 'c option defined
.ds body "BGCOLOR=\QQ" 'c option "\\QQ" cat cat
.}
.tag BODY \\*[body]
.nr unify begin
.tag H1
\\$1(\\$2)
.tag /H1
.nr unify end
.{ args 3 sub inc posi
Date: \\$3
.tag BR
.{ args 4 sub inc posi
Source: \\$4
.tag BR
.}
.{ args 5 sub inc posi
Title: \\$5
.tag BR
\\$6
.}
.}
.bp
..
.de	SH
.stopIP
.nr unify begin
.tag H2
\\$*
.tag /H2
.nr unify end
..
.de	SS
.stopIP
.nr unify begin
.tag H3
\\$*
.tag /H3
.nr unify end
..
.de	LP
.stopIP
.tag P
..
.alias	PP LP
.alias	P LP
.de	stopIP
.{ \\n(DL posi
.nr DL 0
.tag /DL
.}
..
.de	IP
.{ \\n(DL posi not
.nr DL 1
.tag DL
.}
.{ args posi
.tag DT
\\$1
.tag DD
.}{
.tag BR
.}
..
.de	TP
.getline
.IP "\\$+"
..
.alias	HP TP
.de	RS
.nr RS \\n(RS 1 add
.tag BLOCKQUOTE
..
.de	RE
.{ \\n(RS posi
.tag /BLOCKQUOTE
.}{
.warn RE without RS
.}
.nr RS \\n(RS 1 sub
..
.de	I
.it 1
.{ args posi
\\$*
.}
..
.de	B
.bf 1
.{ args posi
\\$*
.}
..
.alias	SB B
.de	IB
\fI\\$1\fB\\$2\fI\\$3\fB\\$4\fI\\$5\fB\\$6\fR
..
.de	BI
\fB\\$1\fI\\$2\fB\\$3\fI\\$4\fB\\$5\fI\\$6\fR
..
.de	RI
\\$1\fI\\$2\fP\\$3\fI\\$4\fP\\$5\fI\\$6\fP
..
.de	IR
\fI\\$1\fP\\$2\fI\\$3\fP\\$4\fI\\$5\fP\\$6
..
.de	RB
\\$1\fB\\$2\fP\\$3\fB\\$4\fP\\$5\fB\\$6\fP
..
.de	BR
.{ args 2 equiv '\\$2 '^\([1-8]\w*\) match and
.ds name '\\$1
.ds chap '\\$2 '^\(([1-8]\w*)\) subpat
.ds tail '\\$2 '^\([1-8]\w*\)(.*) subpat
.manout \\*[name] \\*[chap]
.}{
.ds manout null
.}
.{ manout string file
.nr unify begin
.tag A HREF=\\QQ\\*[manout]\\QQ
\\fB\\*[name]\\fR(\\*[chap])\\*[tail]
.nr unify end
.tag /A
.}{
\fB\\$1\fR\\$2\fB\\$3\fR\\$4\fB\\$5\fR\\$6
.}
..
.de	TX
.ds TX 'TX\\$1 string defined 'TX(\\$1) or
\\*(TX\\$2
..
.de	SM
\\$*
..
.alias	IX nop
.alias	PD nop
.alias	DT nop
.\"ds	R	\[reg]
.ds	R	(Reg)
ENDDATA
DATA s
.\"
.\" -ms MACRO PACKAGE
.\" Copyright (C) TOYODA Eizi, 1998.  All rights reserved.
.\" see COPYING.TXT for terms of license.
.\"
.\" --- init
.checkopt "c"
.{ '! number
usage: htroff -ms [-c<color>] files...
.}
.ds MO 'month string
.ds DY 'month string " " cat 'dy number cat ", " cat 'year number cat
.\" --- macros for beginning of page
.de TL
.tag H1 ALIGN=CENTER
..
.de AU
.tag /H1
.tag DIV ALIGN=CENTER
..
.de AI
.tag BR
.tag I
..
.de AB
.tag /I
.tag /DIV
.tag P
..
.de AE
.tag HR
..
.\" --- macros commonly used
.de endPar
.endParWithoutIP
.stopIP
..
.de endParWithoutIP
.bf 0
.it 0
.stopQP
..
.de CT
.endPar
.tag HR
.tag H2
.ds heading H2
.hook "" endheading
..
.de SH
.endPar
.tag H3
.ds heading H3
.hook "" endheading
..
.de endheading
.hook ""
\\*[line]
.tag /\\*[heading]
..
.de PP
.endPar
.tag P
..
.de stopQP
.{ QP number
.tag /BLOCKQUOTE
.nr QP 0
.}
..
.de QP
.endPar
.tag P
.tag BLOCKQUOTE
.nr QP 1
..
.de RS
.tag BLOCKQUOTE
..
.de RE
.tag /BLOCKQUOTE
..
.de	stopIP
.{ \\n(DL posi
.nr DL 0
.tag /DL
.}
..
.de	IP
.endParWithoutIP
.{ \\n(DL posi not
.nr DL 1
.tag DL
.}
.tag DT
\\$1
.tag DD
..
.de	B
.bf 1000
.{ args posi
\\$*
.bf 0
.}
..
.de	I
.it 1000
.{ args posi
\\$*
.bf 0
.}
..
ENDDATA
