<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Yaa::Autoresponse;

use strict;
use Net::SMTP;
use Mail::Address;
use MIME::QuotedPrint;
use Encode qw/encode decode/;
use POSIX qw(strftime);
use Sys::Hostname;
use vars qw($VERSION);

use constant DEFAULT_CHARSET =&gt; 'us-ascii';
use constant MESSAGE_MAX_NUM_RECIPS =&gt; 100;
use constant HEADER_DATE_FORMAT =&gt; '%a, %e %b %Y %T %z';
use constant CRLF =&gt; "\r\n";

# set debugging constant if YAA_DEBUG environment variable is set
BEGIN {
	use constant DEBUG =&gt; ((defined $ENV{YAA_DEBUG}) ? 1 : 0);
	require File::Basename if (DEBUG);
}


$VERSION = '0.1';

######################################################
#               OBJECT CONSTRUCTOR                   #
######################################################

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self = {};

	##################################################
	#               PUBLIC VARS                      #
	##################################################

	# last error accoured
	$self-&gt;{error} = undef;

	##################################################
	#              PRIVATE VARS                      #
	##################################################
	
	# Yaa::Message object
	$self-&gt;{msg} = undef;

	bless($self, $class);
	
	$self-&gt;clearParams();
	$self-&gt;setParams(@_);
	
	return $self;
}



####################################################
#               PUBLIC METHODS                     #
####################################################

sub clearParams {
	my ($self) = @_;
	
	$self-&gt;{error} = undef;

	# clear message parameters
	$self-&gt;clearMessageParams();

	# mail sending method
	$self-&gt;{mail_sending_method} = "smtp";

	# SMTP settings
	$self-&gt;{smtp_server} = "localhost";
	$self-&gt;{smtp_helo} = hostname();
	$self-&gt;{smtp_auth} = 0;
	$self-&gt;{smtp_username} = undef;
	$self-&gt;{smtp_password} = undef;
	
	# Sendmail binary settings
	$self-&gt;{sendmail_path} = "/usr/sbin/sendmail";
	
	return 1;
}

=head2 setParams (key =&gt; value, key2 =&gt; value2)

Sets object's parameters. Parameters are driver dependent.

=cut
sub setParams {
	my ($self) = shift;

	while ((my $name = shift) &amp;&amp; (my $value = shift)) {
		$self-&gt;{$name} = $value if (substr($name, 0, 1) ne '_');
	}

	return 1;
}


sub clearMessageParams {
	my ($self) = @_;

	$self-&gt;{default_message} = undef;		# Autoresponse message settings
	$self-&gt;{default_charset} = DEFAULT_CHARSET;
	$self-&gt;{charset} = DEFAULT_CHARSET;
	$self-&gt;{msg} = undef;
}

# returns last error accoured
sub error {
	my ($self) = @_;
	return $self-&gt;{error};
}

sub setParsedMessage {
	my ($self, $msg) = @_;

	if (! defined $msg) {
		$self-&gt;{error} = "Message object was not given.";
		return 0;
	}
	elsif (ref($msg) ne 'Yaa::Message') {
		$self-&gt;{error} = "Message must be given as initialized Yaa::Message object.";
		return 0;
	}
	elsif (! $msg-&gt;isParsed()) {
		$self-&gt;{error} = "Yaa::Message object given, but no message was parsed yet.";
		return 0;
	}
	
	$self-&gt;{msg} = $msg;
	return 1;
}

