POP3 interface for fetchfml

1 files changed, 346 insertions, 0 deletions

diff --git a/fml/lib/FML/MUA/POP3.pm b/fml/lib/FML/MUA/POP3.pm
new file mode 100644
index 00000000..e96d6c47
--- /dev/null
+++ b/fml/lib/FML/MUA/POP3.pm
@@ -0,0 +1,346 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2005 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$
+#
+
+package FML::MUA::POP3;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+use FileHandle;
+
+# optional queue class.
+my $opt_class = [ "article_post", "command_mail", "error_mail_analyzer" ]; 
+
+
+=head1 NAME
+
+FML::MUA::POP3 - retrieve a message by pop3 protocol.
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 C<new()>
+
+constructor.
+
+=cut
+
+# Descriptions: constructor.
+#    Arguments: OBJ($self) OBJ($curproc)
+# Side Effects: none
+# Return Value: OBJ
+sub new
+{
+    my ($self, $curproc) = @_;
+    my ($type) = ref($self) || $self;
+    my $me     = { _curproc => $curproc };
+    return bless $me, $type;
+}
+
+
+# Descriptions: login to pop3 server.
+#    Arguments: OBJ($self) HASH_REF($r_args);
+# Side Effects: none
+# Return Value: OBJ
+sub login
+{
+    my ($self, $r_args) = @_;
+    my $server   = $r_args->{ server }   || '';
+    my $username = $r_args->{ username } || '';
+    my $password = $r_args->{ password } || '';
+    my $timeout  = $r_args->{ timeout  } || 60;
+
+    if ($server && $username && $password) {
+        use Net::POP3;
+        my $pop = Net::POP3->new($server, Timeout => $timeout);
+	if (defined $pop) {
+	    my $status = undef;
+	    my $capa   = $pop->capa();
+
+	    if ($capa->{ APOP }) {
+		$status = $pop->apop($username, $password);
+	    }
+	    unless ($status) {
+		$status = $pop->login($username, $password);
+	    }
+
+	    if (defined $status) {
+		$self->{ _pop } = $pop;
+		return $pop;
+	    }
+	    else {
+		$self->error_set("login failed.");
+	    }
+	}
+	else {
+	    $self->error_set("undefined object.");
+	}
+    }
+    else {
+	$self->error_set("invalid login arguments");
+    }
+}
+
+
+# Descriptions: retrieve messages.
+#    Arguments: OBJ($self) HASH_REF($r_args);
+# Side Effects: none
+# Return Value: OBJ
+sub retrieve
+{
+    my ($self, $r_args) = @_;
+    my $curproc = $self->{ _curproc };
+    my $pop     = $self->{ _pop }   || undef;
+    my $class   = $r_args->{ class } || undef;
+
+    if (defined $pop && defined $class) {
+	my $msgnums = $pop->list; # hashref of msgnum => size
+
+      MSG:
+	foreach my $msgnum (keys %$msgnums) {
+	    my $q = $self->_new_queue_file($r_args);
+	    if (defined $q) {
+		my $wh = $q->open("incoming", { mode => "w" });
+		if (defined $wh) {
+		    $wh->autoflush(1);
+
+		    $wh->clearerr();
+		    $pop->get($msgnum, $wh);
+		    if ($wh->error()) {
+			$curproc->logerror("failed to retrieve.");
+			$q->remove();
+		    }
+		    else {
+			my $id = $q->id();
+			$q->content_dup2($class);
+			$q->remove();
+			$curproc->log("fetched: qid=$id");
+		    }
+
+		    $wh->close();
+		}
+		else {
+		    last MSG;
+		}
+	    }
+	    else {
+		$curproc->logerror("queue not prepared");
+	    }
+	}
+    }
+    else {
+	$self->error_set("invalid state") unless defined $pop;
+	$self->error_set("invalid class") unless defined $class;
+    }
+}
+
+
+# Descriptions: close pop session.
+#    Arguments: OBJ($self) HASH_REF($r_args)
+# Side Effects: close pop session.
+# Return Value: none
+sub quit
+{
+    my ($self, $r_args) = @_;
+    my $pop = $self->{ _pop };
+
+    if (defined $pop) {
+	$pop->quit();
+    }
+}
+
+
+=head1 UTILITY
+
+=cut
+
+
+# Descriptions: new queue file path.
+#    Arguments: OBJ($self) HASH_REF($r_args);
+# Side Effects: none
+# Return Value: OBJ
+sub _new_queue_file
+{
+    my ($self, $r_args) = @_;
+    my $curproc   = $self->{ _curproc };
+    my $config    = $curproc->config(); 
+    my $queue_dir = $config->{ fetchfml_queue_dir };
+    my $class     = $r_args->{ class } || undef;
+
+    use Mail::Delivery::Queue;
+    my $queue = new Mail::Delivery::Queue {
+	directory   => $queue_dir,
+	local_class => $opt_class,
+    };
+    return $queue;
+}
+
+
+# Descriptions: pick up one queue and return the queue id.
+#    Arguments: OBJ($self) HASH_REF($r_args)
+# Side Effects: none
+# Return Value: OBJ
+sub pick_up_queue
+{
+    my ($self, $r_args) = @_;
+    my $curproc   = $self->{ _curproc };
+    my $config    = $curproc->config();
+    my $class     = $r_args->{ class } || $opt_class->[ 0 ];
+    my $queue_dir = $config->{ fetchfml_queue_dir };
+
+    use Mail::Delivery::Queue;
+    my $queue      = new Mail::Delivery::Queue { 
+	directory   => $queue_dir,
+	local_class => $opt_class,
+    };
+
+    my $list     = $queue->list($class, "oldest");
+    my $queue_id = $list->[ 0 ] || '';
+    if (defined $queue_id) {
+	my $queue       = new Mail::Delivery::Queue {
+	    id          => $queue_id,
+	    directory   => $queue_dir,
+	    local_class => $opt_class,
+	};
+	return $queue;
+    }
+    else {
+	return undef;
+    }
+}
+
+
+=head1 ERROR HADNLING
+
+=head2 error_set($reason)
+
+save error reason.
+
+=head2 error()
+
+return the last error reason.
+
+=cut
+
+
+# Descriptions: save error reason.
+#    Arguments: OBJ($self) STR($reason)
+# Side Effects: update reason.
+# Return Value: none
+sub error_set
+{
+    my ($self, $reason) = @_;
+    $self->{ _error_reason } = $reason;
+}
+
+
+# Descriptions: return the last error reason.
+#    Arguments: OBJ($self)
+# Side Effects: none
+# Return Value: STR
+sub error
+{
+    my ($self) = @_;
+    $self->{ _error_reason } || '';
+}
+
+
+#
+# debug
+#
+if ($0 eq __FILE__) {
+    my ($username, $password, $buf) = ();
+    my $server = shift @ARGV || croak("usage: $0 server\n");
+
+    use Term::ReadLine;
+    my $term   = new Term::ReadLine 'Simple Perl calc';
+    my $prompt = "Username: ";
+  LINE:
+    while ( defined ($buf = $term->readline($prompt)) ) {
+	system "stty -echo";
+	eval( $username = $buf );
+	last LINE if $@;
+	last LINE if $username;
+    }
+    $username =~ s/\s*$//;
+
+    $prompt = "Password: ";
+  LINE:
+    while ( defined ($buf = $term->readline($prompt)) ) {
+	system "stty -echo";
+	eval( $password = $buf );
+	last LINE if $@;
+	last LINE if $password;
+    }
+    $password =~ s/\s*$//;
+
+    print "\n";
+
+    if ($username && $password) {
+	use Net::POP3;
+	my $pop    = Net::POP3->new($server, Timeout => 60);
+	my $capa   = $pop->capa();
+	my $status = 0;
+
+	if ($capa->{ APOP }) {
+	    print "try apop ...\n";
+	    $status = $pop->apop($username, $password) || undef;
+	}
+	unless ($status) {
+	    print "try usual login ...\n";
+	    $status = $pop->login($username, $password) || undef;
+	}
+
+	if (defined $status) {
+	    if ($status > 0) {
+		my $msgnums = $pop->list; # hashref of msgnum => size
+		foreach my $msgnum (keys %$msgnums) {
+		    print ">>> $msgnum\n";
+		    $pop->get($msgnum, \*STDOUT);
+		    # $pop->delete($msgnum);
+		}
+	    }
+	}
+	else {
+	    croak("login failed.");
+	}
+
+	$pop->quit;
+    }
+    else {
+	croak("username and password unspecified.");
+    }
+}
+
+=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) 2005 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
+
+FML::MUA::POP3 appeared in fml8 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;