#! /usr/bin/perl
#! /usr/local/bin/perl
#! /usr/local/bin/perl5
#! /usr/bin/perl5

#	IMPOST: An Internet Message Posting Frontend

$Version = "impost version 0.99i-ssh (Nov. 24, 1999)";

#	Copyright(c)1995,1996,1997 by Motonori Nakamura
#					<motonori@econ.kyoto-u.ac.jp>

#	Redistribution for any purpose, without significant modification,
#	is granted as long as all copyright notices are retained.  THIS
#	SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
#	IMPLIED WARRANTIES ARE DISCLAIMED.

#	The newest version can be found in
#	ftp://falcon.econ.kyoto-u.ac.jp/pub/dist/impost/.

# Features:
#	A replacement of send/MH
#	Dispatch messages over SMTP/NNTP
#	SIZE extension by ESMTP supported
#	DSN extension by ESMTP supported (Return-Receipt-To: header is
#		converted to DSN style request)
#	Multiple SMTP/NNTP server support (specify like "s1,s2,s3")
#	Conversion of ISO-2022-JP characters in header part into MIME style
#	Conversion of EUC/SJIS japanese encoding system into ISO-2022-JP
#	Conversion 8bit into Q/Base64 encoding
#	MIME (Multipart) style error notification
#	MIME style BCC (blind carbon copy) encapsulation (with Message/rfc822)
#	DCC (distribution carbon copy) support (MH origin)
#	FCC (folder carbon copy) support (dir/file style)
#	Message-Id:/Date: header generation
#	MH compatible "anno"/"dist" interface
#	"list:;" syntax address support
#	"group:u1, u2;" syntax address support (rewritten to group:;)
#	"group:/file;" style address list file inclusion (rewritten to group:;)
#		This is similar to :include: feature of Sendmail
#		but :include: is only for root-privileged users --
#		This can be used by any users.
#		"group:~/file;" is also supported (relative from home directory)
#	Message splitting into MIME (Message/partial) style multiple messages
#	MH style user level address aliasing support
#	  Definition file must be specified by -mailaliases option
#		or MAILALIASES environment variable
#	  Format of the file is:
#		alias1: u1
#		alias2: u2, u3
#		alias3: group:u4, u5;
#		alias4: group:/address/list/file;
#		 :
#	BIND style user level domain part completion
#	  Definition file must be specified by -hostaliases option or
#		HOSTALIASES environment variable
#	  Format of the file is:
#		alias1	realname1.domain
#		alias2	realname2.domain
#		 :
#	Making user level delivery history
#	  History file path can be changed by -history option
#	Message queuing support for net-detached mobile or dialup environment.
#	Multipart message generation by -multipartadd option
#	Signing with PGP (experimental)

# Usage:
#  o With UCB Mail
#	define "sendmail" environment variable with value "impost".
#  o With Mew
#	eval (setq mew-prog-send "impost")
#  o With MH
#	define sendproc in ~/.mh_profile like "sendproc: impost"
#  o With sendmail.el (if you are using VM or ....)
#	eval (setq sendmail-program "impost")
#  o With mh-e (4 or later)
#	eval (setq mh-send-prog "impost")
#  o With pine
#	define "sendmail-path" in ~/.pinerc, for example:
#	sendmail-path=/usr/local/bin/impost -Report -ObeyHeader -IgnoreDot
#  o With applications which use sendmail
#	replace sendmail to this program but if daemon sendmail is required,
#	original sendmail should be renamed to sendmail.bin or something else
#	for starting daemon mode sendmail and for newaliasing
#  o With applications which use inews
#	header generation by command line option not supported

# Mailing List Information:
#	To subscribe Mailing-List for discussion on "impost",
#	send a message with a line "subscribe impost-users" in body part
#	to majordomo@falcon.econ.kyoto-u.ac.jp
#	(Discussion is held in Japanese, Sorry)

##### SAMPLE CONFIGURATIONS FOR LOCAL ENVIRNMENT #####

$System_config = "/usr/local/etc/impostrc";

'
###
### Sample configuration for "/usr/local/etc/impostrc"
###

# list of SMTP servers (separated with ",")
# (overridden by -smtpservers option or SMTP_SERVER environment variable)
option: -smtpservers localhost,smtp.kyoto.wide.ad.jp

# list of NNTP servers (separated with ",")
# (overridden by -nntpservers option NNTP_SERVER environment variable)
option: -nntpservers localhost

# hostname of this host
# (overridden by -clientname option)
option: -clientname localhost

# default domain part of sender (in header)
# (overridden by -fromdomain option)
option: -fromdomain kyoto.wide.ad.jp

# default domain part of recipient (in header)
# (overridden by -todomain option)
option: -todomain kyoto.wide.ad.jp

# name of organization
option: -org Kyoto Network Operations Center of WIDE Internet, Japan

## if ISO2022JP
# need conversion from EUC/SJIS to ISO-2022-JP
option: -nojpconv

# need ISO-2022-JP header conversion into MIME style
option: -jpheader
## endif
';

'
###
### Sample configuration for "~/.impostrc"
###

# default configuration
config: default
option: -mailfolders Mail
option: -hostaliases ~/.hostaliases
option: -mailaliases ~/.mailaliases
option: -name NAKAMURA Motonori

# special configuration for kyoto-u
# used if -config option specified or "Config: kyoto-u" header line exists
config: kyoto-u
option: -nntpservers news.kyoto-u.ac.jp
option: -smtpservers smtp.kyoto-u.ac.jp
option: -fromdomain kyoto-u.ac.jp
option: -todomain kyoto-u.ac.jp
option: -org Kyoto University, Japan
';

##### MAIN #####
	if ($] >= 5 && $] < 5.003) {
		print STDERR "Sorry, perl5 older than version 5.003 is not supported.\n";
		exit 1;
	}

	&initialize;

	&parse_opts(0, @ARGV);
	&read_config(0, $System_config, "");
	&read_environments;
	&read_config(0, $User_config, "");
	if ($Config_opt ne "") {
		&read_config(0, $User_config, $Config_opt);
	}
	@arg_rest = &parse_opts(1, @ARGV);
	&set_debug;

	if ($ProcessQueue || $QueueStatus) {
		&init_final;
		&process_queue($ProcessQueue);
		&exit(0);
	}

	&open_aliases;

	$Obey_header = 1 if ($Draft_message);
	if (!$Obey_header && !$Smtp_input_mode) {
		foreach $arg (@arg_rest) {
			if ($arg =~ /^\// || $arg =~ /^\w:\//) {
				# absolute path expression: a draft message
				$Draft_message = $arg;	# XXX
				last;
			} else {
				# otherwise: a mail address (not a news group)
				&parse_rcpt(0, $arg);
				$News_flag = 0;	# XXX
			}
		}
	} else {
		# a draft message is specified or SMTP input mode
		# XXX arguments ignored
	}

	if ($Help) {
		&help;
		exit 0;
	}

	unless ($Obey_header || $Draft_message || $Smtp_input_mode) {
		# recipients should be specified at command line
		if ($#Recipients < 0 && $Newsgroups eq "") {
			# XXX "send:" is for trap hack of mew B-)
			print STDERR "send: message was not delivered.\n";
			print STDERR "Recipient names must be specified.\n";
			exit 1;
#			$Errlog .= "Recipient names must be specified.\n";
#			&error_exit;
		}
	}

##### GET A MESSAGE #####
	if ($Draft_message || $Dist_file) {
		# read whole message from draft message file
		$Dot_terminate = 0;
		if ($Dist_flag && $Dist_file) {
			&read_message(1);	# read altmsg to resend
		} else {
			&read_message(0);	# read normal message
		}
	} elsif ($Smtp_input_mode) {
		# read message with SMTP
		&smtp_get_mail;
	} else {
		# read message from STDIN
		&read_header("STDIN", 0);
		&read_body("STDIN", $Dot_terminate);
	}
	print STDERR "message accepted.\n" if ($Verbose);

##### SET SIGNAL HANDLING FUNCTIONS #####
	$SIG{'ALRM'} = alarm_func;
	$SIG{'TERM'} = term_func;
	$SIG{'INT'} = int_func;

##### OPTIONAL CONFIGURATION #####
	if ($Obey_header && ($Config_opt = &header_value("Config"))) {
		$Config_opt =~ s/\s+//g;
		&read_config(0, $User_config, $Config_opt)
			if ($Config_opt ne "");
		&kill_header("Config", 0);
	}

##### HEADER PROCESSING #####
	if ($Config_opt ne "") {
		# reopen
		&close_aliases;
		&open_aliases;
	}
	&init_final;

	if ($Obey_header && &header_value("Return-Receipt-To")) {
		$Dsn_success_report = 1;
		&kill_header("Return-Receipt-To", 0);
	}
	
	# verify invalid headers for posting news
	if ($Newsgroups ne "") {
		&add_header(1, "Newsgroups", $Newsgroups);
		&kill_header("Path", 0);
		&kill_header("Followup-To", 0);
		&kill_header("Received", 0);
		&kill_header("Return-Path", 0);
		&kill_header("NNTP-Posting-Host", 0);
		&kill_header("Xref", 0);
		&kill_header("Resent-To", 0);
		&kill_header("Resent-Cc", 0);
		&kill_header("Resent-From", 0);
		$News_flag = 1;
	} elsif ($News_flag
	 && &header_value("Newsgroups")
	 && !&header_value("Path")
	 && !&header_value("Received")
	 && !&header_value("Return-Path")
	 && !&header_value("NNTP-Posting-Host")
	 && !&header_value("Xref")
	 && (!$News_severe_check
	   || !&header_value("Apparently-To")
	   && !&header_value("To")
	   && !&header_value("Cc"))) {
#		$News_flag = 1;
#		print STDERR "NNTP will performed.\n" if ($Debug{"judge"});
	} else {
		$News_flag = 0;
		print STDERR "NNTP disabled (header format is not fit).\n"
			if ($Debug{"judge"});
	}

	if ($Dist_flag
#	 || &header_value("Date")
	 || &header_value("Resent-To")
	 || &header_value("Resent-Cc")
	 || &header_value("Resent-From")) {
		$resend_mode = 1;
		$Resend_prefix = "Resent-";
		$News_flag = 0;
		print STDERR "NNTP disabled (resend is only for mailing).\n"
			if ($Debug{"judge"});
	} else {
		$resend_mode = 0;
		$Resend_prefix = "";
	}

	if ($Dist_flag && $Dist_file) {
		&rewrite_resend_header;
		&append_dist_header;
	}

## if ISO2022JP
	# hook before convert header
	eval "&$Hook_PreHeaderconv" if ($Hook_PreHeaderconv);

	&header_iso2022jp_conv;
## endif

	# XXX just for NetNews ?
	if ($News_flag && $Organization && !&header_value("Organization")) {
## if ISO2022JP
		if ($Iso2022jp_code_conversion) {
#			$c = &code_check($Organization);
#			if ($c eq "sjis" || $c eq "euc" || $c eq "sORe") { # XXX
				$Organization = &conv_iso2022jp($Organization);
#			}
		}
		$Organization = &line_iso2022jp_mimefy($Organization)
			if ($Iso2022jp_header_mime_conv);
## endif
		&add_header(0, "Organization", $Organization);
	}
	if ($Generate_message_id
	 && !&header_value($Resend_prefix."Message-Id")) {
		$Cur_mid = &gen_message_id(0);
		&add_header(0, $Resend_prefix."Message-Id", $Cur_mid);
	}
	if ($Generate_date && !&header_value($Resend_prefix."Date")) {
		&add_header(0, $Resend_prefix."Date", &gen_date(!$News_flag));
	}
	if ($Sender_name) {
		if ($Comment_Name) {
			$Sender_line = "$Sender ($Sender_name)";
		} else {
			$Sender_line = "$Sender_name <$Sender>";
		}
## if ISO2022JP
		if ($Iso2022jp_code_conversion) {
#			$c = &code_check($Sender_line);
#			if ($c eq "sjis" || $c eq "euc" || $c eq "sORe") { # XXX
				$Sender_line = &conv_iso2022jp($Sender_line)
#			}
		}
		$Sender_line = &struct_iso2022jp_mimefy($Sender_line)
			if ($Iso2022jp_header_mime_conv);
## endif
	} else {
		$Sender_line = $Sender;
	}
	print STDERR "Sender: $Sender_line\n" if ($Debug{"from"});
	unless ($from = &header_value($Resend_prefix."From")) {
		&add_header(0, $Resend_prefix."From", $Sender_line);
	} else {
		if (&parse_rcpt(-1, $from) != 1
		 || &extract_addr($from) ne $Sender) {
			&add_header(1, $Resend_prefix."Sender", $Sender_line);
#			&add_header(1, "Originator", $Sender_line)
#				if ($News_flag);
		}
	}
	if (!&header_value("Subject")) {
		&add_header(1, "Subject", $Subject);
	}

##### BODY PROCESSING #####
	unless (&header_value("Mime-Version")) {
		$Body_code = &body_code(*Body);
		print STDERR "Body code is $Body_code\n" if ($Debug{"code"});
		$do_conv_8to7 = 0;
		if ($Body_code eq "8BIT") {
			$Need_mime_version_header = 1;
			$Has_8bit_body = 1;
			$do_conv_8to7 = 1 if ($Conv_8to7);
		}
## if ISO2022JP
		elsif ($Body_code eq "JIS") {
			$Need_mime_version_header = 1;
			$Has_iso2022jp_body = 1;
		} elsif ($Body_code eq "SJIS" || $Body_code eq "EUC") {
			$Need_mime_version_header = 1;
			if ($Iso2022jp_code_conversion) {
				$Has_iso2022jp_body = 1;
				&body_convert_iso2022jp(*Body);
				if ($Has_Hankaku_kana) {
					$Body_code = "8BIT";
					$Has_8bit_body = 1;
					$do_conv_8to7 = 1 if ($Conv_8to7);
				}
			} else {
				$Has_8bit_body = 1;
				$do_conv_8to7 = 1 if ($Conv_8to7);
			}
		}
		if ($do_conv_8to7) {
			if ($Need_base64_encoded) {
				&body_base64_encode(*Body);
				$Body_encoding = "base64";
			} else {
				&body_qp_encode(*Body);
				$Body_encoding = "quoted-printable";
			}
		}
## endif
	}

##### HEADER REWRITING #####
	&rewrite_header;

##### GET RECIPIENTS #####
	&rcpt_pickup($resend_mode, 0)
		if ($Obey_header || $Draft_message);

##### VERIFY FORMAT OF THE MESSAGE #####
	if ($News_flag) {
		unless (&header_value("Newsgroups")) {
			$Errlog .= "Invalid message format (no Newsgroups)\n";
			print STDERR "send: no Newsgroups.\n" if ($Verbose);
			&error_exit;
		}
		unless (&header_value("Subject")) {
			$Errlog .= "Invalid message format (no Subject)\n";
			print STDERR "send: no Subject.\n" if ($Verbose);
			&error_exit;
		}
		if ($#Body < 0) {
			$Errlog .= "No message body\n";
			print STDERR "send: no message body.\n" if ($Verbose);
			&error_exit;
		}
	} else {
		if ($#Recipients < 0) {
			$Errlog .= "No recipients collected.\n";
			print STDERR "send: no recipients.\n" if ($Verbose);
			&error_exit;
		}
	}

	if ($Me_too) {
		&add_to_rcpt(0, $Sender);
	}

	# hook before final header processing
	eval "&$Hook_PreFinalHeaderProc" if ($Hook_PreFinalHeaderProc);

##### FINAL HEADER PROCESSING #####
	&add_header(1, "X-".$Resend_prefix."Dispatcher", $Version);
	&kill_header("Bcc", 0);
	&kill_header("Dcc", 0);
	&kill_header("Fcc", 0);
	&kill_header("Resent-Bcc", 0);
	&kill_header("Resent-Dcc", 0);
	&kill_header("Resent-Fcc", 0);
	if ($resend_mode) {
		&kill_header("Resent-Sender", 1);
		&kill_header("Resent-From", 1);
		&kill_header("Resent-Message-Id", 1);
	} else {
		&kill_header("Sender", 1);
		&kill_header("From", 1);
		&kill_header("Message-Id", 1);
	}
	if ($Draft_message) {
		# annotation headers
		&kill_header("Replied", 0);
		&kill_header("Forwarded", 0);
		&kill_header("Resent", 0);
	}

	if ($Need_mime_version_header && !&header_value("Mime-Version")) {
		&add_header(1, "Mime-Version", "1.0");
		if ($Has_8bit_body) {
			&add_header(1, "Content-Type",
				"Text/plain; charset=$Unknown8bit_label");
## if ISO2022JP
		} elsif ($Has_iso2022jp_body) {
			if ($Body_code eq "SJIS" || $Body_code eq "EUC") {
				&add_header(1, "Content-Type",
					"Text/plain; charset=iso-2022-jp"
					." (auto-converted from $Body_code)");
			} else {
				&add_header(1, "Content-Type",
					"Text/plain; charset=iso-2022-jp");
			}
## endif
		} else {
			&add_header(1, "Content-Type",
				"Text/plain; charset=us-ascii");
		}
		if ($Body_encoding) {
			&add_header(1, "Content-Transfer-Encoding",
				"$Body_encoding");
		}
	}

##### PGP HANDLING #####
	if ($PGP_Sign) {
		&pgp_process;
	}

##### MULTIPART HANDLING #####
	&add_multipart if (@Mulipart_messages);