sub sendAutoresponse {
	my ($self, $message, $subject, $sender, $recipient) = @_;

	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", sendAutoresponse(), line ", __LINE__, ": sender '$sender', recipient: '$recipient'\n" if (DEBUG);
	
	if (! (defined $self-&gt;{msg} &amp;&amp; $self-&gt;{msg}-&gt;isParsed)) {
		$self-&gt;{error} = "Unable to send autoresponse, becouse Yaa::Message object was is not set or object contains unparsed message.";
		return 0;
	}
	if (ref($message) ne 'SCALAR') {
		$self-&gt;{error} = "Message must be given as scalar reference.";
		return 0;
	}
	
	# 2007-02-12 Geert Janssens
	#	Reply subject can come from either original mail or configuration settings and in
	#	both cases it can be encoded is some way.
	#	It should be decoded before using it for the autoreply
	my $mycharset;
	my $mysubject;
	if (! length $subject) {
		# Original subject can be MIME encoded.
		# Decode first to perl internal character format
		$mysubject = "Re: " . decode('MIME-Header',$self-&gt;{msg}-&gt;getHeader("subject", 1));
	} else {
		# Stored subject can be encoded in charset specified by the user in the configuration settings
		# Decode first to perl internal character format
		$mycharset = ($self-&gt;{charset}) ? $self-&gt;{charset} : $self-&gt;{default_charset};
		$mysubject = decode($mycharset,$subject);
	}
	$$message = $self-&gt;{default_message} if (! length $$message);
	
	my $tmp;
	my @headers;
	
	# Prepare headers
	# Message ID
	push(@headers, "Message-ID: &lt;" . rand(4000000000) . '@' . hostname() . "&gt;");
	
	# From:
	$tmp = $self-&gt;{msg}-&gt;getRecipientName($sender);
	# Changed by actra.development 2008/11/21
	# Check first if the sender is a fully qualified address with name prepended, e.g. "John Doe" &lt;john@example.com&gt;
	# If we can't find a name or the address parsing failed use the possibly returned name from $self-&gt;{msg}-&gt;getRecipientName($sender)
	my @tmpAddr = Mail::Address-&gt;parse($sender);
	if(defined $tmpAddr[0]) {
		if(defined $tmpAddr[0]-&gt;phrase &amp;&amp; length($tmpAddr[0]-&gt;phrase)) {
			push(@headers, "From: " . $tmpAddr[0]-&gt;format());
		}
		else {
			push(@headers, "From: " . ((defined $tmp) ? '"' . $tmp . '" &lt;' : undef) . $sender . ((defined $tmp) ? '&gt;' : ''));
		}
	}
	else {
		push(@headers, "From: " . ((defined $tmp) ? '"' . $tmp . '" &lt;' : undef) . $sender . ((defined $tmp) ? '&gt;' : ''));
	}
	
	# To:
	$tmp = $self-&gt;{msg}-&gt;getSenderName();
	push(@headers, "To: " . (($tmp) ? '"' . $tmp . '"' : undef) . " &lt;" . $recipient . "&gt;");
	
	push(@headers, "Reply-To: &lt;&gt;");
	
	# Date:
	push(@headers, "Date: " . strftime(HEADER_DATE_FORMAT, localtime(time())));
	
	# Reply header
	$tmp = $self-&gt;{msg}-&gt;getHeader('Message-ID', 1);
	if (defined $tmp) {
		push(@headers, "In-Reply-To: " . $tmp);
		# hm, this could be MIME 1.0 non-compilant, becouse this could result in very long head line
		push(@headers, "References: " . $tmp . " " . $self-&gt;{msg}-&gt;getHeader('References'));
	}

	push(@headers, "Auto-Submitted: auto-replied");
	push(@headers, "Precedence: bulk");
	
	# Subject
	# 2007-02-12 Geert Janssens
	#	Headers should not be encoded with encode_qp from MIME:QuotedPrintable but with encode('MIME-...',$subject)
	#	See perldoc Encode::MIME::Header for more info
	push(@headers, "Subject: " . encode('MIME-Q', $mysubject));
	
	# Content Type
	push(@headers, "MIME-Version: 1.0");
	push(@headers, "Content-Type: text/plain;");
	push(@headers, '        charset="' . $self-&gt;{charset} . '"');
	push(@headers, "Content-Transfer-Encoding: Quoted-Printable");
	
	return $self-&gt;_sendMessage(\ @headers, $message, $sender, $recipient);
}

sub forwardMessage {
	my ($self, $sender, $recipient) = @_;
	
	unless (defined $recipient) {
		$self-&gt;{error} = "Unable to forward message to undefined address.";
		return 0;
	}
	
	return $self-&gt;_sendMessage(\ $self-&gt;{msg}-&gt;getHeadersAsString(), $self-&gt;{msg}-&gt;getMessageFh(), $sender, $recipient);
}

####################################################
#               PRIVATE METHODS                    #
####################################################

