summaryrefslogtreecommitdiff
path: root/regress/tinymta/SMTP.pm
diff options
context:
space:
mode:
Diffstat (limited to 'regress/tinymta/SMTP.pm')
-rw-r--r--regress/tinymta/SMTP.pm317
1 files changed, 317 insertions, 0 deletions
diff --git a/regress/tinymta/SMTP.pm b/regress/tinymta/SMTP.pm
new file mode 100644
index 00000000..2abf2470
--- /dev/null
+++ b/regress/tinymta/SMTP.pm
@@ -0,0 +1,317 @@
+#-*- perl -*-
+#
+# Copyright (C) 2006 Ken'ichi Fukamachi
+# All rights reserved. This program is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#
+# $FML: @template.pm,v 1.10 2006/01/07 13:16:41 fukachan Exp $
+#
+
+package TinyMTA::SMTP;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+
+=head1 NAME
+
+TinyMTA::SMTP - smtp
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 new()
+
+constructor.
+
+=cut
+
+
+# Descriptions: constructor.
+# Arguments: OBJ($self) OBJ($config)
+# Side Effects:
+# Return Value: none
+sub new
+{
+ my ($self, $config) = @_;
+ my ($type) = ref($self) || $self;
+ my $me = { _config => $config };
+ return bless $me, $type;
+}
+
+
+# Descriptions: main routine.
+# Arguments: OBJ($self)
+# Side Effects: none
+# Return Value: none
+sub run
+{
+ my ($self) = @_;
+ my $config = $self->{ _config };
+
+ my $q_list = $self->pickup_queue();
+ for my $q (@$q_list) {
+ $self->log("try to send: $q");
+ $self->send($q);
+ }
+}
+
+
+# Descriptions: pick up queue (id's) and return it as ARRAY_REF.
+# Arguments: OBJ($self)
+# Side Effects: none
+# Return Value: ARRAY_REF
+sub pickup_queue
+{
+ my ($self) = @_;
+ my $config = $self->{ _config };
+
+ my (@queue) = ();
+
+ use DirHandle;
+ my $queue_dir = $config->{ queue_dir };
+ my $dh = new DirHandle $queue_dir;
+ if (defined $dh) {
+ my $entry;
+
+ ENTRY:
+ while ($entry = $dh->read()) {
+ next ENTRY if $entry =~ /^\./o;
+ next ENTRY if $entry =~ /^\,/o;
+ next ENTRY if $entry =~ /^\_/o;
+ next ENTRY if $entry !~ /^\d/o;
+
+ push(@queue, $entry);
+ }
+
+ $dh->close();
+ }
+ else {
+ $self->logerror("cannot open $queue_dir");
+ croak("cannot open $queue_dir");
+ }
+
+ return \@queue;
+}
+
+
+# Descriptions: send queue.
+# Arguments: OBJ($self)
+# Side Effects: queue is removed if succeeded.
+# Return Value: none
+sub send
+{
+ my ($self, $q) = @_;
+ my $qf_candidate = $self->queue_file_path($q);
+ my $qf_locked = $self->queue_file_path("_$q");
+
+ if (rename($qf_candidate, $qf_locked)) {
+ $self->_send_file($qf_locked);
+ }
+ else {
+ $self->logerror("cannot lock queue: $q");
+ }
+}
+
+
+# Descriptions: return full path for queue id.
+# Arguments: OBJ($self) STR($qid)
+# Side Effects: none
+# Return Value: STR
+sub queue_file_path
+{
+ my ($self, $qid) = @_;
+ my $config = $self->{ _config };
+ my $queue_dir = $config->{ queue_dir };
+
+ use File::Spec;
+ return File::Spec->catfile($queue_dir, $qid);
+}
+
+
+# Descriptions: send $queue_file by Mail::Delivery.
+# Arguments: OBJ($self) HASH_REF($args)
+# Side Effects: queue removed if suceeded.
+# Return Value: none
+sub _send_file
+{
+ my ($self, $queue_file) = @_;
+ my $config = $self->{ _config };
+ my $queue_dir = $config->{ queue_dir };
+
+ use Mail::Message;
+ my $message = Mail::Message->parse( { file => $queue_file } );
+
+ my ($sender, $rcpt_maps) = $self->_analyze_message($message);
+
+ use Mail::Delivery::Queue;
+ my $queue = new Mail::Delivery::Queue { directory => $queue_dir };
+
+ my $validater = sub {
+ my ($address) = @_;
+ use FML::Restriction::Base;
+ my $restriction = new FML::Restriction::Base;
+ return $restriction->regexp_match( 'address', $address );
+ };
+
+ use Mail::Delivery;
+ my $logfp_normal = sub { $self->log(@_); };
+ my $logfp_error = sub { $self->log(@_); };
+ my $service = new Mail::Delivery {
+ log_info_function => $logfp_normal,
+ log_error_function => $logfp_error,
+ log_debug_function => undef,
+ smtp_log_function => undef,
+ smtp_log_handle => undef,
+ address_validate_function => $validater,
+ };
+ if ($service->error) {
+ # log($service->error);
+ croak("cannot initialize Mail::Delivery object");
+ }
+
+ $service->deliver({
+ 'smtp_servers' => $config->{'smtp_servers'},
+
+ 'smtp_sender' => $sender,
+ 'recipient_array' => $rcpt_maps,
+ 'recipient_limit' => $config->{smtp_recipient_limit},
+
+ 'message' => $message,
+
+ queue => $queue,
+
+ # XXX do not need fallback here ?
+ use_queue_dir => 1,
+ queue_dir => $queue_dir,
+ });
+ if ($service->error) {
+ $self->logerror($service->error);
+ croak($service->error);
+ }
+
+ # delivery not completes.
+ if ($service->get_not_done()) {
+ $self->logerror("delivery not done");
+ croak("delivery not done");
+ }
+
+ # done.
+ unlink $queue_file;
+ unless (-f $queue_file) {
+ use File::Basename;
+ my $qid = basename($queue_file);
+ $qid =~ s/^_//;
+ $self->log("$qid removed");
+ }
+}
+
+
+# Descriptions: analyze message and return sender and recipients info.
+# Arguments: OBJ($self) STR($msg)
+# Side Effects: none
+# Return Value: ARRAY(STR, ARRAY_REF)
+sub _analyze_message
+{
+ my ($self, $msg) = @_;
+ my $header = $msg->whole_message_header();
+
+ # results
+ my ($sender) = '';
+ my ($rcpt_maps) = [];
+
+ {
+ my $from = $header->get('from');
+ use Mail::Address;
+ my (@addrlist) = Mail::Address->parse($from);
+ if (defined $addrlist[0]) {
+ $sender = $addrlist[0]->address;
+ }
+ }
+
+ {
+ my $to = $header->get('to') || '';
+ my $cc = $header->get('cc') || '';
+ my $bcc = $header->get('bcc') || '';
+ use Mail::Address;
+ my (@addrlist) = Mail::Address->parse("$to, $cc, $bcc");
+ if (defined $addrlist[0]) {
+ for my $a (@addrlist) {
+ if ($a->address) {
+ push(@$rcpt_maps, $a->address);
+ }
+ }
+ }
+ }
+
+ return($sender, $rcpt_maps);
+}
+
+
+# Descriptions: log as normal level.
+# Arguments: OBJ($self) STR($msg)
+# Side Effects: none
+# Return Value: none
+sub log
+{
+ my ($self, $msg) = @_;
+ &TinyMTA::Log::log($msg);
+}
+
+
+# Descriptions: log as error level.
+# Arguments: OBJ($self) STR($msg)
+# Side Effects: none
+# Return Value: none
+sub logerror
+{
+ my ($self, $msg) = @_;
+ &TinyMTA::Log::log("error: $msg");
+}
+
+
+######################################################################
+#
+# dispatcher
+#
+
+# Descriptions: main dispatcher.
+# Arguments: OBJ($main_cf) STR($config_cf_file)
+# Side Effects: none
+# Return Value: none
+sub main::dispatch
+{
+ my ($main_cf, $config_cf_file) = @_;
+
+ my $config = TinyMTA::Config::load_file($config_cf_file, $main_cf);
+ my $obj = new TinyMTA::SMTP $config;
+ $obj->run();
+}
+
+
+=head1 CODING STYLE
+
+See C<http://www.fml.org/software/FNF/> on fml coding style guide.
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Ken'ichi Fukamachi
+
+All rights reserved. This program is free software; you can
+redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 HISTORY
+
+TinyMTA::SMTP appeared in fml8 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;
generated by cgit v1.2.1 (git 2.18.0) at 2026-09-30 10:10:43 +0000