##### SIZE OF MESSAGE BODY FIXED #####
	if (!&header_value("Lines")) {
		if ($#Body >= 0) {
			&add_header(1, "Lines", $#Body);
		} else {
			&add_header(1, "Lines", '0');
		}
	}
	if ($Lines_to_partial > 0 && $#Body > $Lines_to_partial) {
		$partial_total
			= int(($#Body+$Lines_to_partial-1) / $Lines_to_partial);
	} else {
		$partial_total = 0;
	}

	&kill_empty_header;

##### SAVE INTO FOLDER #####
	if ($Fcc_folder) {
		@Response = ();
		if (&save_fcc($Fcc_folder, $Fcc_save_dir, 0, $partial_total)) {
			&log_history("fcc", $Fcc_folder, "sent");
		} else {
			$Errlog .= "Folder carbon copy ($Fcc_folder) failed.\n";
			print STDERR "send: folder carbon copy failed.\n"
				if ($Verbose);
			&log_history("fcc", $Fcc_folder, "failed");
			&error_exit;
		}
	}

##### QUEUING IF NEEDED #####
	if ($JustQueuing) {
		if (&queue_message) {
			if ($Draft_message) {
				&trash_message;
				&mh_annotate if ($Annotate_flag);
			}
			print STDERR "message queued.\n" if ($Verbose);
			exit 0;
		}
		$Errlog .= "Queuing failed.\n";
		# XXX "send:" is for trap hack of mew B-)
		print STDERR "send: queuing failed.\n" if ($Verbose);
		&error_exit;
	}

##### DISPATCH THE MESSAGE #####
	# hook before dispatching the message
	eval "&$Hook_PreDispatching" if ($Hook_PreDispatching);

	$rcode = &send_message($News_flag, $partial_total);
	if ($rcode == 0) {
		if ($Smtp_input_mode) {
			&smtp_get_mail_final(0) unless ($Error_report_by_mail);
		} elsif ($Verbose) {
			if ($Info) {
				print STDERR "\n";
				print STDERR $Info;
			}
			if ($Session_log) {
				print STDERR "\n";
				print STDERR $Session_log;
			}
		}
		if ($Draft_message) {
			&trash_message;
			&mh_annotate if ($Annotate_flag);
		}
		&exit(0);
	} else {
		if ($rcode > 0 && $Queuing) {
			if (&queue_message) {
				if ($Draft_message) {
					&trash_message;
					&mh_annotate if ($Annotate_flag);
				}
				print STDERR "message queued.\n" if ($Verbose);
				&exit(0);
			}
		}
		# XXX "send:" is for trap hack of mew B-)
		print STDERR "send: delivery failed.\n" if ($Verbose);
		&error_exit;
	}
# end of main


##### INITIALIZATION #####
#
# initialize()
#	return value: none
#
sub initialize {

	$Prog = $0;
	($Prog_base = $Prog) =~ s/.*\///;

	# table of commandline options
	@Options = (
		## Format: option_name, type, pointer, default, description
		#   The TYPE consists of the following flags
		#     1st: [T] true/bool, [F] false/bool, [S] string
		#     2nd: [+] early eval, [:] normal, [-] secret, [=] ignored
		## early evaluated options
		'Help',		'T+',	*Help,			0,
				"this information is shown",
		'rc',		'S+',	*User_config,		"\~/.impostrc",
				"user's configuration file",
		'Config',	'S+',	*Config_opt,		"",
				"user's configuration option",
		'Debug',	'T+',	*DebugAll,		0,
				"set all debug options",
		'DebugFlag',	'S+',	*DebugFlag,		0,
				"set specific debug options (sep. with ',')",
		'Verbose',	'T+',	*Verbose,		0,
				"set verbose mode",
		'NoVerbose',	'F+',	*Verbose,		0,
				"unset verbose mode",
		## late evaluated options
		'Require',	'S:',	*User_require,		"",
				"user's require file",
		'SMTPservers',	'S:',	*Smtp_servers,		"localhost",
				"list of SMTP servers (separated with ',')",
		'EmgSMTPsvrs',	'S:',	*Emg_Smtp_servers,	"",
				"list of SMTP servers for Emergency Use",
		'TryNextOnFatal','T:',	*Smtp_fatal_next,	0,
				"Try next SMTP server evenif permanent error",
		'NNTPservers',	'S:',	*Nntp_servers,		"localhost",
				"list of NNTP servers (separated with ',')",
		'ClientName',	'S:',	*Client_name,		"localhost",
				"name as a SMTP client (used for SMTP HELO)",
		'SSHserver',	'S:',	*Ssh_server,			"",
				"SSH port relay server",
		'ObeyMTAdomain','T:',	*Obey_MTA_domain,		0,
				"do not append default domain on local address",
		'FromDomain',	'S:',	*Default_from_domain_name,	"",
				"default domain name for sender",
		'ToDomain',	'S:',	*Default_to_domain_name,	"",
				"default domain name for recipients",
		'MsgIdDomain',	'S:',	*Message_id_domain_name,	"",
				"default domain name for Message-Id generation",
		'User',		'S:',	*User_name,			"",
				"address local part of the sender",
		'Name',		'S:',	*Sender_name,			"",
				"commentary name for the sender",
		'NameInComment','T:',	*Comment_Name,			0,
				"show commentary name in () at From: header",
		'Org',		'S:',	*Organization,			"",
				"name of organization for news",
		'Subj',		'S:',	*Subject,			"",
				"a string for subject field",
		'NScmpl',	'T:',	*Cmpl_with_gethostbyname,	0,
				"use domainpart completion with nameserver",
		'noNScmpl',	'F:',	*Cmpl_with_gethostbyname,	0,
				"do not use domainpart completion with NS",
		'ShowRcpts',	'T:',	*Show_Rcpts_Header,		1,
				"show recipients in header as To: if no To:",
		'noShowRcpts',	'F:',	*Show_Rcpts_Header,		1,
				"append To: U-R:; header if no To:",
		'MeToo',	'T:',	*Me_too,			0,
				"request DCC to me",
		'Fcc',		'S:',	*Fcc_folder,			"",
				"folder name to save FCC",
		'Receipt',	'T:',	*Dsn_success_report,		0,
				"need successful delivery report",
		'Group',	'S:',	*Newsgroups,			"",
				"Newsgroup names to be posted in",
## if ISO2022JP
		'JPconv',	'T:',	*Iso2022jp_code_conversion,	0,
				"convert encoding from EUC/SJIS to JIS",
		'DefCode',	'S:',	*Default_code,			"8BIT",
				"Default classification (EUC/SJIS/8BIT)",
		## compatibility for sendmail on Sony NEWS
		'J',		'T-',	*Iso2022jp_code_conversion,	0, "",
		'noJPconv',	'F:',	*Iso2022jp_code_conversion,	0,
				"do not convert Japanese encodings",
		'JPheader',	'T:',	*Iso2022jp_header_mime_conv,	1,
				"encode JIS to MIME style at header",
		'noJPheader',	'F:',	*Iso2022jp_header_mime_conv,	1,
				"do not encode JIS to MIME style at header",
		'HdrQEncoding',	'T:',	*HdrQEncoding,			0,
				"Header encoding type: 0 is B/1 is Q",
## endif
		'NoHdrFolding',	'T:',	*NoFolding,			0,
				"do not fold long header lines",
		'Through8',	'F:',	*Conv_8to7,			1,
				"do not convert 8bit body to 7bit",
		'8to7',		'T:',	*Conv_8to7,			1,
				"convert 8bit body to 7bit",
		'8BitLabel',	'S:',	*Unknown8bit_label,	"unknown-8bit",
				"label for unknown 8bit body",
		'Lines',	'S:',	*Lines_to_partial,	0,
				"line numbers for splitting",
		'noPartial',	'F:',	*Lines_to_partial,	0,
				"no splitting",
		'Sleep',	'S:',	*Partial_sleep,		10,
				"sleep interval for dispatching splitted mail",
		'History',	'S:',	*Hist_file,	"\~/.posthistory",
				"path of history log file",
		'noHistory',	'F:',	*Hist_file,	"\~/.posthistory",
				"do not write posting history log",
		'Report',	'T:',	*Error_report_by_mail,	1,
				"report errors via mail",
		'noReport',	'F:',	*Error_report_by_mail,	1,
				"report errors to terminal",
		'MsgId',	'T:',	*Generate_message_id,	1,
				"generate Message-Id header line",
		'noMsgId',	'F:',	*Generate_message_id,	1,
				"do not generate Message-Id header line",
		'PidMsgId',	'T:',	*Message_id_PID,	0,
				"generate Message-Id with Process ID",
		'Date',		'T:',	*Generate_date,		1,
				"generate Date header line",
		'noDate',	'F:',	*Generate_date,		1,
				"do not generate Date header line",
		'NewsGMTdate',	'T:',	*NewsGMTdate,		0,
				"generate date field in GMT for posting news",
		'MailAliases',	'S:',	*Mail_aliases,		"",
				"list of files for mail address aliasing",
		'HostAliases',	'S:',	*Host_aliases,		"",
				"list of files for domain part completion",
		'MailFolders',	'S:',	*Default_msg_folders_dir,	"Mail",
				"path of directory for message folders",
		'FccDir',	'T:',	*Fcc_save_dir,		1,
				"save to folder with directory style",
		'FccFile',	'F:',	*Fcc_save_dir,		1,
				"save to folder with file style",
		'FccPartial',	'T:',	*Fcc_partial,		0,
				"save FCC with partial format",
		'Dead',		'S:',	*Dead_letter,	"\~/dead.letter",
				"path of file to save deadletter",
		'JustQueuing',	'T:',	*JustQueuing,		0,
				"just queue message",
		'Queuing',	'T:',	*Queuing,		0,
				"queue message on connection failure",
		'ProcessQueue',	'T:',	*ProcessQueue,		0,
				"process queued messages",
		'QueueStatus',	'T:',	*QueueStatus,		0,
				"show list of queued messages",
		'QueueDir',	'S:',	*Queue_Dir,	"\~/.imqueue",
				"path of queuing directory",
		'MsgMode',	'S:',	*Mode_message,		"0600",
				"mode for message file creation",
		'FolderMode',	'S:',	*Mode_directory,	"0700",
				"mode for folder directory creation",
		'Folder',	'S:',	*Draft_folder,		"",
				"path of draft folder directory",
		'MIMEbcc',	'T:',	*Mime_bcc,		1,
				"use MIME style BCC",
		'noMIMEbcc',	'F:',	*Mime_bcc,		1,
				"do not use MIME style BCC",
		'TrashMark',	'S:',	*Trashmark,		"#",
				"prefix for draft message renaming",
		'Message',	'S:',	*Draft_message,		"",
				"path/name of draft message",
		'PGPsign',	'T:',	*PGP_Sign,		0,
				"sign body-part with PGP",
		'MultipartAdd',	'L:',	*Mulipart_messages,	"",
				"path/name of message to be added in multipart",
		'SMTP',		'T:',	*Smtp_input_mode,	0,
				"SMTP style input mode",
		'Dist',		'T:',	*Dist_flag,		0,
				"redistribution mode (using Resent-*)",
		'DistMsg',	'S:',	*Dist_file,		"",
				"path of message for redistribution",
		'ObeyHeader',	'T:',	*Obey_header,		0,
				"pick up recipients from message header",
		'IgnoreHeader',	'F:',	*Obey_header,		0,
				"do not pick up recipients from message header",
		'TermDot',	'T:',	*Dot_terminate,		1,
				"treat DOT as termination",
		'IgnoreDot',	'F:',	*Dot_terminate,		1,
				"ignore DOT for termination",
		'NewsCheck',	'T:',	*News_severe_check,	0,
				"no news posting if To, Cc, etc header found",
		'noNewsCheck',	'F:',	*News_severe_check,	0,
				"post news when Newsgroups header found",
		'ESMTP',	'T:',	*Esmtp_flag,		0,
				"enforce ESMTP",
		'noESMTP',	'F:',	*Esmtp_flag,		0,
				"use ESMTP only if server says ESMTP is OK",
		'NewsPost',	'T:',	*News_flag,		1,
				"enable NNTP",
		'noNewsPost',	'F:',	*News_flag,		1,
				"disable NNTP",
#		'DelMailHdr',	'L:',	*Del_headers_on_mail,	"",
#				"header list to be deleted on mail sending",
#		'DelMewsHdr',	'L:',	*Del_headers_on_news,	"",
#				"header list to be deleted on news posting",
		## for compatibility with send/MH
		'Watch',	'T-',	*Verbose,		0,	"",
		'NoWatch',	'F-',	*Verbose,		0,	"",
		'DraftFolder',	'S-',	*Draft_folder,		"",	"",
		'DraftF',	'S-',	*Draft_folder,		"",	"",
		'NoDraftFolder','S=',	*Dummy,			"",	"",
		'DraftMessage',	'S-',	*Draft_message,		"",	"",
		'DraftM',	'S-',	*Draft_message,		"",	"",
		'Draft',	'F=',	*Dummy,			"",	"", #XXX
		'Alias',	'S-',	*Mail_aliases,		"",	"",
		'Filter',	'S=',	*Dummy,			"",	"",
		'NoFilter',	'F=',	*Dummy,			"",	"",
		'Format',	'T=',	*Dummy,			"",	"",
		'NoFormat',	'F=',	*Dummy,			"",	"",
		'Forward',	'T=',	*Dummy,			"",	"",
		'NoForward',	'F=',	*Dummy,			"",	"",
		'Push',		'T-',	*Error_report_by_mail,	0,	"",
		'NoPush',	'F-',	*Error_report_by_mail,	0,	"",
		'Width',	'S=',	*Dummy,			"",	"",
		'Library',	'S=',	*Dummy,			"",	"",
## if ISO2022JP
		'HEncode',	'T-',	*Iso2022jp_header_mime_conv, 0,	"",
		'NoHEncode',	'F-',	*Iso2022jp_header_mime_conv, 0,	"",
## endif
		'MIME',		'T-',	*Mime_bcc,		0,	"",
		'Split',	'S-',	*Partial_sleep,		0,	"",
		'Server',	'S-',	*Smtp_servers,		"",	"",
		'Client',	'S-',	*Client_name,		"",	"",
		## temporary solution for compatibility with sendmail
		'bs',		'T-',	*Smtp_input_mode,	0,	"",
		'f',		'S=',	*Dummy,			"",	"",
		't',		'T-',	*Obey_header,		0,	"",
		'v',		'T-',	*Verbose,		0,	"",
		'odb',		'F-',	*Dummy,			0,	"",
		'odi',		'F-',	*Dummy,			0,	"",
		'oem',		'F-',	*Error_report_by_mail,	1,	"",
		'oi',		'F-',	*Dot_terminate,		0,	"",
		'i',		'F-',	*Dot_terminate,		0,	"",
		'om',		'T-',	*Me_too,		0,	"",
		'm',		'T-',	*Me_too,		0,	"",
		'odq',		'T-',	*JustQueuing,		0,	"",
		'q',		'T-',	*ProcessQueue,		0,	"",
		'bp',		'T-',	*QueueStatus,		0,	"",
		## temporary solution for compatibility with inews
		'h',		'T-',	*Obey_header,		0,	"",
		## temporary solution for compatibility with ucbmail
		's',		'S-',	*Subject,		0,	"",
	);
	while ($#Options >= 0) {
		local ($key, $type, $ptr, $dfl, $desc) = splice(@Options, 0, 5);
		$name = $key;
		$key =~ y/A-Z/a-z/;
#		print STDERR "Key: $key\n" if ($Debug{"opt"});
		$Options{$key} = $type;
		$OptName{$key} = $name;
		$Pointers{$key} = $ptr;
		$Description{$key} = $desc;
		next if ($type =~ /^.[=-]/);
		if ($dfl) {
			*p = $ptr;
			$p = $dfl;
		}
	}

	# table of environment variables
	%Environments = (
		'NAME',			*Sender_name,
		'SIGNATURE',		*Sender_name,
		'SMTP_SERVERS',		*Smtp_servers,
		'NNTP_SERVERS',		*Nntp_servers,
		'ORGANIZATION',		*Organization,
		'MAILALIASES',		*Mail_aliases,
		'HOSTALIASES',		*Host_aliases,
		'MSGIDDOMAIN',		*Message_id_domain_name,
		'FROMDOMAIN',		*Default_from_domain_name,
		'TODOMAIN',		*Default_to_domain_name,
		# the followings are not shown in the help.
		'mhaltmsg',		*Dist_file,	# for redistribution
		'mhdist',		*Dist_flag,	# for redistribution
		'mhannotate',		*Annotate_flag,	# for annotation
		'mhinplace',		*Annotate_inp,	# for annotation
		'mhmessages',		*Annotate_msg,	# for annotation
	);

	# Constants
	$Address_operators = '\@%!:';
	$Folding_length = 72;
	@Base64a = ('A'..'Z', 'a'..'z', '0'..'9', '+', '/');
	grep($Base64b{$Base64a[$_]} = unpack('B6', pack('C', $_ * 4)), 0 .. 63);
	@Week_str = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
	@Month_str = ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
			"Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
## if ISO2022JP
	($Jp_Bin, $Jp_Qin, $Jp_out)
		= ('=?ISO-2022-JP?B?', '=?ISO-2022-JP?Q?', '?=');
	($Jis_kanji, $Jis_roman) = ('\e\$[\@B]', '\e\([BJ]');
	($E_jp, $E_asc, $E_kana) = ("\e\$B", "\e(B", "\e(I");

	$C_jis       = '\e\$[@B]([\x21-\x7e][\x21-\x7e])+';
	$C_jis_roman = '\e\([BJ][\s\x21-\x7e]*';
	$C_sjis      = '([\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc])+';
	$C_sjis_kana = '[\xa1-\xdf]+';
	$C_euc       = '([\xa1-\xfe][\xa1-\xfe])+';
	$C_euc_kana  = '(\x8e[\xa1-\xdf])+';
	$C_SorE      = '([\xa1-\xdf]|[\x8e\xe0-\xfc][\xa1-\xfc])+';
## endif
	$C_ascii     = '[\s\x21-\x7e]*';
#	$C_ascii     = '[\x07\s\x21-\x7e]*';	# for IRC freak :-)
	$C_pascii    = '[\x21-\x7e]+';
	$C_tascii    = '[\x21\x23-\x27\x2a\x2b\x2d\x30-\x39\x41-\x5a\x5e-\x7e]+';
	$C_sascii    = '[\x22\x28\x29\x2c\x2e\x2f\x3a-\x40\x5b-\x5d]+';

	$C_8bit      = '[\x80-\xff]';

	@Debug_Options = ("opt", "conf", "judge", "from", "code", "addr",
	  "include", "header", "alias", "encode", "fcc", "queue", "create",
	  "multipart", "put", "smtp");

	# Variables
#	@Del_headers_on_mail = ("Originator");
	@Del_headers_on_news = ("To", "Cc");
	$CRLF = "\n";

	# host information
	$Hostname = `hostname`;
	chop($Hostname);
	($Hostname) = gethostbyname($Hostname);

	# user's information
	local ($pw_name, $pw_passwd, $pw_uid, $pw_gid,
	 $pw_quota, $pw_comment, $pw_gcos, $pw_dir, $pw_shell) = getpwuid($<);

	$Login = $pw_name;
	$Uid = $pw_uid;
	$Home = $pw_dir;
	$Home = $ENV{'HOME'} if ($ENV{'HOME'});

	local (@cap) = unpack("aa*", $pw_name);
	$cap[0] =~ tr/a-z/A-Z/;
	local ($cap) = join("", @cap);
	($Sender_name = $pw_gcos) =~ s/,.*$//;
	$Sender_name =~ s/&/$cap/g;

	srand(time+$$);
#	binmode(STDIN);

	$Cur_time = time;
}

##### SIGNAL HANDLERS #####
sub alarm_func {
#	no operation
}

sub int_func {
	$Errlog .= "Terminated by interrupt (SIGINT).\n";
	&error_exit;
}

sub term_func {
	$Errlog .= "Terminated by interrupt (SIGTERM).\n";
	&error_exit;
}

##### PARSE COMMANDLINE OPTIONS #####
#
# parse_opts(late_flag, args...)
#	late_flag: true for processing on late evaluating options
#	args...: option argument list
#	return value: unparsable arguments as option
#
sub parse_opts {
	local ($late, @argv) = @_;
	local ($_, $opt, $type, $v);
	while ($_ = shift(@argv)) {
		unless (/^-(.*)/) {
			unshift(@argv, $_);
			last;
		}
		$opt = $1;
		$opt =~ y/A-Z/a-z/;
		unless ($type = $Options{$opt}) {
			# XXX "send:" is for trap hack of mew B-)
			print STDERR "send: message was not delivered.\n";
			print STDERR "unknown option -$opt\n";
			exit 1;
		}
		*p = $Pointers{$opt};
		if ($type =~ /^T/) {		# Boolean: True
			next if ($type =~ /^.=/);
			next if ($late && $type =~ /^.\+/);
			next if (!$late && $type =~ /^.[:-]/);
			$p = 1;
			printf STDERR "setting option %s = 1\n", *p
				if ($Debug{"opt"});
		} elsif ($type =~ /^F/) {	# Boolean: False
			next if ($type =~ /^.=/);
			next if ($late && $type =~ /^.\+/);
			next if (!$late && $type =~ /^.[:-]/);
			$p = 0;
			printf STDERR "setting option %s = 0\n", *p
				if ($Debug{"opt"});
		} elsif ($type =~ /^S/) {	# String (overriding)
			if ($#argv < 0) {
				# XXX "send:" is for trap hack of mew B-)
				print STDERR "send: message was not delivered.\n";
				print STDERR "Missing value for option -$opt\n";
				exit 1;
			}
			$v = shift(@argv);
			next if ($type =~ /^.=/);
			next if ($late && $type =~ /^.\+/);
			next if (!$late && $type =~ /^.[:-]/);
			if ($v eq "\@HOSTNAME\@") {
				$v = $Hostname;
			}
			$p = $v;
			printf STDERR "setting option %s = \"%s\"\n", *p, $p
				if ($Debug{"opt"});
		} elsif ($type =~ /^L/) {	# List (appending)
			if ($#argv < 0) {
				# XXX "send:" is for trap hack of mew B-)
				print STDERR "send: message was not delivered.\n";
				print STDERR "Missing value for option -$opt\n";
				exit 1;
			}
			$v = shift(@argv);
			next if ($type =~ /^.=/);
			next if ($late && $type =~ /^.\+/);
			next if (!$late && $type =~ /^.[:-]/);
			if ($v eq "\@HOSTNAME\@") {
				$v = $Hostname;
			}
			push (@p, $v);
			printf STDERR "adding value %s <- \"%s\"\n", *p, $p
				if ($Debug{"opt"});
		}
	}
	return @argv;
}

##### SET DEBUG #####
#
# set_debug()
#
sub set_debug {
	local ($f, $opt, $found);
	if ($DebugFlag) {
		foreach $f (split(',', $DebugFlag)) {
			$found = 0;
			foreach $opt (@Debug_Options) {
				if ($f eq $opt) {
					$found = 1;
					last;
				}
			}
			unless ($found) {
				printf STDERR "unknown debug option: $f\n";
			}
			$Debug{$f} = 1;
		}
		$Verbose = 1;
	}
	if ($DebugAll) {
		foreach $f (@Debug_Options) {
			$Debug{$f} = 1;
		}
		$Verbose = 1;
	}
}

##### FILE PATH COMPLETION #####
#
# file_path(file_name, folder_name, base_name, ign_plus)
#	file_name: a file name
#	folder_name: folder name
#	base_name: base path for relative search
#	ign_plus: true if preceeding '+' for folder name
#	return value: absolute file path
#
sub file_path {
	local ($file, $subdir, $base, $ign_plus) = @_;
	return $file if ($file =~ /^\//);
	return $file if ($file =~ /^.:/);	# DOS style drive specifier
	if ($file =~ /^\~\//) {
		$file =~ s/^\~/$Home/;
		return $file;
	}
	if ($file =~ /^\+/) {
		$file = &get_folders_dir(0)."/".substr($file,1);
		return $file;
	}
	$base = $Home unless ($base);
	if ($subdir) {
		if ($subdir =~ /^\~\//) {
			$subdir =~ s/^\~/$Home/;
			return "$subdir/$file" if ($file);
			return "$subdir";
		}
		$subdir =~ s/^\+// if ($ign_plus && $subdir =~ /^\+/);
		return "$base/$subdir/$file" if ($file);
		return "$base/$subdir";
	} else {
		return "$base/$file" if ($file);
		return $base;
	}
}

##### READ CONFIG FILE #####
#
# read_config(required, path, conf_opt)
#	required: exit with error notice if true
#	path: path of configuration file
#	conf_opt: special configuration block name
#	return value: none
#
sub read_config {
	local ($required, $config, $conf_opt) = @_;
	local ($file) = &file_path($config, "", "", 0);
	local (@arg, $c, $skip, $found);
	unless (open(CONFIG, "<$file")) {
		if ($required) {
			# XXX "send:" is for trap hack of mew B-)
			print STDERR "send: message was not delivered.\n";
			print STDERR "can not open config file: $file\n";
			exit 1;
		}
		print STDERR "can not open config file: $file\n"
			if ($Debug{"conf"});
		return;
	}
	print STDERR "Reading $file\n" if ($Debug{"conf"});
	$conf_opt = "default" unless ($conf_opt);
	$conf_opt =~ s/\s+//g;
	print STDERR "Using configuration for $conf_opt\n" if ($Debug{"conf"});
	if ($conf_opt =~ /^default$/i) {
		$skip = 0;
	} else {
		$skip = 1;
	}
	$found = 0;
	while (<CONFIG>) {
		chop if (/\n$/);
		next if (/^#/);	# skip commentary line
		next if (/^$/);	# skip blank line
		s/\s*$//;	# ignore trailing spaces
		if (/^\s*config:\s*(\S+)\s*/i) {
			print STDERR "tracing config for $1\n"
				if ($Debug{"conf"});
			$skip = 1;
			foreach $c (split(',', $1)) {
				if ($c =~ /^$conf_opt$/i) {
					$found = 1;
					$skip = 0;
					last;
				}
			}
		}
		next if ($skip);
		if (/^\s*option:\s*(-\w+)\s*/i) {
			if ($') {
				push (@arg, $1, $');
			} else {
				push (@arg, $1);
			}
		}
	}
	close(CONFIG);
	if ($conf_opt !~ /^default$/i && !$found) {
		# XXX "send:" is for trap hack of mew B-)
		print STDERR "send: message was not delivered.\n";
		print STDERR "configuration for $conf_opt not found.\n";
		exit 1;
	}
	printf STDERR "options found in $file: %s\n", join(' ', @arg)
		if ($Debug{"conf"});
	&parse_opts(1, @arg);
}

##### SHOW CURRENT CONFIGURATIONS #####
#
# help()
#	return value: none
#
sub help {
	local ($key, $type, $conf, *p);
	print STDOUT "$Version ($Prog)\n";
	print STDOUT "[description and configuration for options"
		." (option name is case insensitive)]\n";
	foreach $key (sort sortfunc keys %Options) {
		$conf = "-".$OptName{$key};
		$type = $Options{$key};
		next if ($type =~ /^.[-=]/);	# skip secret/ignored
		*p = $Pointers{$key};
		if ($type =~ /^T/) {
			$conf .= " (set)" if ($p);
			$conf .= " (not set)" unless ($p);
		} elsif ($type =~ /^F/) {
			$conf .= " (set)" unless ($p);
			$conf .= " (not set)" if ($p);
		} elsif ($type =~ /^S/) {
			if (defined $p) {
				$conf .= " \"$p\"";
			} else {
				$conf .= " <undef>"; # XXX
			}
		} elsif ($type =~ /^L/) {
			if ($#p >= 0) {
				$conf .= " (".join(',', @p).")";
			} else {
				$conf .= " <empty>"; # XXX
			}
		}
		if (length($conf) > 29) {
			printf STDOUT "  %s\n", $conf;
			printf STDOUT "\t\t\t\t%s\n", $Description{$key};
		} else {
			printf STDOUT "  %-29s %s\n", $conf, $Description{$key};
		}
	}
	print STDOUT "[environments to be referenced]\n";
	foreach $key (sort keys %Environments) {
		next if ($key =~ /^[a-z]/);	# skip secret
		if (defined $ENV{$key}) {
			print STDOUT "  $key=\"$ENV{$key}\"\n";
		} else {
			print STDOUT "  $key=<undef>\n";
		}
	}
}

##### OPTION NAMES SORT FUNCTION #####
#
# sortfunc()
#
sub sortfunc {
	local ($c) = $a;
	local ($d) = $b;
	$c =~ y/A-Z/a-z/;
	$d =~ y/A-Z/a-z/;
	$c =~ s/^no(.*)/$1.no/;
	$d =~ s/^no(.*)/$1.no/;
	return $c cmp $d;
}

##### READ ENVIRONMENT VARIABLES #####
#
# read_environments()
#	return value: none
#
sub read_environments {
	local ($e);
	foreach $e (sort keys %Environments) {
		if (defined $ENV{$e}) {
			*p = $Environments{$e};
			$p = $ENV{$e};
			print STDERR "getenv: $e=$p\n" if ($Debug{"conf"});
		}
	}
}

##### FINAL INITIALIZATION #####
#
# init_final()
#	return value: none
#
sub init_final {
	$Mode_message = eval $Mode_message;
	if ($Mode_message) {
		$MsgUmask = 0777 ^ $Mode_message;
	} else {
		$MsgUmask = 0077;
	}
	$Mode_directory = eval $Mode_directory;
	if ($Mode_directory) {
		$DirUmask = 0777 ^ $Mode_directory;
	} else {
		$DirUmask = 0077;
	}

	# sender information
	$Login = $User_name if ($User_name);	# XXX
	unless ($Sender) {
		if ($Default_from_domain_name && !$Obey_MTA_domain) {
			$Sender = "$Login\@$Default_from_domain_name";
		} else {
			$Sender = $Login;
		}
	}

	unless ($Message_id_domain_name) {
		if ($Default_from_domain_name) {
			$Message_id_domain_name = $Default_from_domain_name;
		} else {
			$Message_id_domain_name = "unknown-domain";
		}
	}

	@Smtp_servers = split(',', $Smtp_servers);
	@Nntp_servers = split(',', $Nntp_servers);

	local ($inc);
	if (defined($^A)) {	# $^A is not used by perl V4
		# perl V5 or later
		$inc = "Socket.pm";
		foreach $prefix (@INC) {
			if (-f "$prefix/$inc") {
				eval 'use Socket';
				$AF_INET = &AF_INET;
				$SOCK_STREAM = &SOCK_STREAM;
				$P5inc = 1;
				eval 'use Fcntl';
				last;
			}
		}
	} else {
		# perl V4
		$inc = "sys/socket.ph";
		foreach $prefix (@INC) {
			if (-f "$prefix/$inc") {
				require "$prefix/$inc";
				$AF_INET = &AF_INET;
				$SOCK_STREAM = &SOCK_STREAM;
				require 'sys/syscall.ph';
				require 'fcntl.ph';  
				$P4syscall = 1;
				last;
			}
		}
	}
	if (!defined($AF_INET) && !defined($SOCK_STREAM)) {
		print STDERR "$inc not found. using default parameter.\n"
			if ($Verbose);
		$AF_INET = 2;
		if (open(SOCKET_H, "</usr/include/sys/socket.h")) {
			while (<SOCKET_H>) {
				if (/^\s*#define\s+NC_TPI_COTS\s+(\d+)/) {
					$NC_TPI_COTS = $1;
				}
				if (/^\s*#define\s+SOCK_STREAM\s+(\d+)/) {
					$SOCK_STREAM = $1;
					last;
				}
				if (/^\s*#define\s+SOCK_STREAM\s+NC_TPI_COTS/) {
					$SOCK_STREAM = $NC_TPI_COTS;
					last;
				}
			}
			close(SOCKET_H);
		}
		unless ($SOCK_STREAM) {
			if (-d "/etc/init.d") {
				# assignments for Solaris/IRIX
				$SOCK_STREAM = 2;
			} else {
				# assignments for 4.3BSD
				$SOCK_STREAM = 1;
			}
		}
	}

	# user's require file
	if($User_require) {
		require "$User_require";
	}
}

##### GENERATE A MESSAGE-ID CHARACTER STRING #####
#
# gen_message_id(part)
#	part: part number of partial messages (for reuse)
#	return value: a unique message-id string
#
sub gen_message_id {
	local ($part) = @_;
	return $Mid_hist{$part} if ($part > 0 && $Mid_hist{$part});
	local ($tm_sec, $tm_min, $tm_hour, $tm_mday, $tm_mon, $tm_year)
		= localtime($Cur_time);
	local ($mid_time) = sprintf("%d%02d%02d%02d%02d%02d",
		$tm_year+1900, $tm_mon+1, $tm_mday, $tm_hour, $tm_min, $tm_sec);
	local ($mid_rnd) = sprintf("%c", 0x41 + rand(26));
	if ($Prev_mid_time eq $mid_time) {
		while ($mid_rnd =~ /[$Mid_rnd_hist]/) {
			$mid_rnd = sprintf("%c", 0x41 + rand(26));
		}
		$Mid_rnd_hist .= $mid_rnd;
	} else {
		$Prev_mid_time = $mid_time;
		$Mid_rnd_hist = $mid_rnd;
	}
	if ($Message_id_PID) {
		$mid_rnd = "-".$$.$mid_rnd;
	}
	local ($mid) = "<$mid_time$mid_rnd.$Uid\@$Message_id_domain_name>";
	$Mid_hist{$part} = $mid if ($part > 0);
	return $mid;
}

##### GANARATE A DATE CHARACTER STRING #####
#
# gen_date(need_week)
#	need_week:
#		0 = day-of-week portion (Sun, Mon,...) not required
#		1 = day-of-week portion required		
#	return value: current date string
#
sub gen_date {
	local ($need_week) = @_;
	local ($tm_sec, $tm_min, $tm_hour, $tm_mday, $tm_mon, $tm_year,
		$tm_wk, $tm_yday);
	local ($tm_tz);
	if ($NewsGMTdate && $News_flag) {
		($tm_sec, $tm_min, $tm_hour, $tm_mday, $tm_mon, $tm_year,
			$tm_wk, $tm_yday) = gmtime($Cur_time);
		$tm_tz = "GMT";
	} else {
		($tm_sec, $tm_min, $tm_hour, $tm_mday, $tm_mon, $tm_year,
			$tm_wk, $tm_yday) = localtime($Cur_time);
		local ($gm_sec, $gm_min, $gm_hour, $gm_mday, $gm_mon, $gm_year,
			$gm_wk, $gm_yday) = gmtime($Cur_time);
		local ($off) = ($tm_hour - $gm_hour) * 60 + $tm_min - $gm_min;
		if ($tm_year < $gm_year) {
			$off -= 24 * 60;
		} elsif ($tm_year > $gm_year) {
			$off += 24 * 60;
		} elsif ($tm_yday < $gm_yday) {
			$off -= 24 * 60;
		} elsif ($tm_yday > $gm_yday) {
			$off += 24 * 60;
		}
		if ($off == 0) {
			$tm_tz = "GMT";
		} elsif ($off > 0) {
			$tm_tz = sprintf("+%02d%02d", $off/60, $off%60);
		} else {
			$off = -$off;
			$tm_tz = sprintf("-%02d%02d", $off/60, $off%60);
		}
	}
	local ($date) = sprintf("%02d %s %d %02d:%02d:%02d %s",
		$tm_mday, $Month_str[$tm_mon], $tm_year+1900,
		$tm_hour, $tm_min, $tm_sec, $tm_tz);
	if ($need_week) {
		return "$Week_str[$tm_wk], $date";
	} else {
		return $date;
	}
}

##### MAKE TCP CONNECTION TO SPECIFIED SERVER #####
#
# connect_server(server_list, protocol)
#	server_list: comma separated server list
#	protocol: protocol name to be used with the servers
#	return value: handle if success
#
sub connect_server {
	local (*servers, $proto) = @_;
	local ($SOCK) = $proto;
	local ($port);
	@Response = ();
	local ($pe_name, $pe_aliases, $pe_proto) = getprotobyname ("tcp");
	unless ($pe_name) {
		$pe_proto = 6;
#		$Errlog .= "unknown protocol: tcp\n";
#		return "";
	}
	local ($se_name, $se_aliases, $se_port) = getservbyname ($proto, "tcp");
	unless ($se_name) {
		if ($proto eq "smtp") {
			$se_port = 25;
		} elsif ($proto eq "nntp") {
			$se_port = 119;
		} else {
			$Errlog .= "unknown service: $proto\n";
			return "";
		}
	}

	local ($he_name, $he_alias, $he_type, $he_len, $he_addr, @he_addrs);
	local ($s, $sin);
	while ($s = shift(@servers)) {
		$Cur_server_original_form = $s;
		local ($r) = ($#servers >= 0)?"skipped":"failed";
		# manage server:localport or server/remoteport:localport notation
		if ($s =~ s/:(\d+)$//) {
			$port = $1;
			$Cur_server = $s;
			local( $remoteport );
			if ($s =~ s/\/(\d+)$//) {
				$remoteport = $1;
			} else {
				$remoteport = $se_port;
			}
			# Set default value of SSH Relay server.
			$Ssh_server || ( $Ssh_server = $Client_name );
			if ($Ssh_server eq 'localhost') {
				$Errlog .= "Port-forwarding via localhost is not available.\n";
				$port = $remoteport;
				$Cur_server = "$s/$port";
			} else {
				if ( $port = &ssh_proxy($s,$remoteport,$port,$Ssh_server) ) {
					$s = 'localhost';
					$Cur_server = "$Cur_server:$port";
				} else { # Connection failed.
					$Errlog .= "Can't login to $Ssh_server.\n";
					push( @Response, "Can't login to $Ssh_server." );
					if ($proto =~ /smtp$/i) {
						&log_history($proto,
							     join(',', @Recipients), $r);
					} else { # NNTP
						&log_history($proto, $Newsgroups, $r);
					}
					next;
				}
			}
		}
		# manage server/port notation
		elsif ($s =~ s/\/(\d+)$//) {
			$port = $1;
			$Cur_server = "$s/$port";
		} else {
			$port = $se_port;
			$Cur_server = $s;
		}
		if ($s =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
			@he_addrs = (pack("C4", $1, $2, $3, $4));
		} else {
			alarm(60);
			$0 = "$Prog_base: gethostbyname($s)";
			($he_name, $he_alias, $he_type, $he_len, @he_addrs)
				= gethostbyname ($s);
			alarm(0);
			unless ($he_name) {
				$Errlog .= "address unknown for $s\n";
				@Response = ("address unknown for $s");
				if ($proto =~ /smtp$/i) {
					&log_history($proto,
						join(',', @Recipients), $r);
				} else { # NNTP
					&log_history($proto, $Newsgroups, $r);
				}
				next;
			}
		}

		foreach $he_addr (@he_addrs) {
			if ($P5inc && defined(&Socket'pack_sockaddr_in)) {
				$sin = &Socket'pack_sockaddr_in($port, $he_addr);
			} else {
				$sin = pack("S n a4 x8", $AF_INET, $port, $he_addr);
			}
			unless (socket($SOCK, $AF_INET, $SOCK_STREAM,
			 $pe_proto)) {
				$Errlog .= "socket creation failed: $!.\n";
				return "";
			}
			print STDERR "opening $proto session to $s($port).\n"
				if ($Verbose);
			alarm(60);
			$0 = "$Prog_base: connecting to $s with $proto";
			if (connect ($SOCK, $sin)) {
				alarm(0);
				select ($SOCK); $| = 1; select (STDOUT);
#				unshift(@servers, $s);	# XXX
				$ErrTitle = "(while talking to $s with $proto)\n";
				return $SOCK;
			}
			@Response = ($!);
			alarm(0);
			close($SOCK);
		}
		$Errlog .= "$proto server $s($port) did not respond.\n";
		if ($proto =~ /smtp$/i) {
			&log_history($proto, join(',', @Recipients), $r);
		} else { # NNTP
			&log_history($proto, $Newsgroups, $r);
		}
	}
	$Errlog .= "$proto connection was not established.\n";
	return "";
}

##### CLIENT-SERVER HANDSHAKE #####
#
# send_command(channel, command, log_flag)
#	channel: socket descriptor to send the command
#	command: command string to be sent
#	log_flag: conversations are saved in $Session_log if true
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub send_command {
	local ($CHAN, $command, $logging) = @_;
	local ($resp, $stat, $rcode);
	@Response = ();
	$stat = "";
	if ($command) {
		print STDERR "<<< $command\n" if ($Verbose);
		$Session_log = $Session_log."<<< $command\n" if ($logging);
		unless (print $CHAN "$command\r\n") {
			# may be channel truoble
			@Response = ($!);
			return 1;
		}
		$0 = "$Prog_base: $command ($Cur_server)";
	} else {
## if you have mysterious TCP/IP bug on IRIX/SGI
#		print $CHAN " ";
## endif
		$0 = "$Prog_base: greeting ($Cur_server)";
	}
	do {
		alarm(600);
		unless ($resp = <$CHAN>) {
			# may be channel truoble
			@Response = ("$!");
			return 1;
		}
		alarm(0);
		$resp =~ s/[\r\n]+$//;
		if ($resp =~ /^[0-9][0-9][0-9]/) {
			$rcode = $&;
			if ($stat eq "" && $rcode !~ /^0/) {
				$stat = $rcode;
			}
			push(@Response, $resp) if ($rcode !~ /^0/);	# XXX
		}
		print STDERR ">>> $resp\n" if ($Verbose);
		$Session_log = $Session_log.">>> $resp\n" if ($logging);
		last if ($resp =~ /^\.$/);
	} while ($resp =~ /^...-/ || $resp =~ /^[^1-9]/);
	return 0 if ($stat =~ /^[23]../);
	return 1 if ($stat =~ /^4../);
	return -1;
}

##### SEND A MESSAGE WITH SMTP/NNTP #####
#
# send_message(news_flag, split_flag)
#	news_flag: news mode if true
#	split_flag: splitting into multiple messages with "partial" format
#			is required if true
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub send_message {
	local ($news_flag, $split) = @_;
	local ($normal, $bcc, $i, $rcode);

	if ($news_flag) {
		if ($split) {
			for ($i = 1; $i <= $split; $i++) {
				sleep($Partial_sleep) if ($i > 1);
				$rcode = &nntp_transaction($i, $split);
				return $rcode if ($rcode);
			}
		} else {
			$rcode = &nntp_transaction(0, 0);
			return $rcode if ($rcode);
		}
		# XXX should be controlable? --- yes, of course!
#		&add_header(0, "X-NNTP-Posting-Status",
#			"posting successful via $Cur_server");
		print STDERR "posting succeeded.\n" if ($Verbose);
	}

	# header management only for SMTP message
	if (!&header_value("To")
	 && !&header_value("Cc")
	 && !&header_value("Resent-To")
	 && !&header_value("Resent-Cc")
	 && !&header_value("Apparently-To")) {
		unless ($Show_Rcpts_Header) {
			&add_header(0, "To", "undisclosed-recipients:;");
		} else {
			foreach $rec (@Recipients) {
				if ($rec =~ /<(.+)>/) {
					&add_header(0, "To", $1);
				}
			}
		}
	}

	foreach $rec (@Recipients) {
		if ($rec =~ /<.+>/) {
			$normal = 1;
		} else {
			$bcc = 1;
		}
	}

	if ($normal) {
		if ($split) {
			for ($i = 1; $i <= $split; $i++) {
				sleep($Partial_sleep) if ($i > 1);
				$rcode = &smtp_transaction(0, $i, $split);
				return $rcode if ($rcode);
			}
		} else {
			$rcode = &smtp_transaction(0, 0, 0);
			return $rcode if ($rcode);
		}
	}
	if ($bcc) {
		if ($split) {
			for ($i = 1; $i <= $split; $i++) {
				sleep($Partial_sleep) if ($i > 1);
				$rcode = &smtp_transaction(1, $i, $split);
				return $rcode if ($rcode);
			}
		} else {
			$rcode = &smtp_transaction(1, 0, 0);
			return $rcode if ($rcode);
		}
	}
	print STDERR "delivery succeeded.\n" if ($Verbose);
	return 0;
}

##### SMTP SESSION OPENING #####
#
# smtp_open(log_flag)
#	log_flag: conversations are saved in $Session_log if true
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub smtp_open {
	local ($logging) = @_;
	local ($rc, $rsp);
	@Status =();
	if ($Smtp_opened) {
		if (grep($Smtp_opened eq $_, @Smtp_servers)) {
			$Cur_server = $Smtp_cur_server;
			print STDERR "resetting SMTP session.\n"
				if ($Verbose);
			return 0 unless (&send_command($SMTPd, "RSET", $logging));
		}
		&smtp_close($SMTPd, 0, 0);
#		return 1;
	}
	return 1 unless ($SMTPd = &connect_server(*Smtp_servers, "smtp"));
	if ($logging) {
		$Session_log = $Session_log
			."Transcription of SMTP session follows:\n";
	}
	return $rc if ($rc = &send_command($SMTPd, "", $logging));
	$Esmtp_flag = 0;
	if (join('/', @Response) =~ /ESMTP/) {
		$Esmtp_flag = 1;
	}
	$Client_name = "localhost" unless ($Client_name);
	if ($Esmtp_flag) {
		unless (&send_command($SMTPd, "EHLO $Client_name", $logging)) {
			# ESMTP OK
			$rsp = join('/', @Response);
			$Esmtp_support_size = ($rsp =~ /SIZE/i) ? 1 : 0;
			$Esmtp_support_8bitmime = ($rsp =~ /8BITMIME/i) ? 1 : 0;
			$Esmtp_support_dsn = ($rsp =~ /DSN/i) ? 1 : 0;
			$Esmtp_support_verb = ($rsp =~ /VERB/i) ? 1 : 0;
			$Smtp_cur_server = $Cur_server;
			$Smtp_opened = $Cur_server_original_form;
			&send_command($SMTPd, "VERB", $logging)
				if ($Esmtp_support_verb && $Debug{"smtp"});
			return 0;
		}
		$Esmtp_flag = 0;
	}
	# fall back to traditional SMTP
	$rc = &send_command($SMTPd, "HELO $Client_name", $logging);
	return $rc if ($rc);
	$Smtp_cur_server = $Cur_server;
	$Smtp_opened = $Cur_server_original_form;
	&send_command($SMTPd, "VERB", $logging) if ($Debug{"smtp"});
	return 0;
}

##### SMTP SESSION CLOSING #####
#
# smtp_close(channel, savehist)
#	channel: socket descriptor to close
#	savehist: save result information into history file if true
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub smtp_close {
	local ($CHAN, $savehist, $next) = @_;
	if ($savehist) {
		&log_history($Esmtp_flag?"esmtp":"smtp",
			join(',', @Recipients), $next?"skipped":"failed");
	}
#	@Status =();
	return 0 unless ($CHAN);
	return 0 unless ($Smtp_opened);
	$Smtp_opened = 0;
	print STDERR "closing SMTP session.\n" if ($Verbose);
	return 1 if (&send_command($CHAN, "QUIT", 1));
	close($CHAN);
	return 0;
}

##### SMTP TRANSACTION MANAGEMENT #####
#
# smtp_transaction(bcc_flag, part, total)
#	bcc_flag: send message in "bcc" style
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub smtp_transaction {
	local ($bcc, $part, $total) = @_;
	local ($rc);
	do {
		$rc = &smtp_transact_sub($bcc, $part, $total);
		$rc = 1 if ($rc == -1 && $Smtp_fatal_next);
		if ($rc > 0 && $#Smtp_servers >= 0) {
			# close and try the next server if TEMPFAIL
			&smtp_close($SMTPd, 1, 1);
		} elsif ($rc < 0 || $rc > 0 && $#Smtp_servers < 0) {
			# log if fatal or the last server
			&smtp_close("", 1, 0);
		}
		if ($rc) {
			$Errlog .= $ErrTitle;
			$ErrTitle = "";
			$Errlog .= join("\n", @Response)."\n";
		}
		return -1 if ($rc < 0);
	} while ($rc != 0 && $#Smtp_servers >= 0);
	return $rc;
}

##### SMTP TRANSACTION MANAGEMENT SUBROUTUNE #####
#
# smtp_transact_sub(bcc_flag, part, total)
#	bcc_flag: send message in "bcc" style
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub smtp_transact_sub {
	local ($bcc, $part, $total) = @_;
	local ($i, $rc, $fail, @fatal, $msg_size);
	return $rc if ($rc = &smtp_open(1));
	if ($Esmtp_support_size) {
		$msg_size = &message_size($part);
		$rc = &send_command($SMTPd,
			"MAIL FROM:<$Sender> SIZE=$msg_size", 1);
	} else {
		$rc = &send_command($SMTPd, "MAIL FROM:<$Sender>", 1);
	}
	return $rc if ($rc);
	$fail = 0;
	for ($i = 0; $i <= $#Recipients; $i++) {
		$rec = $Recipients[$i];
		if ($bcc) {
			next if ($rec =~ /<.+>/);
			if ($Esmtp_support_dsn && $Dsn_success_report) {
				$rc = &send_command($SMTPd,
					"RCPT TO:<$rec> NOTIFY=SUCCESS", 1);
			} else {
				$rc = &send_command($SMTPd,
					"RCPT TO:<$rec>", 1);
			}
			push(@fatal, @Response) if ($rc);
			$fail = $rc if ($fail != -1 && $rc);
			$Status[$i] = $Response[0];
		} else {
			next if ($rec !~ /<.+>/);
			if ($Esmtp_support_dsn && $Dsn_success_report) {
				$rc = &send_command($SMTPd,
					"RCPT TO:$rec NOTIFY=SUCCESS", 1);
			} else {
				$rc = &send_command($SMTPd, "RCPT TO:$rec", 1);
			}
			push(@fatal, @Response) if ($rc);
			$fail = $rc if ($fail != -1 && $rc);
			$Status[$i] = $Response[0];
		}
	}
	if ($fail) {
		@Response = @fatal;
		return $fail;
	}
	return $rc if ($rc = &send_command($SMTPd, "DATA", 1));
	select ($SMTPd); $| = 0; select (STDOUT);
	$CRLF = "\r\n";
	if ($bcc) {
		return 1 unless (&put_mimed_bcc($SMTPd, 1, $part, $total));
	} else {
		if ($part == 0) {
			return 1 unless (&put_header($SMTPd, "all"));
			return 1 unless (&put_body($SMTPd, 1, 0));
		} else {
			return 1 unless (&put_mimed_partial($SMTPd, 1,
				$part, $total));
		}
	}
	select ($SMTPd); $| = 1; select (STDOUT);
	return $rc if ($rc = &send_command($SMTPd, ".", 1));
	&log_history($Esmtp_flag?"esmtp":"smtp",
		join(',', @Recipients), "sent");
	$Info .= "Delivery successful for the following recipient(s):\n";
	for ($i = 0; $i <= $#Recipients; $i++) {
		if ($Status[$i] =~ /^2/) {
			$Info .= "\t$Recipients[$i]\n";
		}
	}
	return 0;
}

##### SMTP TRANSACTION MANAGEMENT FOR RETURN ERROR NOTIFY #####
#
# smtp_transaction_for_error_notify()
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub smtp_transaction_for_error_notify {
	local ($rc);
	@Prev_Recipients = @Recipients;
	@Prev_Status = @Status;
	@Recipients = ($Sender);
	return $rc if ($rc = &smtp_open(0));
	return $rc if ($rc = &send_command($SMTPd, "MAIL FROM:<>", 0));
	return $rc if ($rc = &send_command($SMTPd, "RCPT TO:<$Sender>", 0));
	return $rc if ($rc = &send_command($SMTPd, "DATA", 0));
	select ($SMTPd); $| = 0; select (STDOUT);
	$CRLF = "\r\n";
	&put_mimed_error_notify($SMTPd, 1);
	select ($SMTPd); $| = 1; select (STDOUT);
	return $rc if ($rc = &send_command($SMTPd, ".", 0));
	&log_history($Esmtp_flag?"esmtp":"smtp",
		join(',', @Recipients), "sent");
	return 0;
}

##### NNTP SESSION OPENING #####
#
# nntp_open()
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub nntp_open {
	local ($rc);
	if ($Nntp_opened && grep($Nntp_opened eq $_, @Nntp_servers)){
		$Cur_server = $Nntp_cur_server;
		return 0;
	}
	return 1 unless ($NNTPd = &connect_server(*Nntp_servers, "nntp"));
	$Session_log = $Session_log."Transcription of NNTP session follows:\n";
	if ($rc = &send_command($NNTPd, "", 1)) {
		return $rc;
	}
	if ($Response[0] =~ /InterNetNews server INN/) {
		if (&send_command($NNTPd, "MODE reader", 1)) {
			return 1;
		}
	}
	$Nntp_cur_server = $Cur_server;
	$Nntp_opened = $Cur_server_original_form;
	return 0;
}

##### NNTP SESSION CLOSING #####
#
# nntp_close(channel, savehist)
#	channel: socket descriptor to close
#	savehist: save result information into history file if true
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub nntp_close {
	local ($CHAN, $savehist, $next) = @_;
	&log_history("nntp", $Newsgroups, $next?"skipped":"failed")
		if ($savehist);
	return 0 unless ($Nntp_opened);
	$Nntp_opened = 0;
	print STDERR "closing NNTP session.\n" if ($Verbose);
	return 1 if (&send_command($CHAN, "QUIT", 1));
	close($CHAN);
	return 0;
}

##### NNTP TRANSACTION MANAGEMENT #####
#
# nntp_transaction(part, total)
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub nntp_transaction {
	local ($part, $total) = @_;
	local ($rc);
	do {
		$rc = &nntp_transact_sub($part, $total);
		if ($rc) {
			$Errlog .= $ErrTitle;
			$Errlog .= join("\n", @Response)."\n";
			&nntp_close($NNTPd, 1, $#Nntp_servers >= 0);
			return -1 if ($rc < 0);
		}
	} while ($rc > 0 && $#Nntp_servers >= 0);
	return $rc;
}

##### NNTP TRANSACTION MANAGEMENT SUBROUTINE #####
#
# nntp_transact_sub(part, total)
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value:
#		 0: success
#		 1: recoverable error (should be retried)
#		-1: unrecoverable error
#
sub nntp_transact_sub {
	local ($part, $total) = @_;
	local ($rc);
	return $rc if ($rc = &nntp_open);
	return $rc if ($rc = &send_command($NNTPd, "POST", 1));
	return -1 if (grep(/^(435|437|440|441)/, @Response) > 0);
	select ($NNTPd); $| = 0; select (STDOUT);
	$CRLF = "\r\n";
	if ($part == 0) {
		return 1 unless (&put_header($NNTPd, "all"));
		return 1 unless (&put_body($NNTPd, 1, 0));
	} else {
		return 1 unless (&put_mimed_partial($NNTPd, 1, $part, $total));
	}
	select ($NNTPd); $| = 1; select (STDOUT);
	return $rc if ($rc = &send_command($NNTPd, ".", 1));
	&log_history("nntp", $Newsgroups, "sent");
	return 0;
}

##### EXTRACT AN ADDRESS FROM AN ADDRESS EXPRESSION #####
#
# extract_addr(address)
#	address: address in any style
#	return value: pure address portion
#
sub extract_addr {
	local ($addrin) = @_;
	local ($addrout);
	$addrin =~ s/\n\s+//g;
	($addrout) = &fetch_addr($addrin, 0, 1);	# strip ()-style comment
	return $addrout;
}

##### REPLACE THE ADDRESS IN AN ADDRESS EXPRESSION #####
#
# replace_addr(expr, old, new)
#	expr:
#	old:
#	new:
#	return value: replaced expression
#
sub replace_addr {
	local ($expr, $old, $new) = @_;

	if ($expr =~ /$old.*$old/) {
		# multiple appearance
		return $b;	# XXX drop comment portion
	}
	$expr =~ s/$old/$new/;
	return $expr if (&extract_addr($expr) eq $new);
	return $b;	# XXX drop comment portion
}

##### PARSE RECIPIENT LIST #####
#
# sub parse_rcpt(bcc_flag, addr_list)
#	bcc_flag:
#		 1 = BCC distination
#		 0 = normal distination
#		-1 = parse only
#	addr_list: address list string (concatinated with ",")
#	return value: number of addresses in the list
#
sub parse_rcpt {
	local ($bcc_flag, $addr_list) = @_;
	local ($cnt, $addr);
	$addr_list =~ s/^\s+//;
	$addr_list =~ s/\n\s*//g;	# XXX
	return 0 if ($addr_list eq "");
	$cnt = 0;
	while ("$addr_list" ne "") {
		($addr, $addr_list) = &fetch_addr($addr_list, 0, 1);
		if ($addr =~ /^.+:[^;]*;$/) {	# YYY
			&expn_group($bcc_flag, $addr) if ($bcc_flag >= 0);
		} else {
			&add_to_rcpt($bcc_flag, $addr) if ($bcc_flag >= 0);
		}
		$cnt++;
		$addr_list =~ s/^\s*//;
	}
	return $cnt;
}

##### GET FIRST ADDRESS #####
#
# sub fetch_addr(addr_list, with_comment, extract)
#	addr_list: address list string (concatinated with ",")
#	with_comment: need comment portion
#	extract: extract address portion
#	return values: (first, rest)
#	  first: the first address in the list
#	  rest: rest of address in the list
#
sub fetch_addr {
	local ($addrin, $with_comment, $extract) = @_;
	local ($addrout, $inquote, $incomment, $c, $addrquote);
	local ($groupcolon, $groupsyntax);
	$inquote = 0;
	$incomment = 0;
	$addrquote = 0;
	$groupcolon = 0;
	print "First addr (in): $addrin\n" if ($Debug{"addr"});
	while ("$addrin" ne "") {
		$c = substr($addrin, 0, 1);
		$addrin = substr($addrin, 1);
		if ($inquote) {
			$addrout .= $c;
			if ($c eq '"') {
				$inquote = 0;
			} elsif ($c eq "\\") {
				$addrout .= substr($addrin, 0, 1);
				$addrin = substr($addrin, 1);
			}
			next;
		} elsif ($incomment) {
			$addrout .= $c if ($with_comment);
			if ($c eq "(") {
				$incomment++;
			} elsif ($c eq ")") {
				$incomment--;
			} elsif ($c eq "\\") {
				$addrout .= substr($addrin, 0, 1)
					if ($with_comment);
				$addrin = substr($addrin, 1);
			}
			next;
		} elsif ($c eq '"') {
			$inquote = 1;
		} elsif ($c eq "(") {
			$incomment++;
			next unless ($with_comment);
		} elsif ($c eq ")") {
			$Errlog .= "Unbalanced comment parenthesis "
			  ."('(', ')').\n";
			&error_exit;
		} elsif ($c eq "<") {
			$addrquote++;
		} elsif ($c eq ">") {
			$addrquote--;
		} elsif ($c eq "\\") {
			$addrout .= $c;
			$c = substr($addrin, 0, 1);
			$addrin = substr($addrin, 1);
		} elsif ($c eq ":") {
			$addrout .= $c;
			$c = substr($addrin, 0, 1);
			$addrin = substr($addrin, 1);
			$groupcolon = 1 if ($c ne ":");
		} elsif ($c eq ";") {
			if ($groupcolon) {
				$groupcolon = 0;
				$groupsyntax = 1;
			}
		} elsif ($c eq ",") {
			last unless ($groupcolon);
		}
		$addrout .= $c;
	}
	print "First addr (out): $addrout\n" if ($Debug{"addr"});
	if ($addrquote) {
		$Errlog .= "Unbalanced address quotes ('<', '>').\n";
		&error_exit;
	}
	if ($inquote) {
		$Errlog .= "Unbalanced quotes ('\"').\n";
		&error_exit;
	}
	if ($incomment) {
		$Errlog .= "Unbalanced comment parenthesis ('(', ')').\n";
		&error_exit;
	}
	if ($extract && !$groupsyntax) {
		$addrout =~ s/.*<([^<>]+)>.*/$1/;
		$addrout =~ s/^\s+//;
		$addrout =~ s/\s+$//;
	}
	return ($addrout, $addrin);
}

##### ADD AN ADDRESS TO RECIPIENT LIST #####
#
# add_to_rctp(bcc_flag, addr)
#	bcc_flag: register with "bcc" tag
#	addr: an address to be registered
#	return value: none
#
sub add_to_rcpt {
	local ($bcc_flag, $addr) = @_;
	local ($rec, $a);
	$addr = &extract_addr($addr);
	return unless ($addr);
	if ($addr =~ /^\@MYSELF\@/i || $addr =~ /^\@ME\@/i) {
		$addr = $Sender;
	}
	if ($addr !~ /[$Address_operators]/o) {
		if (($a = &alias_lookup($addr)) ne "") {
			&parse_rcpt($bcc_flag, $a);
			return;
		} elsif ($Default_to_domain_name) {
			$addr .= "\@$Default_to_domain_name";
		}
	}
	if ($a = &completion($addr)) {
		$addr = $a;
	}
	foreach $rec (@Recipients) {
		if ($bcc_flag) {
			return if ($rec eq $addr);
		} else {
			return if ($rec eq "<$addr>");
		}
	}
	print STDERR "Adding to recipients: <$addr>\n" if ($Debug{"addr"});
	$addr = "<$addr>" unless ($bcc_flag);
	push (@Recipients, $addr);
}

##### EXPAND GROUP/LIST SYNTAX #####
#
# expn_group(bcc_flag, group_syntax_address)
#	bcc_flag: need "bcc" style message format if true
#	group_syntax_address: an gruop:addrs; style address to be expanded
#	return value: none
#
sub expn_group {
	local ($bcc_flag, $group_expression) = @_;
	local ($rest, @mboxes, $rec);
#	return if ($group_expression !~ /:.*;$/);
	return if ($group_expression !~ /:[^;]*;/);
	print STDERR "expanding $group_expression\n" if ($Debug{"addr"});
#	local ($group_name);
#	$group_name = $group_expression;
#	$group_name =~ s/:.*/:;/;
	$rest = $group_expression;
	$rest =~ s/.+:([^;]*);$/$1/;	# YYY
	@mboxes = split (',', $rest);
	foreach $rec (@mboxes) {
		if ($rec =~ /^\// || $rec =~ /^\~/) {
			&expn_rcpt_list($bcc_flag, $rec);
		} else {
			&add_to_rcpt($bcc_flag, $rec);
		}
	}
#	return $group_name;
}

##### INCLUDE RECIPIENT LIST FILE #####
#
# expn_rcpt_list(bcc_flag, include_file)
#	bcc_flag: need "bcc" style message format if true
#	include_file: path of an address list file to be included
#	return value: none
#
sub expn_rcpt_list {
	local ($bcc_flag, $include_file) = @_;
	local ($my_handle);
	local ($file) = &file_path($include_file, "", "", 0);
	if ($Include_handle) {
		$Include_handle++;
	} else {
		$Include_handle = "inc00";
	}
	$my_handle = $Include_handle;
	if (open($my_handle, "<$file")) {
		while (<$my_handle>) {
			chop if (/\n$/);
			print STDERR "reading $file: $_\n"
				if ($Debug{"include"});
			next if (/^#/);
			s/\s#@#.*//;
			s/\s*$//;
			if (/^\s*:include:/) {
				s/^\s*:include://;
				&expn_rcpt_list($bcc_flag, $_);
			} elsif (/^\s*\//) {
				$Errlog .= "Mail to file not supported: $_\n";
				&error_exit;
			} elsif (/^\s*\|/ || /^\s*"\s*\|/) {
				$Errlog .= "Mail to program not supported: $_\n";
				&error_exit;
			}
#			&add_to_rcpt($bcc_flag, $_);
			&parse_rcpt($bcc_flag, $_);
		}
		close($my_handle);
	} else {
		$Errlog .= "List file $file not found\n";
		&error_exit;
	}
}

##### READ HEADER #####
#
# read_header(channel, dist_append_flag)
#	channel: socket/file descriptor to write out
#	dist_append_flag: as redistribution headers if true
#	return value: none
#
sub read_header {
	local ($CHAN, $dist_append) = @_;
	local ($inheader, $line, $_);
	$First_body_line = "";
	$inheader = 1;
	$line = "";
	$_ = <$CHAN>;
	unless ($_) {
		$inheader = 0;
		$First_body_line = "" unless ($dist_append);
	} elsif (!$Smtp_input_mode && $_ =~ /^From /) {
		$_ = <$CHAN>;		# skip UNIX From_ line
	}
	while ($inheader) {
		$line = $_;
		if ($Draft_message && $line =~ /^-+$/) {
			$inheader = 0;
			$First_body_line = "\n" unless ($dist_append);
			$line = "";
			last;
		}
		if ($line !~ /^[\w-]+:/) {
			$inheader = 0;
			$First_body_line = $line unless ($dist_append);
			$line = "";
			last;
		}
		if ($dist_append) {
			if ($line !~ /^Resent-To:/i
			 && $line !~ /^Resent-Cc:/i
			 && $line !~ /^Resent-Bcc:/i
			 && $line !~ /^Resent-Dcc:/i
			 && $line !~ /^Resent-Fcc:/i
			 && $line !~ /^Resent-Reply-To:/i
			 && $line !~ /^Resent-Sender:/i
			 && $line !~ /^Resent-From:/i) {
				$line =~ /^[\w-]+:/;
				$Errlog .= "Remove $& header\n";
				&error_exit;
			}
		}
		while (<$CHAN>) {
			if (/^[ \t]/) {
				$line .= $_;
			} else {
				last;
			}
		}
		push (@Header, $line) if ($line);
	}
}

##### GET VALUE OF SPECIFIED HEADER LINE #####
#
# header_value(field)
#	field: field name of which value needed
#	return value: value for specified field OR null
#
sub header_value {
	local ($field_name) = @_;
	local ($line);
	foreach $line (@Header) {
		if ($line =~ /^$field_name:\s*/i) {
			local ($val) = $';
			$val =~ s/\s*$//;
			return $val;
		}
	}
	return "";
}

##### ADD A HEADER LINE #####
#
# add_header(replace_flag, field_name, field_value)
#	replace_flag: old headers are deleted if true
#	field_name: field name to be entered
#	field_value: field value to be entered with
#	return value: none
#
sub add_header {
	local ($replace_flag, $field_name, $field_value) = @_;
	local ($i);
	$field_value .= "\n" if ($field_value !~ /\n$/);
	print STDERR "adding header line> $field_name: $field_value"
		if ($Debug{"header"});
	if ($replace_flag) {
		for ($i = 0; $i <= $#Header; $i++) {
			if ($Header[$i] =~ /^$field_name:/i) {
				$Header[$i] = $field_name.": ".$field_value;
				return;
			}
		}
	}
	push (@Header, $field_name.": ".$field_value);
}

##### KILL SPECIFIED HEADER LINES #####
#
# kill_header(field_name, leave_first)
#	field_name: field name to be deleted
#	leave_first: leave the first appeared header line if true
#	return value: none
#
sub kill_header {
	local ($field_name, $leave_first) = @_;
	local ($i);
	for ($i = 0; $i <= $#Header; $i++) {
		if ($Header[$i] =~ /^$field_name:/i) {
			if ($leave_first) {
				$leave_first = 0;
				next;
			}
			print STDERR "killing $Header[$i]"
				if ($Debug{"header"});
			$Header[$i] = " KILLED ".$Header[$i];
		}
	}
}

##### KILL EMPTY HEADER LINES #####
#
# kill_empty_header()
#	return value: none
#
sub kill_empty_header {
	local ($i);
	for ($i = 0; $i <= $#Header; $i++) {
		if ($Header[$i] =~ /^[\w-]+:\s*$/) {
			print STDERR "killing $Header[$i]"
				if ($Debug{"header"});
			$Header[$i] = " KILLED ".$Header[$i];
		}
	}
}

##### REWRITE HEADER ON ADDRESSES #####
#
# rewrite_header()
#	return value: none
#
sub rewrite_header {
	local ($i, $e, $_);
	$e = $#Header;
	for ($i = 0; $i <= $e; $i++) {
		$_ = $Header[$i];
		if (/^(To):\s*/i
		 || /^(Cc):\s*/i
		 || /^(Bcc):\s*/i
		 || /^(Dcc):\s*/i
		 || /^(Resent-To):\s*/i
		 || /^(Resent-Cc):\s*/i
		 || /^(Resent-Bcc):\s*/i
		 || /^(Resent-Dcc):\s*/i) {
			&add_header(0, " ORIGINAL ".$1, $');
			$Header[$i] = $1.": "
				.&rewrite_addr_list(0, $', !$Obey_MTA_domain);
		} elsif (/^(From):\s*/i
		      || /^(Resent-From):\s*/i
		      || /^(Reply-To):\s*/i
		      || /^(Resent-Reply-To):\s*/i
		      || /^(Errors-To):\s*/i
		      || /^(Return-Receipt-To):\s*/i) {
			&add_header(0, " ORIGINAL ".$1, $');
			$Header[$i] = $1.": "
				.&rewrite_addr_list(1, $', !$Obey_MTA_domain);
		} elsif (/^Newsgroups:/i) {
			# strip spaces off
			local ($newsgroups) = $';
			$newsgroups =~ s/[ \t]//g;
			$Header[$i] = "Newsgroups: $newsgroups";
		} elsif (/^([\w-]+):(\S)/) {
			$Header[$i] = "$1: $2$'";
		}
	}
}

##### REWRITE HEADER FOR RESEND #####
#
# rewrite_resend_header()
#	return value: none
#
sub rewrite_resend_header {
	local ($i, $_);
	for ($i = 0; $i <= $#Header; $i++) {
		$_ = $Header[$i];
		if (/^Resent-/i) {
			$Header[$i] = "Prev-$Header[$i]";
		}
	}
}

##### REWRITE ADDRESS LIST #####
#
# rewrte_addr_list(sender_flag, address_list, append_default)
#	sender_flag: rewrite as a sender's address
#	addresslist: address list to be rewrited
#	append_default: append default domain name for local names if true
#	return value: rewritten addresses
#
sub rewrite_addr_list {
	local ($sender_flag, $addr_list, $def_append) = @_;
	local ($line, $ret, $addr, $a, $b);
	$addr_list =~ s/^\s+//;
	$addr_list =~ s/\s+$//;
#	$addr_list =~ s/\n[ \t]+/ /g;	# XXX
	while ("$addr_list" ne "") {
		($addr, $addr_list) = &fetch_addr($addr_list, 1, 0);
		$a = &extract_addr($addr);
		if ($a =~ /^(.+):[^;]*;$/) {	# YYY
#			&expn_group(0, $&);
			&add_header(0, $Resend_prefix."Dcc", $&);
			$addr = $1.":;";
		} else {
			if ($addr =~ /^\@MYSELF\@/i || $addr =~ /^\@ME\@/i) {
				$addr = $Sender;
			}
			if ($a !~ /[$Address_operators]/
			 && ($b = &alias_lookup($a)) ne "") {
				if ($addr_list) {
					$addr_list = $b.",".$addr_list;
				} else {
					$addr_list = $b;
				}
				next;
			}
			if ($a !~ /[$Address_operators]/o) {
				if ($sender_flag && $def_append
				 && $Default_from_domain_name) {
					$b = "$a\@$Default_from_domain_name";
					$addr = &replace_addr($addr, $a, $b);
				} elsif ($def_append
				 && $Default_to_domain_name) {
					$b = "$a\@$Default_to_domain_name";
					$addr = &replace_addr($addr, $a, $b);
				}
			} elsif ($b = &completion($a)) {
				$addr = &replace_addr($addr, $a, $b);
			}
		}
		$line .= "," if ($line);
		printf STDERR "rewrite: $a => $addr\n" if ($Debug{"alias"});
		$line = &hdr_cat($line, $addr, "any");
		$addr_list =~ s/^\s*//;
	}
	return $line."\n";
}

##### HEADER CONCATINATION #####
#
# hdr_cat(str1, str2, space)
#	str1: a preceeding header string
#	str2: a header string to be appended to str1
#	space: separatig space
#	return value: a concatinated header string
#
sub hdr_cat {
	local ($str1, $str2, $space) = @_;
	if ($str1 eq "") {
		return $str2 if ($space eq "" || $space eq "any");
		return $space.$str2;
	}
	if ($str1 =~ /\n[\t ]+$/) {
		return $str1.$str2 if ($space eq "" || $space eq "any");
		return $str1.$space.$str2;
	}
#	if ($space =~ /\n/) {
#		return $str1.$space.$str2;
#	}
	$str1 =~ /[^\n]*$/;
	local ($l1) = length($&);
	$str2 =~ /^[^\n]*/;
	local ($l2) = length($&);
	if (!$NoFolding && ($l1 + length($space) + $l2 + 1 > $Folding_length)) {
		$space = "\t" if ($space eq "any");
		if ($space ne "") {
			return $str1."\n".$space.$str2;
		} else {
			return $str1."\n\t".$str2;
		}
	}
	$space = " " if ($space eq "any");
	return $str1.$space.$str2;
}

##### PICK UP RECIPIENTS FROM HEADER #####
#
# rcpt_pickup(resend_flag, news_only_flag)
#	resend_flag: pickup addresses for redistributing mode
#	news_only_flag: do not pickup destination addresses for news mode
#	return value: none
#
sub rcpt_pickup {
	local ($resend_flag, $news_only_flag) = @_;
	local ($line);
	foreach $line (@Header) {
		if ($line =~ /^Dcc:/i) {
			&parse_rcpt(0, $');
		} elsif ($line =~ /^Bcc:/i) {
			&parse_rcpt($Mime_bcc, $');
		} elsif ($line =~ /^Fcc:/i) {
			$Fcc_folder = $';
			$Fcc_folder =~ s/\s//g;
		} elsif (!$news_only_flag) {
			unless ($resend_flag) {
				if ($line =~ /^To:/i
				 || $line =~ /^Cc:/i) {
					&parse_rcpt(0, $');
				}
			} else {
				if ($line =~ /^Resent-To:/i
				 || $line =~ /^Resent-Cc:/i) {
					&parse_rcpt(0, $');
				}
			}
		}
	}
}

##### PUT HEADER TO SMTP CHANNEL #####
#
# put_header(channel, field_selection)
#	channel: socket/file descriptor to write out
#	field_selection: ext/int header specification in partial message mode
#	return value:
#		0: failed
#		1: success
#
sub put_header {
	local ($CHAN, $sel) = @_;
	local ($l, $line, $i, $s);
	hdr: foreach $l (@Header) {
		$line = $l;
		next if ($line =~ /^ KILLED /);
		if ($line =~ /^ ORIGINAL /) {
			next if ($sel ne "original");
			$line =~ s/^ ORIGINAL //
				if ($line =~ /^ ORIGINAL Dcc:/i);
			next if ($line =~ /^ ORIGINAL /);
		}
		if ($sel =~ /^partial:/) {
			if ($line =~ /^Mime-Version:/i
			 || $line =~ /^Message-Id:/i
			 || $line =~ /^Encrypted:/i
			 || $line =~ /^Lines:/i
			 || $line =~ /^Content-/i) {
				next if ($sel =~ /:ext$/);
			} else {
				next if ($sel =~ /:int$/);
			}
		}
		if ($CHAN =~ /smtp/i) {
			foreach $i (@Del_headers_on_mail) {
				next hdr if ($line =~ /^$i:/i);
			}
			$line =~ s/Newsgroups:/X-Newsgroups:/i;
		}
		if ($CHAN =~ /nntp/i) {
			foreach $i (@Del_headers_on_news) {
				next hdr if ($line =~ /^$i:/i);
			}
			if ($Obey_MTA_domain
			 && $line =~ /^(From|Sender|Reply-To):\s*/i) {
				$line = "$&".&rewrite_addr_list(1, $', 1);
			}
			$line =~ s/^Sender:/Originator:/i;
		}
		$line .= "\n" if ($line !~ /\n$/);
		$line =~ s/\r?\n/\r\n/g if ($CRLF eq "\r\n");
		printf STDERR "put_header: putting line > $line\n"
				if ($Debug{"put"});
		return 0 unless (print($CHAN "$line"));
		print STDERR "|$line" if ($Debug{"header"});
	}
	if ($CHAN =~ /nntp/i && !&header_value("Path")) {
		return 0 unless (print($CHAN "Path: $Login$CRLF"));
	}
	printf STDERR "put_header: no error\n" if ($Debug{"put"});
	return 1;
}

##### READ BODY #####
#
# read_body(channel, dot_terminate)
#	channel: socket/file descriptor to write out
#	dot_terminate: terminating dot protocol is used if true
#	return value: none
#
sub read_body {
	local ($CHAN, $dot_terminate) = @_;
	local ($_);
	@Body = ();
	if ($dot_terminate) {
		return if ($First_body_line =~ /^\.[\r\n]/);
		$First_body_line =~ s/^\.\././;
	}
	if ($First_body_line) {
		if ($First_body_line ne "\n") {
			push (@Body, "\n");
		}
		push (@Body, $First_body_line);
		while (<$CHAN>) {
			if ($dot_terminate) {
				last if (/^\.[\r\n]/);
				s/^\.\././;
			}
			push (@Body, $_);
		}
		$First_body_line = "\n";	# XXX
	}
}

##### CONVERT BODY INTO QUOTED-PRINTABLE ENCODING #####
#
# body_qp_encode(content)
#	content: pointer to body content line list
#	return value: none
#
sub body_qp_encode {
	local (*content) = @_;
	local ($line, $i, $c, $pos);
	for ($i = 0; $i <= $#content; $i++) {
		$line = $content[$i];
		$line .= "\n" if ($line !~ /\n$/);	# XXX
		$line =~ s/([\000-\010\013-\037=\177-\377])/sprintf("=%02X", unpack ("C", $&))/ge;
		$line =~ s/ \n$/=20\n/;
		$line =~ s/\t\n$/=09\n/;
		$line =~ s/^\.\n$/=2e\n/;
		$line =~ s/^From /From=20/;
		while (!$NoFolding && (length($line) > $Folding_length+3)) {
			# XXX line splitting
			for ($pos = $Folding_length; $pos < $Folding_length+3;
			  $pos++) {
				last if (substr($line, $pos, 1) eq "=");
			}
			splice(@content, $i, 0, substr($line, 0, $pos)."=");
			$line = substr($line, $pos);
			$i++;
		}
		$content[$i] = $line;
	}
}

##### CONVERT BODY INTO BASE64 ENCODING #####
#
# body_base64_encode(content)
#	content: pointer to body content line list
#	return value: none
#
sub body_base64_encode {
	local (*content) = @_;
	local ($line, $i, @Body_tmp);
	$line = "";
	for ($i = 0; $i <= $#content; $i++) {
		$line .= $content[$i];
		$line .= "\n" if ($line !~ /\n$/);
#		$line =~ s/\r?\n?$/\r\n/;
		next if (length($line) < 54 && $i <= $#content);
		push(@Body_tmp, &base64encode(substr($line, 0, 54)));
		$line = substr($line, 54);
	}
	while ("$line" ne "") {
		push(@Body_tmp, &base64encode(substr($line, 0, 54)));
		$line = substr($line, 54);
	}
	@content = @Body_tmp;
	@Body_tmp = ();
}

## if ISO2022JP
##### CONVERT BODY INTO ISO-2022-JP ENCODING #####
#
# body_convert_iso2022jp(content)
#	content: pointer to body content line list
#	return value: none
#
sub body_convert_iso2022jp {
	local (*content) = @_;
	local ($i);
	for ($i = 0; $i <= $#content; $i++) {
		$content[$i] = &conv_iso2022jp($content[$i]);
	}
}
## endif

##### PUT BODY TO SMTP CHANNEL #####
#
# put_body(channel, dot_terminate, part)
#	channel: socket/file descriptor to write out
#	dot_terminate: terminating dot protocol is used if true
#	part: part number to be sent in partial message mode
#	return value:
#		0: failed
#		1: success
#
sub put_body {
	local ($CHAN, $dot_terminate, $part) = @_;
	local ($start, $end, $line, $i);
	if ($part == 0) {
		$start = 0;
		$end = $#Body;
	} else {
		$start = $Lines_to_partial * ($part - 1);
		$end = $Lines_to_partial * $part - 1;
		$end = $#Body if ($end > $#Body);
	}
	for ($i = $start; $i <= $end; $i++) {
		$line = $Body[$i];
		$line .= "\n" if ($line !~ /\n$/);
		$line =~ s/\r?\n/\r\n/g if ($CRLF eq "\r\n");
		$line =~ s/^\./../ if ($dot_terminate);
		printf STDERR "put_body: putting > $line" if ($Debug{"put"});
		return 0 unless (print($CHAN "$line"));
#		print STDERR "$line";
	}
	printf STDERR "put_body: no error\n" if ($Debug{"put"});
	return 1;
}

##### GENERATE MIMED-BCC #####
#
# put_mimed_bcc(channel, dot_terminate, part, total)
#	channel: socket/file descriptor to write out
#	dot_terminate: terminating dot protocol is used if true
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value: (XXX)
#		0: failed
#		1: success
#
sub put_mimed_bcc {
	local ($CHAN, $dot_terminate, $part, $total) = @_;
	local ($subj);
	return 0 unless (print $CHAN "From: $Sender_line$CRLF");
	print $CHAN "To: blind-copy-recipients:;$CRLF";
	print $CHAN "X-Dispatcher: $Version$CRLF";
	if ($subj = &header_value("Subject")) {
		printf $CHAN "Subject: Bcc: %s$CRLF", $subj;
	} else {
		print $CHAN "Subject: Blind Carbon Copy$CRLF";
	}
	if ($Generate_message_id) {
		$Cur_mid = &gen_message_id(0);
		printf $CHAN "Message-Id: %s$CRLF", $Cur_mid;
		$First_part_mid = $Cur_mid if ($part == 1);
	}
	printf $CHAN "Date: %s$CRLF", &gen_date(1) if ($Generate_date);
	if ($part) {
		$bcc_mid = &gen_message_id(0) unless ($bcc_mid);
		print $CHAN "Mime-Version: 1.0$CRLF";
		print $CHAN "Content-Type: Message/partial;$CRLF";
		printf $CHAN "\tid=\"%s\"; number=%d; total=%d$CRLF",
			$bcc_mid, $part, $total;
		print $CHAN "Content-Description: part $part of $total$CRLF";
		printf $CHAN "References: %s$CRLF", $First_part_mid
			if ($part > 1);
		print $CHAN "$CRLF";
		printf $CHAN "Message-Id: %s$CRLF", $bcc_mid if ($part == 1);
	}
	if ($part <= 1) {
		print $CHAN "Mime-Version: 1.0$CRLF";
		print $CHAN "Content-Type: Message/rfc822$CRLF";
		print $CHAN "$CRLF";

		return 0 unless (&put_header($CHAN, "all"));
	}
	return &put_body($CHAN, $dot_terminate, $part);
}

##### GENERATE PARTIAL/MIME #####
#
# put_mimed_partial(channel, dot_terminate, part, total)
#	channel: socket/file descriptor to write out
#	dot_terminate: terminating dot protocol is used if true
#	part: part number to be sent in partial message mode
#	total: total number of partial messages
#	return value: (XXX)
#		0: failed
#		1: success
#
sub put_mimed_partial {
	local ($CHAN, $dot_terminate, $part, $total) = @_;
	return 0 unless (&put_header($CHAN, "partial:ext"));
	if ($Generate_message_id) {
		$Cur_mid = &gen_message_id($part);
		printf $CHAN "Message-Id: %s$CRLF", $Cur_mid;
		$First_part_mid = $Cur_mid if ($part == 1);
	}
	print $CHAN "Mime-Version: 1.0$CRLF";
	print $CHAN "Content-Type: Message/partial;$CRLF";
	printf $CHAN "\tid=\"%s\"; number=%d; total=%d$CRLF",
		&header_value("Message-Id"), $part, $total;
	print $CHAN "Content-Description: part $part of $total$CRLF";
	printf $CHAN "References: %s$CRLF", $First_part_mid if ($part > 1);
	print $CHAN "$CRLF";

	if ($part == 1) {
		return 0 unless (&put_header($CHAN, "partial:int"));
	}
	return &put_body($CHAN, $dot_terminate, $part);
}

##### GENERATE MIMED ERROR NOTIFY #####
#
# put_mimed_error_notify(channel, dot_terminate)
#	channel: socket/file descriptor to write out
#	dot_terminate: terminating dot protocol is used if true
#	return value: (XXX)
#		0: failed
#		1: success
#
sub put_mimed_error_notify {
	local ($CHAN, $dot_terminate) = @_;
	local ($subj);
	return 0 unless (print $CHAN "To: $Sender_line$CRLF");
	print $CHAN "From: MAILER-DAEMON$CRLF";
	print $CHAN "X-Dispatcher: $Version$CRLF";
	if ($subj = &header_value("Subject")) {
		printf $CHAN "Subject: Returned message: %s$CRLF", $subj;
	} else {
		print $CHAN "Subject: Returned message$CRLF";
	}
	if ($Generate_message_id) {
		$Cur_mid = &gen_message_id(0);
		printf $CHAN "Message-Id: %s$CRLF", $Cur_mid;
	}
	printf $CHAN "Date: %s$CRLF", &gen_date(1) if ($Generate_date);
	print $CHAN "Mime-Version: 1.0$CRLF";
	print $CHAN "Content-Type: Multipart/report;$CRLF";
	print $CHAN "\treport-type=delivery-status;$CRLF";
	$boundary = &gen_message_id(0);
	$boundary =~ y/<@>/-_-/;
	print $CHAN "\tboundary=\"$boundary\"$CRLF";
	print $CHAN "Precedence: junk$CRLF";
	print $CHAN "$CRLF";

	print $CHAN "This is a MIME-encapsulated message$CRLF$CRLF";
	print $CHAN "--$boundary$CRLF";
	print $CHAN "$CRLF";
	print $CHAN "Your message was not deliverd successfully.$CRLF";
	if ($Errlog) {
		print $CHAN "$CRLF";
		print $CHAN "Reason:$CRLF";
		print $CHAN "$Errlog$CRLF";
	}
	if ($Info) {
		print $CHAN "$CRLF";
		print $CHAN "$Info$CRLF";
	}
	if ($Session_log) {
		print $CHAN "$CRLF";
		print $CHAN "$Session_log$CRLF";
	}
	if ($#Prev_Recipients >= 0) {
		local ($i);

		print $CHAN "--$boundary$CRLF";
		print $CHAN "Content-Type: message/delivery-status$CRLF";
		print $CHAN "$CRLF";
		print $CHAN "Reporting-MTA: dns; $Hostname$CRLF";
#		print $CHAN "Arrival-Date: (startup time)$CRLF";

		for ($i = 0; $i <= $#Prev_Recipients; $i++) {
			print $CHAN "$CRLF";
			print $CHAN "Final-Recipient: rfc822; "
				."$Prev_Recipients[$i]$CRLF";
			if ($Prev_Status[$i] =~ /^2/) {
#				print $CHAN "Action: relayed$CRLF";
				print $CHAN "Action: failure$CRLF";
				print $CHAN "Status: 5.1.5$CRLF";	# XXX
			} else {
				print $CHAN "Action: failure$CRLF";
				print $CHAN "Status: 5.1.1$CRLF";	# XXX
			}
			print $CHAN "Remote-MTA: $Cur_server$CRLF";
			print $CHAN "Diagnostic-Code: smtp; "
				."$Prev_Status[$i]$CRLF";
		}
	}
	if ($#Header >= 0 || $#Body >= 0) {
		print $CHAN "--$boundary$CRLF";
		print $CHAN "Content-Type: Message/rfc822$CRLF";
		print $CHAN "$CRLF";
		&put_header($CHAN, "original");
		&put_body($CHAN, $dot_terminate, $part);
		print $CHAN "$CRLF";	# a linebreak is needed here
	}
	print $CHAN "--$boundary--$CRLF";
	return 1;
}

##### OPEN ALIAS FILES #####
#
# open_aliases()
#	return value: none
#
sub open_aliases {
	local ($file, $ali, $handle);
	$handle = "ali00";
	foreach $ali (split(',', $Mail_aliases)) {
		$file = &file_path($ali, "", "", 0);
		if (open($handle, "<$file")) {
			push (@Mail_aliases, $handle);
			print STDERR "alias: mail alias file $file is open "
			  ."with handle $handle.\n" if ($Debug{"alias"});
			$handle++;
		} else {
			print STDERR "can't open mail-aliases file: $file\n"
				if ($Verbose);
		}
	}
	foreach $ali (split(',', $Host_aliases)) {
		$file = &file_path($ali, "", "", 0);
		if (open($handle, "<$file")) {
			push (@Host_aliases, $handle);
			print STDERR "alias: host alias file $file is open "
			  ."with handle $handle.\n" if ($Debug{"alias"});
			$handle++;
		} else {
			print STDERR "can't open host-aliases file: $file\n"
				if ($Verbose);
		}
	}
}

##### CLOSE ALIAS FILES #####
#
# close_aliases()
#	return value: none
#
sub close_aliases {
	local ($handle);
	foreach $handle (@Mail_aliases) {
		close($handle);
	}
	foreach $handle (@Host_aliases) {
		close($handle);
	}
}

##### USER LEVEL ALIAS LOOKUP #####
#
# alias_lookup(address)
#	address: an address to be looked up
#	return value: aliased address OR null
#
sub alias_lookup {
	local ($addr) = @_;
	local ($ali, $a);
	return "" if ($addr =~ /[$Address_operators]/o);
	if ($Alias_lookup_count++ == 100) {
		$Errlog .= "May be alias loop: $addr\n";
		&error_exit;
	}
	foreach $ali (@Mail_aliases) {
		print STDERR "alias: searching $addr in handle $ali.\n"
			if ($Debug{"alias"});
		seek($ali, 0, 0);
		while (<$ali>) {
			chop if (/\n$/);
			if (/^$addr:\s*(.+)/) {
				$Alias_lookup_count++;
				print STDERR "alias: found $addr -> $1\n"
					if ($Debug{"alias"});
				$a = $1;
## if ISO2022JP
				if ($Iso2022jp_code_conversion) {
					$a = &conv_iso2022jp($a)
				}
				$a = &struct_iso2022jp_mimefy($a)
					if ($Iso2022jp_header_mime_conv);
## endif
				print STDERR "alias: return: $a\n"
					if ($Debug{"alias"});
				return "$a";
			}
		}
	}
	return "";
}

##### USER LEVEL ADDRESS COMPLETION #####
#
# completion(address)
#	address: an address to be tried completion
#	return value: completed address OR null
#
sub completion {
	local ($addr) = @_;
	local ($local_part, $domain_part, $he_name, $ali);
	if ($addr =~ /^([\w-.]+)@([\w-.]+)$/) {
		($local_part, $domain_part) = ($1, $2);
		foreach $ali (@Host_aliases) {
			print STDERR "alias: searching $addr in handle $ali.\n"
				if ($Debug{"alias"});
			seek($ali, 0, 0);
			while (<$ali>) {
				chop if (/\n$/);
				if (/^$domain_part\s+([\w.-]+)/) {
					print STDERR "alias: found(file): "
					  ."$domain_part -> $1\n"
						if ($Debug{"alias"});
					return "$local_part\@$1";
				}
			}
		}
		if ($Cmpl_with_gethostbyname) {
			($he_name) = gethostbyname($domain_part);
			if (length($he_name) > length($domain_part)) {
				print STDERR "alias: found(gethostbyname): "
				  ."$domain_part -> $he_name\n"
					if ($Debug{"alias"});
				return "$local_part\@$he_name";
			}
		}
	}
	return "";
}

## if ISO2022JP
##### ISO-2022-JP CODE CONVERSION #####
#
# conv_iso2022jp(line)
#	line: a line of string to be converted
#	return value: converted line
#
sub conv_iso2022jp {
	local ($line) = @_;
	if ($line =~ /^$C_ascii$/o) {
		return $line;
	} elsif ($line =~ /^$C_ascii($C_jis($C_jis_roman)+)+$/o) {
		return $line;
	} elsif ($line =~ /^($C_ascii$C_SorE)+$C_ascii$/o) {
		local ($c) = $Body_code;
		$c = $Default_code if ($c eq "");
		if ($c eq "SJIS") {
			return &conv_from_sjis($line);
		} else {
			return &conv_from_euc($line);
		}
	} elsif ($line =~ /^($C_ascii($C_euc|$C_euc_kana))+$C_ascii$/o) {
		return &conv_from_euc($line);
	} elsif ($line =~ /^($C_ascii($C_sjis|$C_sjis_kana))+$C_ascii$/o) {
		return &conv_from_sjis($line);
	}
	return $line;
}

##### ISO-2022-JP CODE CONVERSION FROM EUC #####
#
# conv_from_euc(line)
#	line: a line of string to be converted
#	return value: converted line
#
sub conv_from_euc {
	local ($line) = @_;
	$line =~ s/($C_euc|$C_euc_kana)/&e2j($&, $')/geo;
	return $line;
}
# e2j() is based on _euc2jis() of jcode.pl-1.9/2.0
#	by srekcah@sra.co.jp and utashiro@iij.ad.jp
sub e2j {
	local($_, $rest) = @_;
	tr/\xa1-\xfe/\x21-\x7e/;
	if (/\x8e/) {
		tr/\x8e//d;
		$Has_Hankaku_kana = 1;
		return $E_kana.$_ if ($rest =~ /^($C_euc|$C_euc_kana)/o);
		return $E_kana.$_.$E_asc;
	} else {
		return $E_jp.$_ if ($rest =~ /^($C_euc|$C_euc_kana)/o);
		return $E_jp.$_.$E_asc;
	}
}

##### ISO-2022-JP CODE CONVERSION FROM SJIS #####
#
# conv_from_sjis(line)
#	line: a line of string to be converted
#	return value: converted line
#
sub conv_from_sjis {
	local ($line) = @_;
	$line =~ s/($C_sjis|$C_sjis_kana)/&s2j($&, $')/geo;
	return $line;
}

# s2j() is based on _sjis2jis() of jcode.pl-1.9/2.0
#	by srekcah@sra.co.jp and utashiro@iij.ad.jp
sub s2j {
	local($_, $rest) = @_;
	if (/^$C_sjis_kana/o) {
		tr/\xa1-\xdf/\x21-\x5f/;
		$Has_Hankaku_kana = 1;
		return $E_kana.$_ if ($rest =~ /^($C_sjis|$C_sjis_kana)/o);
		return $E_kana.$_.$E_asc;
	} else {
		s/../$s2e{$&}||&s2e($&)/geo;
		tr/\xa1-\xfe/\x21-\x7e/;
		return $E_jp.$_ if ($rest =~ /^($C_sjis|$C_sjis_kana)/o);
		return $E_jp.$_.$E_asc;
	}
}
# s2e() is taken from jcode.pl-1.9 by srekcah@sra.co.jp and utashiro@iij.ad.jp
######################################################################
#
# jcode.pl: Perl library for Japanese character code conversion
#
# Copyright (c) 1995,1996 Kazumasa Utashiro <utashiro@iij.ad.jp>
# Internet Initiative Japan Inc.
# 1-4 Sanban-cho, Chiyoda-ku, Tokyo 102, Japan
#
# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
# Software Research Associates, Inc.
# Original by srekcah@sra.co.jp, Feb 1992
######################################################################
sub s2e {
	($c1, $c2) = unpack('CC', $code = shift);
	if ($c2 >= 0x9f) {
		$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
		$c2 += 2;
	} else {
		$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
		$c2 += 0x60 + ($c2 < 0x7f);
	}
	$s2e{$code} = pack('CC', $c1, $c2);
}

##### HEADER ISO-2022-JP CONVERSION #####
#
# header_iso2022jp_conv()
#	return value: none
#
sub header_iso2022jp_conv {
	local ($i, $c);
	local ($field_name, $field_value);
	return unless ($Iso2022jp_header_mime_conv);
	for ($i = 0; $i <= $#Header; $i++) {
		$c = &code_check($Header[$i]);
		if ($Iso2022jp_code_conversion) {
			if ($c eq "sORe") {
				if ($Body_code ne "") {
					$c = $Body_code;
				} else {
					$c = $Default_code;
				}
			}
			if ($c =~ /^sjis$/i || $c =~ /^euc$/i) { # XXX
				$Header[$i] = &conv_iso2022jp($Header[$i]);
			}
			$c = "jis";
		}
		if ($c eq "jis") {
			$Header[$i] =~ /^[\w-]+:\s?/;
			$field_name = $&;
			$field_value = $';
			if ($field_name =~ /^To:/i
			 || $field_name =~ /^Apparently-To:/i
			 || $field_name =~ /^Cc:/i
			 || $field_name =~ /^Bcc:/i
			 || $field_name =~ /^Dcc:/i
			 || $field_name =~ /^From:/i
			 || $field_name =~ /^Sender:/i
			 || $field_name =~ /^Originator:/i
			 || $field_name =~ /^Reply-To:/i
			 || $field_name =~ /^Resent-To:/i
			 || $field_name =~ /^Resent-Cc:/i
			 || $field_name =~ /^Resent-Sender:/i
			 || $field_name =~ /^Resent-Bcc:/i
			 || $field_name =~ /^Resent-Dcc:/i
			 || $field_name =~ /^Resent-From:/i
			 || $field_name =~ /^Resent-Sender:/i
			 || $field_name =~ /^Resent-Reply-To:/i
			 || $field_name =~ /^Errors-To:/i
			 || $field_name =~ /^Return-Receipt-To:/i) {
				# structured field
				$Header[$i] = $field_name
				  .&struct_iso2022jp_mimefy($field_value);
			} else {
				$Header[$i] = $field_name
				  .&line_iso2022jp_mimefy($field_value);
			}
		}
		print STDERR "converted into: $Header[$i]\n"
			if ($Debug{"encode"});
	}
}

##### STRUCTURED HEADER LINE ISO-2022-JP MIME CONVERSION #####
#
# struct_iso2022jp_mimefy(lines)
#	lines: continuous header lines to be converted
#	return value: converted lines
#
sub struct_iso2022jp_mimefy {
	local ($line_in) = @_;

	local ($line_out, $line_work, $c, $need_space);
	local ($inquote, $incomment, $addrquote);
	local ($groupcolon, $groupsyntax, $need_encode);
	$inquote = 0;
	$incomment = 0;
	$addrquote = 0;
	$groupcolon = 0;
	$need_encode = 0;
	$line_out = "";
	$line_work = "";
	$need_space = 0;
	print "encoding structured: $line_in\n" if ($Debug{"encode"});
	while ("$line_in" ne "") {
		if ($line_in =~ /^$Jis_kanji[^\e]+$Jis_roman/o){
			$c = $&;
			$line_in = $';
			$need_encode = 1;
		} elsif ($line_in =~ /^$Jis_roman/o) {	# XXXX
			$c = $&;
			$line_in = $';
			$need_encode = 1;
		} else {
			$c = substr($line_in, 0, 1);
			$line_in = substr($line_in, 1);
		}
		if (!$inquote && $c =~ /^\s$/) {
			# split/encode
			if ($line_work ne "" && $need_encode) {
				$need_encode = 0;
				$line_out =~ /[^\n]*$/;
				$n = length($&);
				$line_out .= &word_iso2022jp_mimefy($n,
				  $line_work, $need_space, 1).$c;
			} else {
				$line_out = &hdr_cat($line_out, $line_work.$c,
				  "");
			}
			$line_work = "";
#			$need_space = 0;
			next;
		} elsif ($inquote) {
			$line_work .= $c;
			if ($c eq '"') {
				$inquote = 0;
			} elsif ($c eq "\\") {
				$line_work .= substr($line_in, 0, 1);
				$line_in = substr($line_in, 1);
			}
			next;
		} elsif ($incomment) {
			if ($c eq "(") {
				$incomment++;
			} elsif ($c eq ")") {
				$incomment--;
				if ($incomment == 0) {
					# encode
					if ($line_work ne "" && $need_encode) {
						$need_encode = 0;
						$line_out =~ /[^\n]*$/;
						$n = length($&);
						$line_out .= &word_iso2022jp_mimefy($n, $line_work, $need_space, 1).$c;
					} else {
						$line_out = &hdr_cat($line_out,
						  $line_work.$c, "");
					}
					$line_work = "";
					$need_space = 1;
					next;
				}
			} elsif ($c eq "\\") {
				$line_work .= $c;
				$c = substr($line_in, 0, 1);
				$line_in = substr($line_in, 1);
			}
			$line_work .= $c;
			next;
		} elsif ($c eq '"') {
			$inquote = 1;
		} elsif ($c eq "(") {	# beggining of a comment
			$incomment++;
			# encode and split
			if ($line_work ne "" && $need_encode) {
				$need_encode = 0;
				$line_out =~ /[^\n]*$/;
				$n = length($&);
				$line_out .= &word_iso2022jp_mimefy($n,
				  $line_work, 0, 1).$c;
			} else {
				$line_out = &hdr_cat($line_out, $line_work.$c,
				  "");
			}
			$line_work = "";
			$need_space = 0;
			next;
		} elsif ($c eq ")") {
			$Errlog .= "Unbalanced comment parenthesis "
			  ."('(', ')').\n";
			&error_exit;
		} elsif ($c eq "<") {
			# encode
			$addrquote++;
			if ($addrquote == 1) {
				if ($line_work ne "" && $need_encode) {
					$need_encode = 0;
					$line_out =~ /[^\n]*$/;
					$n = length($&);
					$line_work = &word_iso2022jp_mimefy($n,
					  $line_work, $need_space, 1)." ";
					$line_out .= $line_work;
				} else {
					$line_out = &hdr_cat($line_out,
					  $line_work, "");
				}
				$line_work = $c;
				$need_space = 1;
				next;
			}
		} elsif ($c eq ">") {
			$addrquote--;
			if ($addrquote == 0) {
				# split
				$line_out = &hdr_cat($line_out, $line_work.$c,
				  "");
				$line_work = "";
				$need_space = 1;
				next;
			}
		} elsif ($c eq "\\") {
			$line_work .= $c;
			$c = substr($line_in, 0, 1);
			$line_in = substr($line_in, 1);
		} elsif ($c eq ":") {
			$line_work .= $c;
			$c = substr($line_in, 0, 1);
			$line_in = substr($line_in, 1);
			$groupcolon = 1 if ($c ne ":");
		} elsif ($c eq ";") {
			if ($groupcolon) {
				$groupcolon = 0;
				$groupsyntax = 1;
			}
		} elsif ($c eq ",") {
			unless ($groupcolon) {
				# trail
				if ($line_work ne "" && $need_encode) {
					$need_encode = 0;
					$line_out =~ /[^\n]*$/;
					$n = length($&);
					$line_out .= &word_iso2022jp_mimefy($n,
					  $line_work, $need_space, 1)." ".$c;
				} else {
					$line_out = &hdr_cat($line_out,
					  $line_work.$c, "");
				}
				$line_work = "";
				$need_space = 1;
				next;
			}
		}
		$line_work .= $c;
	}
	# trail
	if ($line_work ne "" && $need_encode) {
		$need_encode = 0;
		$line_out =~ /[^\n]*$/;
		$n = length($&);
		$line_out .= &word_iso2022jp_mimefy($n, $line_work,
		  $need_space, 1);
	} else {
		$line_out = &hdr_cat($line_out, $line_work, "");
	}
	print "encoded structured: $line_out\n" if ($Debug{"encode"});
	if ($addrquote) {
		$Errlog .= "Unbalanced address quotes ('<', '>').\n";
		&error_exit;
	}
	if ($inquote) {
		$Errlog .= "Unbalanced quotes ('\"').\n";
		&error_exit;
	}
	if ($incomment) {
		$Errlog .= "Unbalanced comment parenthesis ('(', ')').\n";
		&error_exit;
	}
	if ($line_out =~ /$Jis_kanji[^\e]+$Jis_roman/o){
		$Errlog .= "invalid iso-2022-jp charset location "
		  ."in structured field.\n";
		&error_exit;
	}
	return ($line_out);
}

##### UNSTRUCTURED HEADER LINE ISO-2022-JP MIME CONVERSION #####
#
# line_iso2022jp_mimefy(lines)
#	lines: continuous header lines to be converted
#	return value: converted lines
#
sub line_iso2022jp_mimefy {
	local ($line_in) = @_;
	local ($line_out, $this_word, $this_space, $this_code, $follow, $n);
	$follow = 0;
	$this_space = "";
	$line_out = "";
	while ("$line_in" ne "") {
		if ($line_in =~ /^\n([ \t]*)/) {	# fold headdings
			$line_in = $';
			if ($this_space ne "") {
				$line_out .= $this_space;
				$this_space = "";
			}
			if ($1 ne "") {
				$line_out .= "\n$1";
			} else {
				$line_out .= "\n";
			}
			$follow = 0;
			next;
		}
		$this_space = "";
		if ($line_in =~ /^[ \t]+/) {	# just spaces
			$line_in = $';
			$this_space = $&;
		}
		$this_word = "";
		$this_code = "us-ascii";
		while ($line_in ne "") {
			if ($line_in =~ /^$C_pascii/o) {
				$line_in = $';
				$this_word .= $&;
			} elsif ($line_in =~ /^$Jis_kanji[^\e]+$Jis_roman/o){
				last if ($this_code ne "us-ascii"
					 && $this_code ne "iso-2022-jp");
				$line_in = $';
				$this_word .= $&;
				$this_code = "iso-2022-jp";
			} elsif ($line_in =~ /^$Jis_roman/o){	# XXX
				last if ($this_code ne "us-ascii"
					 && $this_code ne "iso-2022-jp");
				$line_in = $';
				$this_word .= $&;
				$this_code = "iso-2022-jp";
			} elsif ($line_in =~ /^[ \t]+/) {	# just spaces
				last;
			} elsif ($line_in =~ /^\n[ \t]*/) {	# fold headdings
				last;
			} else {
				# anything else (XXX should be Q-encoded?)
				last if ($this_code ne "us-ascii"
					 && $this_code ne "unknown");
				$this_word .= substr($line_in, 0, 1);
				$line_in = substr($line_in, 1);
				$this_code = "unknown";
			}
		}
		if ($this_code eq "us-ascii" || $this_code eq "unknown") {
			$line_out = &hdr_cat($line_out, $this_word,
				$this_space);
			$this_space = "";
			$follow = 0;
		} elsif ($this_code eq "iso-2022-jp") {
			# ISO-2022-JP encoding
			print STDERR "encoding: $this_word\n"
				if ($Debug{"encode"});
#			$Need_mime_version_header = 1;
			if ($this_space ne "") {
				if ($follow) {
					$this_word = $this_space.$this_word;
				} else {
					$line_out .= $this_space;
				}
			}
			$line_out =~ /[^\n]*$/;
			$n = length($&);
			$line_out .= &word_iso2022jp_mimefy($n, $this_word,
			  $follow, 0);
			$this_space = "";
			$follow = 1;
		}
	}
	return $line_out;
}

##### WORD ISO-2022-JP MIME CONVERSION #####
#
# word_iso2022jp_mimefy(size, word, need_pre_space, struct)
#	size: length already occupied in the last line
#	word: word to be converted
#	need_pre_space: space should be prepended
#	struct: true if in structured field
#	return value: encoded words
#
sub word_iso2022jp_mimefy {
	local ($size, $word_in, $need_pre_space, $struct) = @_;
	local ($word_out) = "";
	local ($word_conv, $n, $word_sub, $word_rest);

	if ($NoFolding) {
		if ($HdrQEncoding) {
			$word_out .= $Jp_Qin;
			$word_out .= &qp_encode($word_in, $struct);
		} else {
			$word_out .= $Jp_Bin;
			$word_out .= &base64encode($word_in);
		}
		$word_out .= $Jp_out;
		return $word_out;
	}

	$size = $Folding_length - $size;
	print STDERR "encoding word($size): $word_in\n"
		if ($Debug{"encode"});
	if ($size - length($Jp_Bin) - length($Jp_out) - 12 <= 0) {
		$word_out .= "\n\t";
		$size = $Folding_length;
	} elsif ($need_pre_space) {
		$word_out .= " ";
	}
	while ($word_in ne "") {
		$word_conv = "";
		$word_out =~ /[^\n]*$/;
		$n = int(($size - (length($&) + length($Jp_Bin)
		  + length($Jp_out) + 12))/4*3);
		while (($n > 0) && $word_in ne "") {
#			if ($word_in !~ /$Jis_kanji/o) {
#				# us-ascii part
#				$word_sub = substr($word_in, 0, $n);
#				$word_in = substr($word_in, $n);
#				$word_conv .= $word_sub;
#				$n -= length($word_sub);
#				next;
#			}
			if ($word_in =~ /^([^\e]+)/) {
				# us-ascii part
				$word_sub = substr($&, 0, $n);
				$word_in = substr($&, $n)."$'";
				$word_conv .= $word_sub;
				$n -= length($word_sub);
				next;
			} elsif ($word_in =~ /^($Jis_roman)([^\e]+)/) {
				# JIS roman part
				if ($n < 3) {
					$n = 0;
					next;
				}
				$word_sub = "$1".substr($2, 0, $n);
				$word_in = substr($2, $n)."$'";
				$word_conv .= $word_sub;
				$n -= length($word_sub);
				next;
			} elsif ($word_in =~
			  /($Jis_kanji)([^\e]+)($Jis_roman)/o) {
				# iso-2022-jp part
				$n = int($n/2)*2 - 6;
				if ($n < 2) {
					$n = 0;
					next;
				}
				$word_sub = substr($2, 0, $n);
				$word_rest = substr($2, $n);
				if ($word_rest) {
					$word_in = $1.$word_rest.$3."$'";
				} else {
					$word_in = $';
				}
				$word_conv .= $1.$word_sub.$3;
				$n -= length($word_sub)+6;
				next;
			} else {
				# Unsupported charset (XXX)
				$word_conv .= $word_in;
				$word_in = "";
			}
		}
		if ($word_conv ne "") {
			if ($HdrQEncoding) {
				$word_out .= $Jp_Qin;
				$word_out .= &qp_encode($word_conv, $struct);
			} else {
				$word_out .= $Jp_Bin;
				$word_out .= &base64encode($word_conv);
			}
			$word_out .= $Jp_out;
		}
		if ($word_in) {
			$word_out .= "\n\t";
		}
		$size = $Folding_length;
	}
	return $word_out;
}
## endif

##### BASE64 ENCODER #####
#
# base64encode(linen)
#	line: a string to be encoded
#	return value: encoded line
#
sub base64encode {
	local($line) = @_;
	local($mod3) = length($line) % 3;
	$line = unpack('B*', $line).('', '0000', '00')[$mod3];
	$line =~ s/.{6}/$Base64a[unpack('C', pack('B*', "00"."$&"))]/ge;
	return $line.('', '==', '=')[$mod3];
}

##### BASE64 DECODER #####
#
# base64decode(linen)
#	line: a string to be decoded
#	return value: decoded line
#
sub base64decode {
	local($line) = @_;
	local($bits) = join('', grep($_ = $Base64b{$_}, $line =~ /./g));
	$line = pack('B' . (length($bits) & ~7), $bits);
	return $line;
}

##### QUOTED-PRINTABLE ENCODER #####
#
# qp_encode(line, struct)
#	line: a string to be encoded
#	struct: true if in structured field
#	return value: encoded line
#
sub qp_encode {
	local($line, $struct) = @_;
	if ($struct) {
		$line =~ s/[^\w\d\!\*\+\-\/ ]/sprintf("=%02X",
			unpack('C', $&))/ge;
	} else {
		$line =~ s/[^\!-<>\@-\^\`-\~ ]/sprintf("=%02X",
			unpack('C', $&))/ge;
	}
	$line =~ s/ /_/g;
	return $line;
}

##### QUOTED-PRINTABLE DECODER #####
#
# qp_decode(line)
#	line: a string to be decoded
#	return value: decoded line
#
sub qp_decode {
	local($line) = @_;
	$line =~ s/=([\dA-F][\dA-F])/pack('C', hex($1))/ige;
	$line =~ s/_/ /g;
	return $line;
}

##### CODE CHECKER #####
#
# code_check()
#	return value: encoding type
#		ascii
#		8bit
#		jis
#		euc
#		sjis
#		sORe
#
sub code_check {
	local ($line) = @_;
	if ($line =~ /^$C_ascii$/o) {
		return "ascii";
## if ISO2022JP
	} elsif ($line =~ /^$C_ascii($C_jis($C_jis_roman)+)+$/o) {
		return "jis";
	} elsif ($line =~ /^($C_ascii$C_SorE)+$C_ascii$/o) {
		return "sORe";
	} elsif ($line =~ /^($C_ascii($C_sjis|$C_sjis_kana))+$C_ascii$/o) {
		return "sjis";
	} elsif ($line =~ /^($C_ascii($C_euc|$C_euc_kana))+$C_ascii$/o) {
		return "euc";
## endif
#	} elsif ($line =~ /$C_8bit/o) {
#		return "8bit";
	}
	return "8bit";
}

##### BODY CODE CHECKER #####
#
# body_code(content)
#	content: pointer to body content line list
#	return value: encode type
#		ASCII
#		8BIT
#		JIS
#		EUC
#		SJIS
#
sub body_code {
	local (*content) = @_;
	local ($i, %count, $line);
	undef %count;
	for ($i = 0; $i <= $#content; $i++) {
		$count{&code_check($content[$i])}++;
		$line = $content[$i];
		$count{"total"} += length($line);
		$line =~ s/[^\x80-\xff]//g;
		$count{"has8bit"} += length($line);
	}
	# select encoding
	if ($count{"has8bit"} * 8 > $count{"total"}) {
		$Need_base64_encoded = 1;
	} else {
		$Need_base64_encoded = 0;
	}
	if ($Debug{"code"}) {
		printf STDERR "ascii = %d\n", $count{"ascii"};
		printf STDERR "8bit = %d\n", $count{"8bit"};
		printf STDERR "jis = %d\n", $count{"jis"};
		printf STDERR "euc = %d\n", $count{"euc"};
		printf STDERR "sjis = %d\n", $count{"sji"};
		printf STDERR "sORe = %d\n", $count{"sORe"};
	}
	return "8BIT" if ($count{"8bit"});
## if ISO2022JP
	if ($count{"jis"}) {
		return "8BIT"
			if ($count{"sORe"} || $count{"sjis"} || $count{"euc"});
		return "JIS";
	}
	if ($count{"sjis"}) {
		return "8BIT" if ($count{"euc"});
		return "SJIS";
	}
	return "EUC" if ($count{"euc"});
	return $Default_code if ($count{"sORe"});
## endif
	return "ASCII";
}

##### GET SIZE OF MESSAGE #####
#
# message_size(part)
#	return value: size of whole message
#
sub message_size {
	local ($part) = @_;
	local ($start, $end, $line, $i, $size);
	if ($part == 0) {
		$start = 0;
		$end = $#Body;
	} else {
		$start = $Lines_to_partial * ($part - 1);
		$end = $Lines_to_partial * $part - 1;
		$end = $#Body if ($end > $#Body);
	}
	$size = 0;
	for ($i = 0; $i <= $#Header; $i++) {
		$size += length($Header[$i])
			if ($Header[$i] !~ /^ KILLED /);
	}
	for ($i = $start; $i <= $end; $i++) {
		$size += length($Body[$i]);
	}
	return $size;
}

##### WRITE DISPATCHING HISTORY #####
#
# log_history(protocol, to, stat)
#	protocol: current protocol to be logged
#	stat: result status to be logged
#	to: list of recipients
#	return value: none
#
sub log_history {
	local ($proto, $to, $stat) = @_;
	return unless ($Hist_file);
	local ($file) = &file_path($Hist_file, "", "", 0);
	umask($MsgUmask);
	unless (open(HISTORY, ">>$file")) {
		print STDERR "can't open history file: $file\n";
		return;
	}
	local ($tm_sec, $tm_min, $tm_hour, $tm_mday, $tm_mon, $tm_year)
		= localtime($Cur_time);
	printf HISTORY "%d/%02d/%02d %02d:%02d:%02d proto=%s",
		$tm_year+1900, $tm_mon+1, $tm_mday, $tm_hour, $tm_min, $tm_sec,
		$proto;
	print HISTORY " server=$Cur_server" if ($Cur_server);
	print HISTORY " id=$Cur_mid" if ($Cur_mid);
	print HISTORY " from=$Sender ($Config_opt)" if ($Config_opt ne "");
	print HISTORY " to=$to" if ($to ne "");
	if ($#Response >= 0) {
		printf HISTORY " stat=%s (%s)", $stat, join('/', @Response);
	} else {
		printf HISTORY " stat=%s", $stat;
	}
	print HISTORY "\n";
	close(HISTORY);
}

##### SERVER SIDE SMTP PROCESSING (BEFORE GETTING MAIL) #####
#
# smtp_get_mail()
#	return value: none
#
sub smtp_get_mail {
	local ($state) = 0;
	print STDOUT "220 Server ready ($Version)\r\n";
	while (<STDIN>) {
		if (/^NOOP\s/i) {
			print STDOUT "250 OK\r\n";
		} elsif (/^QUIT\s/i) {
			print STDOUT "221 Closing connection\r\n";
			close(STDOUT);
			last;
		} elsif (/^HELO\s/i) {
			print STDOUT "250 Hello, pleased to meet you\r\n";
			$state = 1;
		} elsif (/^MAIL FROM:/i) {
			$Sender = &extract_addr($');
			if ($Default_from_domain_name ne ""
			 && !$Obey_MTA_domain	# XXX
			 && $Sender !~ /[$Address_operators]/o) {
				$Sender .= "\@$Default_from_domain_name";
			}
			$Sender_name = "";
			print STDOUT "250 Sender ok\r\n";
			$state = 2;
		} elsif (/^RCPT TO:/i) {
			if ($state != 2) {
				print STDOUT "503 Need MAIL before RCPT\r\n";
				next;
			}
			&add_to_rcpt(0, $');
			print STDOUT "250 Recipient ok\r\n";
			$state = 3;
		} elsif (/^DATA\s/i) {
			if ($state != 3) {
				print STDOUT "503 No recipient\r\n";
				next;
			}
			print STDOUT "354 End with '.' on a line by itself\r\n";
			$Dot_terminate = 1;
			&read_header("STDIN", 0);
			&read_body("STDIN", 1);
			unless ($Error_report_by_mail) {
				last;
			} else {
				print STDOUT "250 Message accepted\r\n";
			}
		} elsif (/^RSET\s/i) {
			print STDOUT "503 Not supported\r\n";
		} elsif (/^HELP\s/i) {
			print STDOUT "250 No information\r\n";
		} elsif (/^VRFY\s/i || /^EXPN\s/i) {
			print STDOUT "503 Not supported\r\n";
		} elsif (/^ONEX\s/i) {
			print STDOUT "250 Treated as NOOP\r\n";
		} elsif (/^VERB\s/i) {
			print STDOUT "250 Verbose mode\r\n";
			$Verbose = 1;
		} else {
			print STDOUT "500 Command unrecognized\r\n";
		}
	}
}

##### SERVER SIDE SMTP PROCESSING (AFTER GETTING MAIL) #####
#
# smtp_get_mail_final(error_status)
#	error_status: status of delivery to be reported
#	return value: none
#
sub smtp_get_mail_final {
	local ($error) = @_;
	return unless (fileno(STDOUT));
	unless ($error) {
		print STDOUT "250 Message accepted for delivery\n";
	}
	while (<STDIN>) {
		if (/^QUIT\s/i) {
			print STDOUT "221 Closing connection\r\n";
			close(STDOUT);
			last;
		} elsif (/^HELO\s/i || /^EHLO\s/i) {
			print STDOUT "250 Hello\r\n";
		} elsif (/^MAIL\s/i || /^RCPT\s/i || /^DATA\s/i) {
			print STDOUT "503 Invalid sequence\r\n";
		} elsif (/^NOOP\s/i) {
			print STDOUT "250 OK\r\n";
		} elsif (/^RSET\s/i) {
			print STDOUT "503 Not supported\r\n";
		} elsif (/^HELP\s/i) {
			print STDOUT "250 No information\r\n";
		} elsif (/^VRFY\s/i || /^EXPN\s/i) {
			print STDOUT "503 Not supported\r\n";
		} elsif (/^ONEX\s/i) {
			print STDOUT "250 Treated as NOOP\r\n";
		} elsif (/^VERB\s/i) {
			print STDOUT "250 Verbose mode\r\n";
			$Verbose = 1;
		} else {
			print STDOUT "500 Command unrecognized\r\n";
		}
	}
}

##### GET DIRECTORY PATH FOR FOLDERS #####
#
# get_folders_dir(for_fcc)
#	for_fcc: need path for "fcc" if true
#	return value: absolute path of folder directory
#
sub get_folders_dir {
	local ($for_fcc) = @_;	# XXX
	local ($folders);
	$folders = $Default_msg_folders_dir;
	if ($folders =~ /^\+/) {
		print STDERR "\$Default_msg_folders_dir must not defined"
			." as '+folder' style\n";
		return "/invalid/folder/directory/path/configuration";
	}
	return &file_path($folders, "", "", 0);

}

##### GET INPUT MESSAGE PATH #####
#
# get_input_message_path()
#	return value: absolute path of message file
#
sub get_input_message_path {
	local ($folders_dir) = &get_folders_dir(0);
	return &file_path($Draft_message, $Draft_folder, $folders_dir, 1);
}

##### READ MESSAGE FROM MESSAGE FILE #####
#
# read_message(dist_mode)
#	dist_mode: redistribution mode if ture
#	return value: none
#
sub read_message {
	local ($dist_mode) = @_;
	local ($FILE) = "message";
	local ($message_file_path);
	if ($dist_mode) {
		$message_file_path = &file_path($Dist_file, "", "", 0);
	} else {
		$message_file_path = &get_input_message_path;
	}
	unless (open($FILE, "<$message_file_path")) {
		$Errlog .= "Can not open: $message_file_path\n";
		&error_exit;
	}
	&read_header($FILE, 0);
	&read_body($FILE, 0);
	close($FILE);
}

##### READ MESSAGE FROM MESSAGE FILE FOR MULTIPART ADDITIONALS #####
#
# read_mp_message(file, content)
#	file: message file name to be read
#	return value: none
#
sub read_mp_message {
	local ($file, *content) = @_;
	local ($FILE) = "mp_message";
	local ($message_file_path);
	if ($file eq "-") {
		$message_file_path = "/dev/tty";	# get from STDIN
	} else {
		$message_file_path = &file_path($file, "", "", 0);
	}
	unless (open($FILE, "<$message_file_path")) {
		$Errlog .= "Can not open: $message_file_path\n";
		&error_exit;
	}
	@content = ();
	while (<$FILE>) {
		push (@content, $_);
	}
	close($FILE);
}

##### ENCAPSULATE MESSAGE BODY #####
#
# encapsulate_body(boundary)
#	boundary: boundary of multipart message
#	return value: none
#
sub encapsulate_body {
	local ($boundary) = @_;
	local ($l);
#	unshift(@Body, "\n");
	# pull down Content-* header lines into body part
	foreach $l (@Header) {
		if ($l =~ /^(Content-[\w-]+):/i) {
			unshift(@Body, $l);
			&kill_header("$1", 0);
		}
	}
	foreach $l (@Body) {
		if ($l !~ /^\n?$/) {
			unshift(@Body, "--$boundary\n");
			last;
		}
	}
	unshift(@Body, "\n");
}

##### ADDING EXTRA MESSAGES AS MULTIPART #####
#
# add_multipart()
#	return value: none
#
sub add_multipart {
	local ($hdr, $part_code);
	local($mp_boundary) = &gen_message_id(0);
	$mp_boundary =~ y/<@>/-_-/;
	&encapsulate_body($mp_boundary);
	&add_header(1, "Mime-Version", "1.0")
		if (!&header_value("Mime-Version"));
	&add_header(1, "Content-Type", "Multipart/mixed;\n"
		."\tboundary=\"$mp_boundary\"");
	foreach $mp_msg (@Mulipart_messages) {
		print STDERR "adding message: $mp_msg\n"
			if ($Debug{"multipart"});
		push(@Body, "--$mp_boundary\n");
		&read_mp_message($mp_msg, *Part);
		$part_code = &body_code(*Part);
		print STDERR "code = $part_code\n"
			if ($Debug{"multipart"});
		# add internal header
		if ($part_code eq "ASCII") {
			push(@Body, "Content-Type: Text/plain;"
				." charset=us-ascii\n");
## if ISO2022JP
		} elsif ($part_code eq "JIS") {
			push(@Body, "Content-Type: Text/plain;"
				." charset=iso-2022-jp\n");
		} elsif ($part_code eq "SJIS" || $part_code eq "EUC") {
			if ($Iso2022jp_code_conversion) {
				&body_convert_iso2022jp(*Part);
				if ($Has_Hankaku_kana) {
					$part_code = "8BIT";
				} else {
					push(@Body, "Content-Type: Text/plain;"
." charset=iso-2022-jp (auto-converted from $part_code)\n");
				}
			} else {
				$part_code = "8BIT";
			}
## endif
		}
		if ($part_code eq "8BIT") {
			local ($part_encoding);
			push(@Body, "Content-Type: Text/plain;"
				." charset=$Unknown8bit_label\n");
			if ($Conv_8to7) {
				if ($Need_base64_encoded) {
					&body_base64_encode(*Part);
					$part_encoding = "base64";
				} else {
					&body_qp_encode(*Part);
					$part_encoding = "quoted-printable";
				}
				push(@Body, "Content-Transfer-Encoding:"
					." $part_encoding\n");
			}
		}
		push(@Body, "\n");
		push(@Body, @Part);
	}
	push(@Body, "--$mp_boundary--\n");
}

##### PGP HANDLING #####
#
# pgp_process()
#	return value: none
#
sub pgp_process {
	local($b, $flg);
	$flg = 0;
	foreach $b (@Body) {
		if ($b !~ /^\n?$/) {
			$flg = 1;
			last;
		}
	}
	if ($flg == 0) {
		# no message body to be signed
		return;
	}
	local($mp_boundary) = &gen_message_id(0);
	$mp_boundary =~ y/<@>/-_-/;
	&encapsulate_body($mp_boundary);
	&add_header(1, "Mime-Version", "1.0")
		if (!&header_value("Mime-Version"));
	&add_header(1, "Content-Type", "Multipart/signed;\n"
		."\tprotocol=\"application/pgp-signature\";\n"
		."\tmicalg=\"pgp-md5\";\n"
		."\tboundary=\"$mp_boundary\"");

	pipe("ReadHandle1", "WriteHandle1");
	pipe("ReadHandle2", "WriteHandle2");

	local ($f) = fork;
	if ($f < 0) {
		$Errlog .= "Can not fork to exec PGP program.\n";
		&error_exit;
	}
	if ($f > 0) {
		# parents
		close("ReadHandle1");
		close("WriteHandle2");
		select("ReadHandle2"); $| = 1;
		select("WriteHandle1"); $| = 1;
		select(STDOUT);
	} else {
		# child
		close("WriteHandle1");
		close("ReadHandle2");
		close (STDIN);
		open(STDIN, "<&ReadHandle1");
		close (STDOUT);
		open(STDOUT, ">&WriteHandle2");
#		close (STDERR);
		select("ReadHandle1"); $| = 1;
		select("WriteHandle2"); $| = 1;
		exec ("pgp", "-saf");
		exit 0;
	}
	$flg = 2;
	foreach $b (@Body) {
		if ($flg > 1 && $b =~ /^--$mp_boundary\n$/) {
			$flg = 1;
			next;
		}
		next if ($flg > 1);
		if ($flg > 0 && $b =~ /^\n$/) {
			$flg = 0;
			next;
		}
		next if ($flg > 0);
		last if ($b =~ /^--$mp_boundary\n$/);
		print WriteHandle1 $b;
	}
	close("WriteHandle1");
	# pass phrase required by child process
	push(@Body, "--$mp_boundary\n");
	push(@Body, "Content-Type: Application/Pgp-Signature\n");
	push(@Body, "Content-Transfer-Encoding: 7bit\n");
	push(@Body, "\n");
	while (<ReadHandle2>) {
		push(@Body, $_);
	}
	push(@Body, "--$mp_boundary--\n");
}

##### EXCLUSIVE CREATE #####
#
# excl_create(handle, file)
#	file: path of file to be created exclusively
#	handle: file handle
#	return value:
#		1: success
#		0: fail
#
sub excl_create {
	local ($HANDLE, $file) = @_;
	if (defined($^A)) {	# $^A is not used by perl V4
		# for PERL5
		return eval 'sysopen($HANDLE, $file, O_RDWR|O_CREAT|O_EXCL)';
	} else {
		# for PERL4
		if ($P4syscall) {
			local($fh) = syscall(&SYS_open, $file,
				&O_RDWR|&O_CREAT|&O_EXCL, 0644);
			return 0 if ($fh <0);
			return open($HANDLE, ">&$fh");
		} else {
			local ($base) = $file;
			$base =~ s/\/[^\/]*$//;
			print STDERR "creating temporary: $base/tmp.$$\n"
				if ($Debug{"create"});
			unless (open($HANDLE, ">$base/tmp.$$")) {
				print STDERR "can't open $base/tmp.$$\n";
				return 0;
			}
			print STDERR "renaming to $file\n"
				if ($Debug{"create"});
			if (!link("$base/tmp.$$", "$file")) {
				print STDERR "can't rename to $file\n";
				close($HANDLE);
				unlink("$base/tmp.$$");
				return 0;
			}
			unlink("$base/tmp.$$");
			return 1;
		}
	}
}

##### OPEN FILE FOR FCC #####
#
# open_fcc(folder_name, save_style)
#	folder_name: a folder name to be saved in
#	save_style:
#		0 = messages in a file
#		1 = separated messages in a directory
#	return values: (handle, fcc_dir, rm_file_on_error)
#	  handle:
#		NULL  : failed
#		Handle: success
#	  fcc_dir: directory name
#	  rm_file_on_error: a path to be deleted on error
#
sub open_fcc {
	local ($folder, $dir_style) = @_;
	local ($fcc_dir, $rm_file_on_error, $fcc_folder, $FILE);
	local ($mh_folder) = &get_folders_dir(1);
	$fcc_folder = &file_path("", $folder, $mh_folder, 1);
#	$fcc_folder = &file_path($folder, "", $mh_folder, 1);

	if (-d $fcc_folder) {
		$fcc_dir = 1;
	} elsif (-f $fcc_folder) {
		$fcc_dir = 0;
	} else {
		# set default style unless exists
		$fcc_dir = $dir_style;
	}
	printf STDERR "FCC style: %s\n", $fcc_dir?"Dir":"File"
		if ($Debug{"fcc"});

	$FILE = "Fcc";
	unless ($fcc_dir) {
		umask($MsgUmask);
		print STDERR "FCC file: $fcc_folder\n" if ($Debug{"fcc"});
		unless (open($FILE, ">>$fcc_folder")) {
			print STDERR "can't open FCC file: $fcc_folder\n";
			return ("", "", "");
		}

		local ($tm_sec, $tm_min, $tm_hour, $tm_mday, $tm_mon, $tm_year,
			$tm_wk) = localtime($Cur_time);
		local ($date) = sprintf("%s %s %2d %02d:%02d:%02d %d",
			$Week_str[$tm_wk], $Month_str[$tm_mon], $tm_mday,
			$tm_hour, $tm_min, $tm_sec, $tm_year+1900); 
		unless (print($FILE "From $Sender $date\n")) {
			close($FILE);
			print STDERR "can't write FCC file: $fcc_folder\n";
			return ("", "", "");
		}
		$rm_file_on_error = "";
	} else {
		local ($f, $ff, $max, $fail_cnt);
		umask($DirUmask);
		$ff = "";
		foreach $f (split('/', $fcc_folder)) {
			$ff .= "/".$f;
			unless (-d $ff) {
				printf STDERR "FCC creating dir: $ff "
					."with mode %o\n", $Mode_directory
					if ($Debug{"fcc"});
				unless (mkdir($ff, $Mode_directory)) {
					print STDERR "can't create directory"
						." $ff\n";
					return ("", "", "");
				}
			}
		}
		unless (opendir(FOLDER, $fcc_folder)) {
			print STDERR "can't open directory: $fcc_folder\n";
			return ("", "", "");
		}
		$max = 0;
		foreach $f (readdir(FOLDER)) {
			if ($f =~ /^\d+$/) {
				$max = $f if ($max < $f);
			}
		}
		closedir(FOLDER);
		$max++;
		$fail_cnt = 0;
		print STDERR "FCC creating $fcc_folder/$max\n"
			if ($Debug{"fcc"});
		umask($MsgUmask);
		while (!&excl_create($FILE, "$fcc_folder/$max") < 0) {
			$max++;
			if ($fail_cnt++ > 10) {
				print STDERR "too many failures creating FCC\n";
				return ("", "", "");
			}
		}
		$rm_file_on_error = "$fcc_folder/$max";
		print STDERR "FCC storing in $rm_file_on_error\n"
			if ($Debug{"fcc"});
	}
	return ($FILE, $fcc_dir, $rm_file_on_error);
}

##### SAVE MESSAGE FOR FCC #####
#
# save_fcc(folder_name, save_style, with_error, partial_total)
#	folder_name: folder name to be saved in
#	save_style:
#		0 = messages in a file
#		1 = separated messages in a directory
#	with_error: error information is saved with if true
#	partial_total: total number of partial messages
#	return value:
#		0: failed
#		1: success
#
sub save_fcc {
	local ($folder, $dir_style, $with_error, $total) = @_;
	local ($fcc_dir, $err_remove, $FILE, $i);
	$CRLF = "\n";
	$total = 0 unless ($Fcc_partial);
	unless ($total) {
		print STDERR "FCC with no spliting.\n" if ($Debug{"fcc"});
		($FILE, $fcc_dir, $err_remove) = &open_fcc($folder, $dir_style);
		unless ($FILE) {
			print STDERR "FCC open failed.\n" if ($Debug{"fcc"});
			unlink($err_remove) if ($err_remove);
			return 0;
		}
		if ($with_error) {	# for dead.letter creating
			unless (&put_mimed_error_notify($FILE, 0)) {
				close($FILE);
				unlink($err_remove) if ($err_remove);
				return 0;
			}
		} else {
			unless (&put_header($FILE, "original")
			 && &put_body($FILE, 0, 0)) {
				print STDERR "FCC write failed.\n"
					if ($Debug{"fcc"});
				close($FILE);
				unlink($err_remove) if ($err_remove);
				return 0;
			}
		}
		unless ($fcc_dir) {
			unless (print($FILE "\n")) {
				close($FILE);
				return 0;
			}
		}
		close($FILE);
		return 1;
	}

	print STDERR "FCC with spliting into $total.\n" if ($Debug{"fcc"});
	for ($i = 1; $i <= $total; $i++) {
		($FILE, $fcc_dir, $err_remove) = &open_fcc($folder, $dir_style);
		unless ($FILE) {
			print STDERR "FCC open failed.\n" if ($Debug{"fcc"});
			unlink($err_remove) if ($err_remove);
			return 0;
		}
		if (!&put_mimed_partial($FILE, 0, $i, $total)) {
			print STDERR "FCC partial write failed.\n"
				if ($Debug{"fcc"});
			close($FILE);
			unlink($err_remove) if ($err_remove);
			return 0;
		}
		unless ($fcc_dir) {
			unless (print($FILE "\n")) {
				close($FILE);
				return 0;
			}
		}
		close($FILE);
	}
	return 1;
}

##### MAKE THE INPUT MESSAGE TRASH #####
#
# trash_message()
#	return value: none
#
sub trash_message {
	local ($message_file_path) = &get_input_message_path;
	local ($dir, $file);
	( $dir = $message_file_path ) =~ s/([^\/]+$)//;
	$file = $1;
	if ($Trashmark) {
		if (-f "$dir$Trashmark$file") {
			unlink ("$dir$Trashmark$file");
		}
		if (!rename ("$dir$file", "$dir$Trashmark$file")) {
			$Errlog .= "Can not rename: $message_file_path\n";
			&error_exit;
		}
	} else {
		unlink ("$dir$file");
	}
}

##### APPEND DIST HEADER #####
#
# append_dist_header()
#	return value: none
#
sub append_dist_header {
	local ($message_file_path) = &get_input_message_path;
	local ($FILE) = "message";
	unless (open($FILE, "<$message_file_path")) {
		$Errlog .= "Can not open: $message_file_path\n";
		&error_exit;
	}
	&read_header($FILE, 1);
	close($FILE);
}

##### MH ANNOTATION #####
#
# mh_annotate()
#	return value: none
#
sub mh_annotate {
	local ($command);
	$command = "anno";
	$command .= " -component '$Annotate_flag'";
	if ($Annotate_inp) {
		$command .= " -inplace";
	} else {
		$command .= " -noinplace";
	}
	$command .= " -text '@Recipients'";
	$command .= " '$Annotate_msg'";
#	$command =~ s/<(.*)>/$1/g; # remove normal/bcc information
	system($command);
}

##### SMTP RELAY (NOT USED) #####
#
# smtp_relay()
#	return value: none
#
sub smtp_relay {
	local ($rin, $rout, $buf);
	local ($SMTP) = &connect_server(*Smtp_servers, "smtp");
	select(STDIN); $| = 1;
	select(STDOUT); $| = 1;
	$rin = '';
	vec($rin, fileno(STDIN), 1) = 1;
	vec($rin, fileno($SMTP), 1) = 1;
	while (1) {
		select($rout=$rin, undef, undef, undef);
		if (vec($rout, fileno($SMTP), 1)) {
			$buf = "";
			if (read($SMTP, $buf, 1024) > 0) {
				print STDOUT $buf;
			} else {
				last;
			}
		} elsif (vec($rout, fileno(STDIN), 1)) {
			if ($_ = <STDIN>) {
				print $SMTP;
			} else {
				last;
			}
		}
	}
}

##### PROCESS QUEUED MESSAGES #####
#
# process_queue(deliver)
#	deliver: try delivery
#	reutrn value: none
#
sub process_queue {
	local ($deliver) = @_;
	local ($mh_folder) = &get_folders_dir(1);
	local ($queue_dir) = &file_path("", $Queue_Dir, $mh_folder, 1);
	local ($q, $QUEUE);
	unless (-d $queue_dir) {
		print STDERR "no queue\n" if ($Verbose);
		return;
	}
	unless (opendir(QUEUEDIR, $queue_dir)) {
		print STDERR "can't read $queue_dir\n" if ($Verbose);
		return;
	}
	foreach $q (sort {$a <=> $b} readdir(QUEUEDIR)) {
		next unless ($q =~ /^\d+$/);
		$QUEUE = "QUEUE";
		rename ("$queue_dir/$q", "$queue_dir/$q.wrk");
		unless (open($QUEUE, "<$queue_dir/$q.wrk")) {
			print STDERR "can't open $queue_dir/$q.wrk\n";
			rename ("$queue_dir/$q.wrk", "$queue_dir/$q");
			return;
		}
		print STDERR "processing $queue_dir/$q.wrk ...\n" if ($Verbose);
		while (<$QUEUE>) {
			chop;
			last if (/^$/);
			print STDERR "ENV>$_\n" if ($Debug{"queue"});
			if (/^AF:(.*)/) { $Annotate_flag = $1; next; }
			if (/^NF:(.*)/) { $News_flag = $1; next; }
			if (/^PS:(.*)/) { $Partial_sleep = $1; next; }
			if (/^SRH:(.*)/) { $Show_Rcpts_Header = $1; next; }
			if (/^SFN:(.*)/) { $Smtp_fatal_next = $1; next; }
			if (/^DSR:(.*)/) { $Dsn_success_report = $1; next; }
			if (/^MID:(.*)/) { $Cur_mid = $1; next; }
			if (/^CFG:(.*)/) { $Config_opt = $1; next; }
			if (/^PT:(.*)/) { $partial_total = $1; next; }
			if (/^S:(.*)/) { $Sender = $1; next; }
			if (/^SSV:(.*)/) { @Smtp_servers = split(',', $1); next; }
			if (/^NSV:(.*)/) { @Nntp_servers = split(',', $1); next; }
			if (/^SSH:(.*)/) { $Ssh_server = $1; next; }
			if (/^CLI:(.*)/) { $Client_name = $1; next; }
			if (/^R:(.*)/) { @Recipients = split(',', $1); next; }
			if (/^RQ:(.*)/) { $User_require = $1; next; }
			print STDERR "unknown environment: $_\n" if ($Verbose);
		}

		print STDERR "reading message\n" if ($Debug{"queue"});
		&read_header($QUEUE, 0);
		&read_body($QUEUE, 0) if ($deliver);
		close($QUEUE);

		if ($deliver) {
			print STDERR "sending message\n" if ($Debug{"queue"});
			$rcode = &send_message($News_flag, $partial_total);
			if ($rcode == 0) {
				unlink("$queue_dir/$q.wrk");
				print STDERR "$queue_dir/$q sent\n"
					if ($Verbose);
			} elsif ($rcode > 0) {
				rename ("$queue_dir/$q.wrk", "$queue_dir/$q");
				print STDERR "$queue_dir/$q preserved\n"
					if ($Verbose);
			} else {
				unlink("$queue_dir/$q.wrk");
				print STDERR "$queue_dir/$q failed\n"
					if ($Verbose);
				&error_exit;
			}
		} else {
			local ($r, $t);
			rename ("$queue_dir/$q.wrk", "$queue_dir/$q");
			print "Message queued in $queue_dir/$q";
			if ($Config_opt ne "") {
				print " (Config: $Config_opt)\n";
			} else {
				print "\n";
			}
			if ($t = &header_value("Message-ID")) {
				print "    Message-ID: $t\n";
			}
			if ($t = &header_value("Date")) {
				print "    Date: $t\n";
			}
			if ($t = &header_value("Subject")) {
## if ISO2022JP
				$t =~ s/\?=\s*=\?/\?==?/;
				$t =~ s/=\?ISO-2022-JP\?B\?([^\?]*)\?=/&base64decode($1)/ige;
				$t =~ s/=\?ISO-2022-JP\?Q\?([^\?]*)\?=/&qp_decode($1)/ige;
				$t =~ s/\n\s*//;
## endif
				print "    Subject: $t\n";
			}
			if ($News_flag) {
				print "    Will be posted in %s\n",
					&header_value("Newsgroups");
			}
			print "    Recipients:\n";
			foreach $r (@Recipients) {
				print "\t$r\n";
			}
		}

		@Header = ();
		@Body = ();
	}
	closedir(QUEUEDIR);
	if ($Verbose) {
		print STDERR "no messages found in queue\n"
			if ($QUEUE eq "");
	}
	return;
}

##### QUEUE THE MESSAGE #####
#
# queue_message()
#	reutrn value:
#		0: failed
#		1: success
#
sub queue_message {
	local ($mh_folder) = &get_folders_dir(1);
	local ($queue_dir) = &file_path("", $Queue_Dir, $mh_folder, 1);
	local ($q);
	local ($FILE) = "Queue";
	unless (-d $queue_dir) {
		umask($DirUmask);
		unless (mkdir($queue_dir, $Mode_directory)) {
			print STDERR "can't create directory $queue_dir\n"
				if ($Verbose);
			return 0;
		}
	}
	unless (opendir(QUEUEDIR, $queue_dir)) {
		print STDERR "can't read $queue_dir\n" if ($Verbose);
		return 0;
	}
	foreach $q (readdir(QUEUEDIR)) {
		$q =~ s/\.wrk$//;
		if ($q =~ /^\d+$/) {
			$max = $q if ($max < $q);
		}
	}
	closedir(QUEUEDIR);
	$max++;
	local ($fail_cnt) = 0;
	print STDERR "QUEUE creating $queue_dir/$max\n"
		if ($Debug{"queue"});
	umask($MsgUmask);
	while (!&excl_create($FILE, "$queue_dir/$max") < 0) {
		$max++;
		if ($fail_cnt++ > 10) {
			print STDERR "too many failures creating QUEUE\n";
			return 0;
		}
	}
	# dumping variables
	print $FILE "AF:$Annotate_flag\n";
	print $FILE "NF:$News_flag\n";
	print $FILE "PS:$Partial_sleep\n";
	print $FILE "SRH:$Show_Rcpts_Header\n";
	print $FILE "SFN:$Smtp_fatal_next\n";
	print $FILE "DSR:$Dsn_success_report\n";
	print $FILE "MID:$Cur_mid\n";
	print $FILE "CFG:$Config_opt\n";
	print $FILE "PT:$partial_total\n";
	print $FILE "S:$Sender\n";
	print $FILE "RQ:$User_require\n";
	printf $FILE "SSV:$Smtp_servers\n";
	printf $FILE "NSV:$Nntp_servers\n";
	printf $FILE "SSH:$Ssh_server\n";
	printf $FILE "CLI:$Client_name\n";
	printf $FILE "R:%s\n", join(',', @Recipients);
	print $FILE "\n";

	$CRLF = "\n";
	if (!&put_header($FILE, "all") || !&put_body($FILE, 0, 0)) {
		close($FILE);
		unlink("$queue_dir/$max");
		return 0;
	}
	print STDERR "QUEUE stored in $queue_dir/$max\n"
		if ($Debug{"queue"});
	&log_history("queue", $max, "queued");
	return 1;
}

##### EXIT WITH ERROR REPORT #####
#
# error_exit()
#
sub error_exit {
	local ($rc);
#	if (!$Error_report_by_mail && !$Smtp_input_mode) {
#		$Error_report_by_mail = 1 unless (-t STDERR); # unless TTY
#	}
	if ($Error_report_by_mail) {
		# reset the server list
		@Smtp_servers = split(',', $Smtp_servers);
		push(@Smtp_servers, split(',', $Emg_Smtp_servers));

		do {
			$rc = &smtp_transaction_for_error_notify;
			&smtp_close($SMTPd, 1, 1) if ($rc);
		} while ($rc > 0 && $#Smtp_servers >= 0);
		if ($rc) {
			print STDERR $Errlog;
			@Response = ();
			$Cur_server = "";
			if ($Draft_message eq "") {
				&save_fcc($Dead_letter, 0, 1, 0);	# XXX
				&log_history("dead-letter", $Dead_letter,
					"sent");
				print STDERR "The message was saved in "
				  ."$Dead_letter\n";
			} else {
				&log_history("draft", $Draft_message,
					"preserved");
				print STDERR "Draft file $Draft_message "
				  ."preserved.\n";
			}
			&exit(1);
		}
		&exit(0);
	}
	if ($Smtp_input_mode) {
		while ($Errlog) {
			$Errlog =~ /^[^\n]+/;
			print STDOUT "554-$&\n";
			$Errlog =~ s/^[^\n]+\n//;
		}
		while ($Info) {
			$Info =~ /^[^\n]+/;
			print STDOUT "554- $&\n";
			$Info =~ s/^[^\n]+\n//;
		}
		while ($Session_log) {
			$Session_log =~ /^[^\n]+/;
			print STDOUT "554- $&\n";
			$Session_log =~ s/^[^\n]+\n//;
		}
		print STDOUT "554 Message was not accepted\n";
		&smtp_get_mail_final(1);
		&exit(1);
	} else {
		# notify to the terminal
		print STDERR "$Prog: delivery failed\n";
		if ($Errlog) {
			print STDERR "\n";
			print STDERR "Reason:\n";
			print STDERR "$Errlog\n";
		}
		if ($Info) {
			print STDERR "\n";
			print STDERR $Info;
		}
		if ($Session_log) {
			print STDERR "\n";
			print STDERR $Session_log;
		}
		@Response = ();
		$Cur_server = "";
		if ($Draft_message eq "") {
			# save in dead_letter unless the message was prepared
			# as a draft file.
			&save_fcc($Dead_letter, 0, 0, 0);	# XXX
			&log_history("dead-letter", $Dead_letter, "sent");
			print STDERR "The message was saved in $Dead_letter\n";
		} else {
			&log_history("draft", $Draft_message, "preserved");
			print STDERR "Draft file $Draft_message preserved.\n";
		}
		&exit(1);
	}
}

##### EXIT #####
#
# exit(stat)
#	stat: exit status
#
sub exit {
	local ($stat) = @_;
	&smtp_close($SMTPd, 0, 0);
	&nntp_close($NNTPd, 0, 0);
	&ssh_close();
	&close_aliases;
	exit $stat;
}

##### SSH_PROXY #####
#
# ssh_proxy(server,remote,local,host)
#	server: SMTP/NNTP server's host name.
#	remote: Port number on the server.
#	local:  A candidate of the port number on the local host.
#	host:   Relay Host.
# return value:
#	0: failed
#	otherwise: The connected port number of the local host.
#	
sub ssh_proxy {
	local( $server, $remote, $local, $host ) = @_;

	$Ssh_fh = "SSH00000" unless $Ssh_fh;

	print STDERR "openning SSH-tunnel to $server/$remote:$local via $host\n"
	    if ($Verbose);
	local( $pid, $read, $write );
      FORK: {
		$read  = $Ssh_fh++;
		$write = $Ssh_fh++;
		pipe( $read, $write );
		if( $pid = fork ){
			close $write;
			local( $buf, $i, $sig );
			for( $i=0; $i<3; $i++ ){
				$sig = $SIG{ALRM};
				$SIG{ALRM} = 'ssh_timeout_handler';
				eval {
					alarm 60;
					$buf = <$read>;
					alarm 0;
				};
				$SIG{ALRM} = $sig;
				if( $@ !~ /ssh_timeout_handler: SIGALRM is received/ ){
					push( @Ssh_pid, $pid );
					if( $buf =~ /ssh_proxy_connect/ ){
						return $local;
					} elsif( $buf =~ /Local: bind: Address already in use/ ){
						$local++;
						redo FORK;
					} elsif( $buf ){
						last;
					}
				}
			}
			$buf =~ s/\s+$//;
			$Errlog .= "Accident in Port Forwading: $buf\n";
			@Response = ( "Accident in Port Forwading: $buf" );
		} elsif( $pid == 0 ){
			close $read;
			open( STDOUT, ">&$write" );
			open( STDERR, ">&$write" );
			exec( 'ssh', '-n', '-x', '-o', 'BatchMode yes',
			      "-L$local:$server:$remote", $host,
			      'echo ssh_proxy_connect ; sleep 300' );
			exit 0; # Not reach.
		} elsif( $! =~ /No more process/ ){
			sleep 5;
			redo FORK;
		} else {
			$Errlog .= "Can't fork `ssh'.\n";
			@Response = ( "Can't fork `ssh'." );
		}
	}
	0;
}

# Internal subroutine.
sub ssh_timeout_handler {
	die "ssh_timeout_handler: SIGALRM is received\n";
}

##### SSH_CLOSE #####
#
# ssh_close()
#	return value: none
#
sub ssh_close {
	if( @Ssh_pid ){
		kill 15, @Ssh_pid;
		sleep 3;
		kill 9, @Ssh_pid;
	}
	@Ssh_pid = ();
}

##### END OF SCRIPT #####

### ToDo list
# PGP encription
# MCI for error respose
# 75 char len (1522)
# select SMTP server on each addresses
# connection timed out (signal)
# refusing large size messgae
# deliverability
# header MIME full encoding
# file locking for appending
# syslog