sub _sendMessage {
	my ($self, $headers, $message, $sender, $recipient) = @_;
	my $tmp;
	
	if (! $sender) {
		$self-&gt;{error} = "To few arguments. Minimum number of arguments is 5.";
		return 0;
	}
	elsif (($tmp = ref($headers)) ne 'ARRAY' &amp;&amp; $tmp ne 'SCALAR') {
		$self-&gt;{error} = "Headers must be provided as array or scalar reference.";
		return 0;
	}
	elsif (($tmp = ref($message)) ne 'SCALAR' &amp;&amp; substr($tmp, 0, 4) ne 'IO::') {
		$self-&gt;{error} = "Message body must be provided as scalar or filehandle reference.";
		return 0;
	}
	
	if ($self-&gt;{mail_sending_method} eq 'smtp') {
		return $self-&gt;_sendMessageSMTP($headers, $message, $sender, $recipient);
	}
	elsif ($self-&gt;{mail_sending_method} eq 'sendmail') {
		return $self-&gt;_sendMessageSendmail($headers, $message, $sender, $recipient);
	}
	else {
		$self-&gt;{error} = "Unknown mail sending method '" . $self-&gt;{mail_sending_method} . "'.";
		return 0;
	}
}

sub _sendMessageSMTP {
	my ($self, $headers, $message, $sender, $recipient) = @_;

	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": connecting to smtp server.\n" if (DEBUG);
	my $smtp = Net::SMTP-&gt;new(
		$self-&gt;{smtp_server},
		timeout =&gt; $self-&gt;{smtp_timeout},
		Hello =&gt; $self-&gt;{smtp_helo},
		Debug =&gt; DEBUG
	);

	if (! defined $smtp) {
		$self-&gt;{error} = "Unable to connect to SMTP server '" . $self-&gt;{smtp_server} . "': " . $!;
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": ", $self-&gt;{error}, "\n" if (DEBUG);
		return 0;
	}
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": successfully connected.\n" if (DEBUG);

	if (! defined $smtp-&gt;domain) {
		$self-&gt;{error} = "Invalid greeting received from SMTP server: " . $smtp-&gt;message;
		return 0;
	}
		
	# authenticate?
	if ($self-&gt;{smtp_auth}) {
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": proceeding with smtp authentication.\n" if (DEBUG);
		if (! (defined $self-&gt;{smtp_user} &amp;&amp; defined $self-&gt;{smtp_pass})) {
			$self-&gt;{error} = "You must provide username and password in order to use SMTP Auth";
			return 0;
		}
		elsif (! $smtp-&gt;auth($self-&gt;{smtp_user}, $self-&gt;{smtp_pass})) {
			$self-&gt;{error} = "SMTP authentication failed";
			return 0;
		}
	}
			
	# we are connected.
	# sender email address (MAIL FROM:)
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": sending MAIL FROM: command.\n" if (DEBUG);
	$smtp-&gt;mail($sender);
	if ($smtp-&gt;code != 250) {
		$self-&gt;{error} = "SMTP server said after MAIL FROM: " . $smtp-&gt;message;
		$smtp-&gt;quit;
		$smtp = undef;
		return 0;
	}
			
	# send recipients (RCPT TO:)
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": sending RCPT TO: commands.\n" if (DEBUG);
	$smtp-&gt;recipient($recipient);
			
	if ($smtp-&gt;code != 250) {
		$self-&gt;{error} = "SMTP server said after RCPT TO: " . $smtp-&gt;message;
		$smtp-&gt;quit;
		$smtp = undef;
		return 0;
	}
			
	# send DATA
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": sending DATA command.\n" if (DEBUG);
	$smtp-&gt;data();
	if ($smtp-&gt;code != 354) {
		$self-&gt;{error}="SMTP server said after DATA: " . $smtp-&gt;message;
		$smtp-&gt;quit;
		$smtp = undef;
		return 0;
	}
			
	# send headers
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": sending message headers.\n" if (DEBUG);
	if (ref($headers) eq 'ARRAY') {
		$smtp-&gt;datasend($_ . CRLF) foreach (@{$headers});
	} else {
		$smtp-&gt;datasend($$headers);
		$smtp-&gt;datasend(CRLF);
	}
	
	# send CRLF
	$smtp-&gt;datasend(CRLF);
	
	# send message
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": sending message body.\n" if (DEBUG);
	if (substr(ref($message), 0, 4) eq 'IO::') {
		$smtp-&gt;datasend($_) while (&lt;$message&gt;);
	} else {
		$smtp-&gt;datasend($$message);
	}
  
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": finishing smtp transaction.\n" if (DEBUG);
	$smtp-&gt;dataend();
			
	# end of message, check results
	if ($smtp-&gt;code != 250) {
		$self-&gt;{error} = "SMTP server said: " . $smtp-&gt;message;
		$smtp-&gt;quit;
		$smtp = undef;
		return 0;
	}
	
	# disconnect from server
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSMTP(), line ", __LINE__, ": disconnecting from smtp server.\n" if (DEBUG);
	if (! $smtp-&gt;quit()) {
		$self-&gt;{error} = "Error disconnecting from STMP server: " . $smtp-&gt;message;
		return 0;
	}
	
	# uf. it's over.
	return 1;
}


