Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling

Re: POP3/IMAP Server modules?

by bbfu (Curate)
on Apr 13, 2003 at 17:50 UTC ( #250153=note: print w/replies, xml ) Need Help??

in reply to POP3/IMAP Server modules?

Actually, I just made Net::Server::POP3::Skeleton over the last few weeks. I haven't quite finished documenting it, but it should be what you need. Obviously, it's Net::Server based, and you have to implement most of the commands yourself, but all the commands are trivial to implement.

(Update: In case you're planning on running this on Win32, I just want to let you know that Net::Server does work on Win32. The forking personality (the one this code uses by default) requires perl 5.8 because there was a bug in the fork emulation in 5.6 that caused perl to crash, and I had a problem with the tests hanging (due to a call to POSIX::setsid which doesn't work on Win32) but it works fine if you just skip the tests. Just wanted you to be aware so you don't think you can't use it on Win32. I'm using it on Win32, so I know it works. :p)

I wrote an implementation using Mail::Webmail::Yahoo so that I could access my Yahoo email via my POP3 client. If you want to see an implementation of the various commands, let me know and I'll post my Yahoo mail module, too.

Click readmore to see the code:
(Code updated and moved to Net::Server::POP3::Skeleton)


Update: Updated the code and it's POD a little bit.

Update: As per request via /msg, I'm including my implementation of a server. It basically creates a proxy-type POP3 server that accesses and manipulates the messages directly via Yahoo's website.

Note that this code uses a modified version of Mail::Webmail::Yahoo, as the normal copy didn't work correctly out of the box and didn't include a way to move / delete messages. So the code almost definately won't run using the vanilla Mail::Webmail::Yahoo. Eventually, I hope to factor my changes out of the Mail::Webmail::Yahoo module and into my code, though I'm not sure how feasable that is...

Click readmore for the implementation code

#!/usr/bin/winperl use warnings; use strict; use lib '.'; use base 'Net::Server::POP3::Skeleton'; use POSIX 'strftime'; use Mail::Webmail::Yahoo; use constant PEND_INDEX => 0; use constant PEND_MESSG => 1; # Make STDOUT and STDERR autoflush select((select(STDOUT), $|=1, select(STDERR), $|=1)[0]); our $INBOX_FOLDER = 'Inbox'; our $TRASH_FOLDER = 'Trash'; # Create and start the server. main->new( greeting => 'POP3 Perl::Yahoo::POP ready', host => 'localhost', log_file => 'yahoo.log', log_level => 2, #setsid => 1, # Doesn't work on Win32 )->run(); #********* Command Implementations *********# sub user { my $self = shift; my $name = shift; unless(defined $name) { $self->senderr("missing argument"); return; } $self->log(4, "Received USER: $name"); $self->set('username', $name); $self->sendok("username accepted, send password"); } sub pass { my $self = shift; my $pass = shift; my $name = $self->get('username'); return $self->unknown() unless defined $name; return $self->senderr("missing argument") unless defined $pass; $self->log(4, "Received PASS: $pass"); $self->set('password', $pass); my $yahoo = Mail::Webmail::Yahoo->new( username => $self->get('username'), password => $self->get('password'), ); $yahoo->trace(1) if $self->{server}{debug}; $self->log(3, "Received auth, attempting login"); unless($yahoo->login) { $self->log(0, "Auth failure ($@)"); $self->senderr("connection or authentication failure ($@)"); $self->set('username', undef); return; } $yahoo->guess_text_on_multipart(1); $self->set('yahoo', $yahoo); $self->state('TRANS'); my @msgs = $yahoo->get_folder_index($INBOX_FOLDER); $self->set('message list', \@msgs); $self->set('message count', scalar @msgs); $self->log(2, "Logged on as ".$self->get('username')." (".@msgs." ms +gs)"); $self->sendok(@msgs . " messages"); } sub stat { my $self = shift; my @msgs = @{$self->get('message list')}; my $size = 0; $size += size2oct($_->{size}) for @msgs; $self->log(4, "Received STAT: ".@msgs." $size"); $self->sendok(@msgs . " $size"); } sub list { my $self = shift; my $msg = shift; my @msgs = @{$self->get('message list')}; $self->log(4, "Received LIST: " . defined($msg) ? $msg : '<undef>'); if(defined $msg and (1 > $msg || $msg > @msgs) || !defined $msgs[$ms +g-1]) { $self->senderr("no such message"); return; } my @results = map { "$_ ".size2oct($msgs[$_-1]{size}) } (defined $ms +g ? $msg : grep { defined $msgs[$_-1] } 1..@msgs ); $self->senddata($self->get('message count') . " messages", @results) +; } sub retr { my $self = shift; my $msg = shift; my $msgs = $self->get('message list'); my $yahoo = $self->get('yahoo'); unless(defined $msg) { $self->senderr("missing argument: message number"); return; } if((1 > $msg || $msg > @$msgs) or not defined($msgs->[$msg-1])) { $self->senderr("no such message"); return; } $self->log(3, "Retrieving message #$msg"); my ($msgb) = $yahoo->get_mail_messages($INBOX_FOLDER, [$msgs->[$msg- +1]]); chomp(my @msg = split /\n/, $msgb->as_string); $self->senddata("message follows", @msg); } sub dele { my $self = shift; my $msg = shift; my $yahoo = $self->get('yahoo'); my $msgs = $self->get('message list'); my $pend = $self->get('pending'); if(not defined $pend) { $pend = []; $self->set('pending', $pend); } $self->log(4, "Received DELE: " . defined($msg) ? $msg : '<undef>'); if((defined $msg and 1 > $msg || $msg > @$msgs) or !defined $msgs->[ +$msg-1]) { $self->senderr("no such message"); return; } $self->log(3, "Deleting message #$msg"); push @$pend, [$msg, $msgs->[$msg-1]]; undef $msgs->[$msg-1]; $self->set('message count', $self->get('message count')-1); $self->sendok("message deleted"); } sub noop { my $self = shift; $self->log(4, "Received NOOP"); shift->sendok("nothing done"); } sub rset { my $self = shift; my $yahoo = $self->get('yahoo'); my $pend = $self->get('pending'); my $msgs = $self->get('message list'); $self->log(4, "Received RSET"); if(defined $pend and @$pend) { # Copy the messages back $msgs->[$_->[PEND_INDEX]-1] = $_->[PEND_MESSG] for @$pend; # Reset state (count and list of pending) $self->set('message count', scalar @$msgs); $self->set('pending', []); } $self->log(3, "Reset to ".@$msgs." messages"); $self->sendok("messages reset; ".@$msgs." messages"); } sub top { my $self = shift; my $args = shift; my $yahoo = $self->get('yahoo'); my @msgs = @{$self->get('message list')}; $args =~ s/^\s+//; my ($msg, $lines) = split /\s+/, $args; $self->log(4, "Received TOP: " . (defined $msg ? $msg : '<undef>') . (defined $lines ? $lines : '<undef>') ); unless(defined $msg) { $self->senderr("missing argument: message number"); return; } unless(defined $lines) { $self->senderr("missing argument: number of lines"); return; } unless(1 <= $msg && $msg <= @msgs && defined $msgs[$msg-1]) { $self->senderr("no such message"); return; } unless($lines >= 0) { $self->senderr("invalid number of lines"); return; } $lines = @msgs if $lines > @msgs; my ($msgb) = $yahoo->get_mail_messages($INBOX_FOLDER, [$msgs[$msg-1] +]); chomp(my @head = @{$msgb->head->header}); chomp(my @body = @{$msgb->body}); $self->senddata("top of message follows", @head, '', @body[0..$lines +-1]); } sub uidl { my $self = shift; # Message-ids must persist across sessions. # Yahoo's message-ids don't. In fact, they # change when you move the message to another # folder. Maybe in the future I will find a # way to implement this. #$self->senderr("command not implemented"); #return; # The following does not create valid (ie, # persisting across sessions) message-ids. # Though, I *think* they only change when # the message is moved, so it should be # close enough. my ($msg) = split /\s+/, shift; my @msgs = @{$self->get('message list')}; $self->log(4, "Received UIDL: " . defined $msg ? $msg : '<undef>'); if(defined $msg and (1 > $msg || $msg > @msgs) || !defined $msgs[$ms +g-1]) { $self->senderr("no such message"); return; } my @results = map { "$_ ".$msgs[$_-1]{id} } (defined $msg ? $msg : grep { defined $msgs[$_-1] } 1..@msgs ); if(@results == 1) { $self->sendok(@results); } else { $self->senddata(@msgs . " messages", @results); } } #********* Non-Command Methods *********# sub commit { my $self = shift; my $yahoo = $self->get('yahoo'); my $pend = $self->get('pending'); $self->log(2, "Client QUIT"); return unless defined $pend and @$pend; $self->log(1, "Committing ".@$pend." messages to Trash"); $yahoo->move($INBOX_FOLDER, $TRASH_FOLDER, map { $_->[PEND_MESSG] } +@$pend); $self->set('pending', []); } sub disconnect { my $self = shift; my $yahoo = $self->get('yahoo'); my $pend = $self->get('pending'); $self->log(2, "Client disconnected"); $self->set('yahoo', undef); $self->set('username', undef); $self->set('password', undef); return unless defined $pend and @$pend; $self->log(2, "Cleaning up ".@$pend." messages back to Inbox"); $self->set('pending', []); } sub write_to_log_hook { my $self = shift; my $lvl = shift; my $msg = shift || ''; my $date = strftime("[%d-%b-%Y %H:%M:%S]:", localtime); $self->SUPER::write_to_log_hook($lvl, "$date $msg"); return; } #********* Helper Functions *********# sub size2oct { my $size = uc(shift || ''); return 0 unless $size =~ /^\s*(\d+)\s*([BKM])\s*$/; return $1 * 1024 * 1024 if $2 eq 'M'; return $1 * 1024 if $2 eq 'K'; return $1; }

Black flowers blossom
Fearless on my breath

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://250153]
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (3)
As of 2021-05-16 23:38 GMT
Find Nodes?
    Voting Booth?
    Perl 7 will be out ...

    Results (152 votes). Check out past polls.