#!/usr/bin/perl
$ETCDIR = "/usr/local/etc";
# add.pl: main routine for dcbib-add(1).
# Copyright (c) TOYODA Eizi, 1998.  All rights reserved.
# see COPYING.TXT for terms of license.

	$ETCDIR = '/etc' unless $ETCDIR;
	$CONFIGFILE = "$ETCDIR/dcbib.conf";

while ($_ = shift) {
	/^-c$/ && ($CONFIGFILE = shift, next);
	&die("undefined commandline argument $_");
}

	&emlOpenFile($CONFIGFILE);
	%CONFIG = &emlRead;

	&emlSetFile("STDIN");
	%HEADER = &emlRead();

	&testCard;

	$outfnam = &generateFileName;
	&creat($outfnam);
	&emlWrite($outfnam, %HEADER);
	
	&okay($outfnam);
	&exit;
# fncreat.pl: filename generation routine for dcbib-add(1).
# Copyright (c) TOYODA Eizi, 1998.  All rights reserved.
# see COPYING.TXT for terms of license.

# assumption:
# * %CONFIG has information from configfile (e.g. /etc/dcbib.conf).
# * %HEADER has information from bib card and tested with &testCard.

sub generateFileName {
	# assumes ending with slash
	local($pat) = $CONFIG{"basedir:"};
	$pat .= $CONFIG{"cardpath:"};
	$pat =~ s/%i/&gfn_initial/ge;
	$pat =~ s/%y/&gfn_year/ge;

	# unique number generator
	if ($pat =~ /%n/) {
		local($number) = 1;
		for (;; $number++) {
			$fnam = $pat;
			$fnam =~ s/%n/$number/g;
			last unless (-e $fnam);
		} 
	} else {
		# Are you sure?  This will overwrite existing same name.
		&warn("cardpath has no %n");
		$fnam = $pat;
	}

	$fnam;
}


sub gfn_year {
	$HEADER{"year:"};
}


# get initial character of author's family name
sub gfn_initial {
	local($author) = split(/\n/, $HEADER{"author:"});
	# if unknown
	return "u" unless $author;
	if ($author =~ /,/) {
		$author =~ s/^\s*//;
	} else {
		# getting last word
		$author =~ s/\s*$//; 
		$author =~ s/^.*[ .]+//; 
	}
	# get initial character
	local($ini) = substr($author, 0, 1);
	$ini =~ tr/A-Z/a-z/;
	$ini;
}

# error.pl: error handler
# Copyright (c) TOYODA Eizi, 1998.  All rights reserved.
# see COPYING.TXT for terms of license.

sub die {
	local($msg) = @_;
	print STDERR "ERROR $msg\n";
	exit 2;
}

sub warn {
	local($msg) = @_;
	print STDERR "WARNING $msg\n";
	$exit = 1;
}

sub okay {
	local($msg) = join(' ', @_);
	print STDERR "OK $msg\n";
}

sub exit {
	exit $exit;
}
# RFC-822-like file reading/writing module
# Copyright (c) TOYODA Eizi, 1998.  All rights reserved.
# see COPYING.TXT for terms of license.

sub emlOpenFile {
	local($file) = @_;
	open($file, "<$file") || &die("cannot open <$file>");
	&emlSetFile($file);
}

sub emlSetFile {
	($emlFile) = @_;
}

sub emlReadLine {
	local($_) = scalar <$emlFile>;
	return undef unless $_;
	&japanese'anyToEUC;
	$_;
}

# -- emlRead() ---
#
# Reads RFC 822 headers from $inputfile and returns hash with which
# $returned_hash{$field_name} == $filed_value,
# where $field_name is lowercased and colon-containing filed name.
# If $field_value contains '\n', it means that the header
# $field_name appeared more than once.
# Undefined return value means there is a format error.

sub emlRead {
	local(%headers) = ();
	local($name, $val) = ("", "");

	while ($_ = &emlReadLine) {
		s/\r?\n$//;
		last if /^$/;
		if (!/^\s/) {
			next if /^From /;
			if (!/^([-A-Za-z0-9]*:)\s*(.*)/) {
				&warn("broken header <$_> in $emlFile");
				return undef;
			}
			($name = $1) =~ tr/A-Z/a-z/;
			($val = $2) =~ s/[\t\r]/ /g;
			if (defined $headers{$name}) {
				$headers{$name} .= "\n$val";
			} else {
				$headers{$name} = $val;
			}
		} else {
			s/[\t\r]/ /g;
			s/^ */ /;
			$headers{$name} .= $_;
		}
	}
	%headers;
}

sub emlWrite {
	local($outfnam, %headers) = @_;
	local($fieldname, @values, $value);

	foreach $fieldname (keys %headers) {
		local(@values) = split(/\n/, $headers{$fieldname});
		foreach $value (@values) {
			print $outfnam "$fieldname $value\n";
		}
	}
}

# misc. file io concerned subroutines
# Copyright (c) TOYODA Eizi, 1998.  All rights reserved.
# see COPYING.TXT for terms of license.

	# create file to write. make directory if necessary.
sub creat {
	local($fnam) = @_;
	local($dnam) = $fnam;
	while ($dnam =~ s/\/[^\/]+$//) {
		last if (-d $dnam);
		mkdir($dnam, 0777) || &die("mkdir $dnam");
	}
	open($fnam, ">$fnam") || &die("creat $fnam");
	$fnam;
}
# bib card integrity check subroutines
# Copyright (c) TOYODA Eizi, 1998.  All rights reserved.
# see COPYING.TXT for terms of license.

sub testCard {
	
}
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;
	}
}

1;