# sends message using sendmail binary
sub _sendMessageSendmail {
	my ($self, $headers, $message, $sender, $recipient) = @_;

	unless (defined $self-&gt;{sendmail_path}) {
		$self-&gt;{error} = "Error sending message: unable to run sendmail binary: path to executable is not defined.";
		return 0;
	}

	my $args = "| " . $self-&gt;{sendmail_path} . " -f '" . $sender . "' '" . $recipient . "'";
	
	my $flush_status = $|;
	$| = 1;

	local *YAA_SENDMAIL_PROC;
	local $SIG{PIPE} = sub {
		print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSendMail(), line ", __LINE__, ": got SIGPIPE.\n" if (DEBUG);
		$self-&gt;{error} = "Error sending message: sendmail binary broke message pipe.";
		$self-&gt;_logger("Error: " . $self-&gt;{error});
		return 0;
	};

	# run process
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSendMail(), line ", __LINE__, ": Running sendmail binary: $args\n" if (DEBUG);
	if (! open(YAA_SENDMAIL_PROC, $args)) {
		$self-&gt;{error} = "Error sending message: unable to run sendmail binary " . $self-&gt;{sendmail_path} . ": " .$!;
		return 0;
	}

	# print headers
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSendMail(), line ", __LINE__, ": pipeing message headers to sendmail binary.\n" if (DEBUG);
	if (ref($headers) eq 'ARRAY') {
		if (DEBUG) {
			print STDERR $_, CRLF foreach (@{$headers});
		}
		print YAA_SENDMAIL_PROC $_, CRLF foreach (@{$headers});
	} else {
		print STDERR $$headers, "\n" if (DEBUG);
		print YAA_SENDMAIL_PROC $$headers;
	}

	print YAA_SENDMAIL_PROC $_, CRLF;
			
	# print message
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSendmail(), line ", __LINE__, ": pipeing message body to sendmail binary.\n" if (DEBUG);
	if (substr(ref($message), 0, 4) eq 'IO::') {
		while (&lt;$message&gt;) {
			print STDERR $_ if (DEBUG);
			print YAA_SENDMAIL_PROC $_;
		}
		print STDERR "\n" if (DEBUG);
	} else {
		print STDERR $$message, "\n" if (DEBUG);
		print YAA_SENDMAIL_PROC $$message;
	}

	$| = $flush_status;

	# close process
	print STDERR "DEBUG: ",  File::Basename::basename(__FILE__), ", _sendMessageSendMail(), line ", __LINE__, ": closing pipe to sendmail binary.\n" if (DEBUG);
	if (! close(YAA_SENDMAIL_PROC)) {
		$self-&gt;{error} = "Error sending message: sendmail command died with exit status: " . $?;
		return 0;
	}

	return 1;
}

1;

=head1 SEE ALSO

perldoc Yaa.

=cut

=head1 AUTHOR

Branko F. Gracnar &lt;bfg@frost.ath.cx&gt;
http://frost.ath.cx/~bfg

=cut

=head1 LICENSE

This software is released under BSD-style license. If you like this software, send me a nice postcard from somewhere to the snail mail address published on my website.

=cut

</pre></body></html>