Mail-Box-POP3-4.01/ 0000755 0001750 0000144 00000000000 15117246024 014305 5 ustar 00markov users 0000000 0000000 Mail-Box-POP3-4.01/README.md 0000644 0001750 0000144 00000004360 15117237340 015570 0 ustar 00markov users 0000000 0000000 # distribution Mail-Box-POP3
* My extended documentation:
* Development via GitHub:
* Sponsor me:
* Download from CPAN:
* Indexed from CPAN:
Until release 3.0, this module was an integral part of the Mail-Box
distribution. This distribution implements a client connector to a
POP3 server.
## Installing
On github, you can find the processed version for each release. But the
better source is CPAN; to get it installed simply run:
```sh
cpan -i Mail::Box::POP3
```
**Be aware that version 4 is not fully compatible with releases pre-4**
See
## Development → Release
Important to know, is that I use an extension on POD to write the manuals.
The "raw" unprocessed version is visible on GitHub. It will run without
problems, but does not contain manual-pages.
Releases to CPAN are different: "raw" documentation gets removed from
the code and translated into real POD and clean HTML. This reformatting
is implemented with the OODoc distribution (A name I chose before OpenOffice
existed, sorry for the confusion)
Clone from github for the "raw" version. For instance, when you want
to contribute a new feature.
## Contributing
When you want to contribute to this module, you do not need to provide
a perfect patch... actually: it is nearly impossible to create a patch
which I will merge without modification. Usually, I need to adapt the
style of code and documentation to my own strict rules.
When you submit an extension, please contribute a set with
1. code
2. code documentation
3. regression tests in t/
**Please note:**
When you contribute in any way, you agree to transfer the copyrights to
Mark Overmeer (you will get the honors in the code and/or ChangeLog).
You also automatically agree that your contribution is released under
the same license as this project: licensed as perl itself.
## Copyright and License
This project is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See
Mail-Box-POP3-4.01/t/ 0000755 0001750 0000144 00000000000 15117246023 014547 5 ustar 00markov users 0000000 0000000 Mail-Box-POP3-4.01/t/01basic.t 0000644 0001750 0000144 00000004325 15117237340 016164 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use warnings;
use strict;
use Mail::Box::POP3::Test;
use Mail::Box::Test;
use File::Spec ();
use File::Basename qw(dirname);
use Test::More;
$ENV{MARKOV_DEVEL} or plan skip_all => "tests are fragile, skipped";
use_ok('Mail::Transport::POP3');
# Check if all methods are there OK
can_ok('Mail::Transport::POP3', qw(
deleted
deleteFetched
DESTROY
disconnect
fetched
folderSize
header
ids
id2n
init
message
messages
messageSize
send
sendList
socket
url
));
my $here = dirname __FILE__;
my $original = File::Spec->catdir($here, 'original');
my $popbox = File::Spec->catdir($here, 'popbox');
copy_dir($original, $popbox);
my ($server, $port) = start_pop3_server($popbox);
my $receiver = start_pop3_client($port);
isa_ok($receiver, 'Mail::Transport::POP3');
my $socket = $receiver->socket;
ok($socket, "Could not get socket of POP3 server");
print $socket "EXIT\n";
my @message = <$popbox/????>;
my $total = 0;
$total += -s foreach @message;
my $messages = @message;
cmp_ok($receiver->messages, '==', $messages, "Wrong number of messages");
cmp_ok($receiver->folderSize, '==', $total, "Wrong number of bytes");
my @id = $receiver->ids;
cmp_ok(scalar(@id), '==', scalar(@message), "Number of messages doesn't match");
is(join('',@id), join('',@message), "ID's don't match filenames");
my $error = '';
foreach(@id)
{ my ($reported, $real) = ($receiver->messageSize($_),-s);
$error .= "size $_ is not right: expected $real, got $reported\n"
if $reported != $real;
}
ok(!$error, ($error || 'No errors with sizes'));
$error = '';
foreach(@id)
{ my $message = $receiver->message($_);
open(my $handle, '<', $_);
$error .= "content of $_ is not right\n"
if join('', @$message) ne join('', <$handle>);
}
ok(!$error, $error || 'No errors with contents');
$receiver->deleted(1,@id);
ok($receiver->disconnect, 'Failed to properly disconnect from server');
@message = <$popbox/????>;
cmp_ok(scalar(@message) ,'==', 0, 'Did not remove messages at QUIT');
ok(rmdir($popbox), "Failed to remove $popbox directory: $!");
is(join('', <$server>), <
Delivered-To: xx-woppa@xx.nl
Received: (qmail 29439 invoked from network); 8 Jul 2002 20:27:13 -0000
Received: from smtpzilla1.xs4all.nl (194.109.127.137)
by ds051.xs4all.nl with SMTP; 8 Jul 2002 20:27:13 -0000
Received: from valizo (a80-127-230-87.dial.xs4all.nl [80.127.230.87])
by smtpzilla1.xs4all.nl (8.12.0/8.12.0) with ESMTP id g68KRdEr060805
for ; Mon, 8 Jul 2002 22:27:43 +0200 (CEST)
Message-Id: <4.2.0.58.20020708222802.024df4a0@mickey.dijkmat.nl>
X-Sender: lm@mickey.dijkmat.nl
X-Mailer: QUALCOMM Windows Eudora Pro Version 4.2.0.58
Date: Mon, 08 Jul 2002 22:28:03 +0200
To: woppa@xx.nl
From: Elizabeth Mattijsen
Subject: test
Mime-Version: 1.0
Content-Type: text/plain; charset="us-ascii"; format=flowed
Mail-Box-POP3-4.01/t/original/0002 0000644 0001750 0000144 00000001436 15117237340 016665 0 ustar 00markov users 0000000 0000000 Return-Path:
Delivered-To: xx-woppa@xx.nl
Received: (qmail 29414 invoked from network); 8 Jul 2002 20:25:55 -0000
Received: from smtpzilla5.xs4all.nl (194.109.127.141)
by ds051.xs4all.nl with SMTP; 8 Jul 2002 20:25:55 -0000
Received: from valizo (a80-127-230-87.dial.xs4all.nl [80.127.230.87])
by smtpzilla5.xs4all.nl (8.12.0/8.12.0) with ESMTP id g68KQRdP007359
for ; Mon, 8 Jul 2002 22:26:28 +0200 (CEST)
Message-Id: <4.2.0.58.20020708222644.02efb4b0@mickey.dijkmat.nl>
X-Sender: lm@mickey.dijkmat.nl
X-Mailer: QUALCOMM Windows Eudora Pro Version 4.2.0.58
Date: Mon, 08 Jul 2002 22:26:52 +0200
To: woppa@xx.nl
From: Elizabeth Mattijsen
Subject: test
Mime-Version: 1.0
Content-Type: text/plain; charset="us-ascii"; format=flowed
Mail-Box-POP3-4.01/t/original/0004 0000644 0001750 0000144 00000006763 15117237340 016677 0 ustar 00markov users 0000000 0000000 Return-Path:
Delivered-To: xx-xxxxx@xx.nl
Received: (qmail 29622 invoked from network); 8 Jul 2002 20:39:46 -0000
Received: from softdnserror (HELO w0.xxxletter.com) (66.181.174.116)
by ds051.xs4all.nl with SMTP; 8 Jul 2002 20:39:46 -0000
Received: (from root@localhost)
by w0.xxxletter.com (8.11.4/8.11.4) id g68Kbow05230
for xxxxx@xx.nl; Mon, 8 Jul 2002 16:37:50 -0400 (EDT)
Date: Mon, 8 Jul 2002 16:37:50 -0400 (EDT)
Message-Id: <200207082037.g68Kbow05230@w0.xxxletter.com>
Mime-Version: 1.0
To: xxxxx@xx.nl
Subject: You Won The Porn Lottery!
Content-type: text/html;
From: PrizeCommitee@sexy-emails.com
THE PORN LOTTERY!!! YOU
WON!!!
Note: this is not a spam
email. This email was sent to you because your
email was entered in on a website
requesting to be a registered subscriber. If you
would would like to be removed from our
list, CLICK
HERE TO CANCEL YOUR ACCOUNT and you
will *never* receive another email from
us!
Mail-Box-POP3-4.01/t/original/0003 0000644 0001750 0000144 00000003625 15117237340 016670 0 ustar 00markov users 0000000 0000000 Return-Path: <15ghnow@yahoo.com>
Delivered-To: xx-xxx@xx.nl
Received: (qmail 29529 invoked from network); 8 Jul 2002 20:32:12 -0000
Received: from unknown (HELO hlzx.bjedu.gov.cn) (211.153.20.89)
by ds051.xs4all.nl with SMTP; 8 Jul 2002 20:32:12 -0000
Received: (qmail 29012 invoked by uid 0); 25 Jun 2002 21:33:30 -0000
Received: from unknown (HELO mx1.mail.yahoo.com) ([209.86.180.232]) (envelope-sender <15ghnow@yahoo.com>)
by 10.91.86.1 (qmail-ldap-1.03) with SMTP
for ; 25 Jun 2002 21:33:30 -0000
Message-ID: <000071e14f34$00001849$00002497@mx1.mail.yahoo.com>
To:
From: "Max" <15ghnow@yahoo.com>
Subject: As Seen On TV15480
Date: Tue, 25 Jun 2002 17:41:37 -1600
MIME-Version: 1.0
Content-Type: text/plain;
charset="Windows-1252"
Content-Transfer-Encoding: 7bit
Reply-To: 15ghnow@yahoo.com
As seen on NBC, CBS, CNN, and even Oprah! The health
discovery that actually reverses aging while burning fat,
without dieting or exercise! This proven discovery has even
been reported on by the New England Journal of Medicine.
Forget aging and dieting forever! And it's Guaranteed!
Click here:
http://www.flyhost.net/betterhealth
Would you like to lose weight while you sleep!
No dieting!
No hunger pains!
No Cravings!
No strenuous exercise!
Change your life forever!
100% GUARANTEED!
1.Body Fat Loss 82% improvement.
2.Wrinkle Reduction 61% improvement.
3.Energy Level 84% improvement.
4.Muscle Strength 88% improvement.
5.Sexual Potency 75% improvement.
6.Emotional Stability 67% improvement.
7.Memory 62% improvement.
***********************************************************
You are receiving this email as a double opt-in
subscriber to the Standard Affiliates Mailing List.
To remove yourself from all related email lists,
just click here:
mailto:optoutemails@btamail.net.cn?Subject=REMOVE
Mail-Box-POP3-4.01/t/server 0000644 0001750 0000144 00000050052 15117237340 016004 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
=head1 NAME
t/server/start - simple POP3 server for testing Mail::Transport::POP3
=head1 SYNOPSIS
open( $pop3,"$^X t/server/start t/messages | " );
open( $pop3,"$^X t/server/start t/messages minimal | " );
open( $pop3,"$^X t/server/start t/messages apoponly | " );
open( $pop3,"$^X t/server/start t/messages autodelete | " );
open( $pop3,"$^X t/server/start t/messages noextra | " );
open( $pop3,"$^X t/server/start t/messages standardport | " );
=head1 DESCRIPTION
This POP3 server is created for testing the Mail::Transport::POP3 only. It
B as real POP3 server (yet).
The server takes on a randomly selected, free port to prevent interference
with existing applications. Start the server by running this script from
another script while capturing the output to STDOUT, e.g. like:
open( my $pop3,"$^X t/server/start t/messages |" )
or die "Could not start POP3 server: $!\n";
my $port = <$pop3>;
The returned $pop3 file handle produces informational texts: it will tell
you the port which is occupied by the server, and when the server shuts down.
It will also report some statistics on the performance of the server.
The server will be bound to localhost (127.0.0.1) at the port number of the
first line that is printed to STDOUT by this script.
The first parameter to the script indicates the directory in which the actual
messages (each message as a seperate file) are located. In the example, this
is "t/messages".
Any other parameters to the script are optional: they consist of keywords to
indicate any settings or peculiarities of certain POP3 server implementations.
The following keywords are recognised:
=over 2
=item minimal
If the keyword "minimal" is specified, only the minimal set of POP3 commands
will be allowed (i.e. USER, PASS, STAT, LIST, RETR, DELE, RSET, NOOP and QUIT).
The optional POP3 commands (APOP, TOP and UIDL) are also supported if this
keyword is B specified.
=item apoponly
If the keyword "apoponly" is specified, then authorization will only be
allowed with the APOP command (i.e. authorization with USER will yield a
negative response). Please note that you cannot use this together with the
"minimal" keyword, as APOP is one of the optional POP3 commands (which is
excluded if you use the "minimal" keyword).
=item autodelete
If the keyword "autodelete" is specified, any messages that are completely
retrieved with RETR or TOP (without specification of number of lines in the
body to return) will be automatically marked for deletion. This will cause
those messages to be deleted if the session is finished with a QUIT command.
This coincides with system resource restrictions imposed by some providers.
=item noextra
If the keyword "noextra" is specified, then all messages will be served with
a check for a CRLF pair at the end of the original messasge: if a CRLF is
found, then only ".\r\n" will be added to indicate the end of a message that
are retrieved with RETR or TOP.
=item standardport
If the keyword "standardport" is specified, then an attempt will be made to
start the POP3 server on port 110, the standard POP3 port. Please note that
this will only be successful if the current user has sufficient privileges
(usually only the root user will be allowed to listen on ports < 1024).
=back
User name is always "user" and the correct password is always "password".
Any other combination will always fail. APOP authorization can be used if
the "minimal" keyword is B specified. The following script will help
you in debugging APOP authorization:
use Digest::MD5 qw(md5_hex);
while (<>) {
s#\r?\n?$##s;
print md5_hex( $_.'password' )."\n";
}
Copy the string that was sent by the initial greeting of the server (including
the <> brackets), paste this into the running script, press ENTER. The script
will respond with a 32 character hexadecimal string. Copy that and the enter
the authorization thus:
APOP user 0123456789abcdef0123456789abcdef
Note that the above hex string is only an example of course.
The following commands do B exist in the POP3 protocol, but are intended
to simulate certain events.
The BREAK command can be used to simulate the breaking of a connection.
After a BREAK is received, the connection is broken by the server (without
sending a response to the client). No messages will be deleted even if any
messages were marked for deletion. This can also be used to simulate a
timeout, of course.
The EXIT command can be used for test-suites: when sent from the client, it
will cause the server to shut down (as if an EXIT was sent) whenever the
client does a QUIT command. When the servers shuts down, its prints its
statistics on STDOUT. Statistics returned are:
- number of succesful logins
- each command + frequency in alphabetical order
so a statistics list for one successful session could be:
1
DELE 102
EXIT 1
LIST 1
PASS 1
QUIT 1
RETR 102
STAT 1
UIDL 1
USER 1
=cut
# Make sure we do everything by the book
# Make sure we can do sockets
# Make sure we can do digests
use strict;
use IO::Socket;
use IO::Socket::IP;
use Digest::MD5 qw(md5_hex);
# Obtain the directory to work on
# Remove trailing slash if any
# Die now if there is no directory
# Die now if we can't work with it
my $directory = shift;
$directory =~ s#/$##;
die qq(Must specify directory to work with\n) unless $directory;
die qq(Trouble using directory "$directory": $!\n)
unless -d $directory and -w _;
# Initialize the flag settings
my $minimal = 0;
my $apoponly = 0;
my $autodelete = 0;
my $noextra = 0;
my $exitonquit = 0;
my $exitnow = 0;
my @port;
# While there are keywords specified
# Set appropriate flags if so specified
while (my $keyword = shift) {
$minimal = ($keyword eq 'minimal');
$apoponly = ($keyword eq 'apoponly');
$autodelete = ($keyword eq 'autodelete');
$noextra = ($keyword eq 'noextra');
@port = qw(LocalPort 110) if $keyword eq 'standardport';
}
# Make sure no buffering takes place
# Create a server that can only take one connection at a time
$| = 1;
my $server = IO::Socket::IP->new(
Type => SOCK_STREAM,
Listen => 1,
@port,
) or die "Couldn't start a POP3 server:\n $@\n";
# Find out the port we're running on
# Let the caller know which port we're running on
my $port = $server->sockport;
print "$port\n";
# Initialize the connected flag
# Initialize the list of available messages
# Initialize the hash of message ordinal numbers to delete
# Initialize the hash of message ordinal numbers to delete automatically
my $connected = 0;
my @message;
my %delete;
my %autodelete;
# Initialize user
# Initialize digest password field (used by APOP only)
# Initialize the line ending on output
my $user = '';
my $digest;
my $lf = "\x0D\x0A"; # always CRLF
# Number of successful logins performed
# Hash with frequency of each command
my $logins = 0;
my %command;
# While the server is running and we got a new client
# Initialize the APOP initialization string
# If this is a minimal POP3 server
# Don't make it appear we can do POP3
# Else
# Create the APOP authentication string
# Let the client know we're there and we can do APOP
SERVER: while (my $client = $server->accept()) {
my $apop = '';
if ($minimal) {
print $client qq(+OK Welcome to the test-suite POP3 server$lf);
} else {
$apop = "<$$.".time().'@localhost>';
print $client qq(+OK $apop$lf);
}
# Obtain list of files in message directory
# Reset the messages to be (automatically) deleted hashes
@message = <$directory/*>;
%autodelete = %delete = ();
# While the client is asking us stuff to do
# Lose the line ending (whatever it is)
# Split into a command and parameters
# Make sure the command is always uppercase (easier checks later)
# Make sure the parameters are defined (if empty)
while (<$client>) {
s#\r?\n$##s;
my ($command,$parameters) = split( /\s+/,$_,2 );
$command = uc($command);
$parameters = '' unless defined($parameters);
# Count this command for the statistics
# Outloop if quitting this client
$command{$command}++;
last if $command eq 'BREAK';
# If we're connected
# Allow for variable references
# If there is a subroutine for this command
# Execute it with the given parameters and return result
# Send result to client if there is something to connect
# Stop server is so requested
# Outloop if we're no longer connected
# Else
# Indicate it's not implemented
if ($connected) {
no strict 'refs';
if (exists( &$command )) {
my @return = &{$command}( split( /\s+/,$parameters ) );
print $client @return if @return;
last SERVER if $exitnow;
last unless $connected;
} else {
print $client "-ERR unimplemented$lf";
}
# Elseif we're quitting without a connection
# Show that we agree
# And outloop
} elsif ($command eq 'QUIT') {
print $client "+OK$lf";
last;
# Elseif we're trying APOP authentication
# If we have a minimal POP3 server
# Show that this isn't implemented
# And reloop
} elsif ($command eq 'APOP') {
if ($minimal) {
print $client "-ERR unimplemented$lf";
next;
}
# Obtain the user name and the digest
# Log the user in if client gives the right credentials
# Send the result to the client
($user,$digest) = split( /\s+/,$parameters );
my @return = login(
$user eq 'user' and
$digest eq md5_hex( $apop.'password')
);
print $client @return;
# Elseif we have a user name (and we're not connected yet)
# Log the user in if client gives the right credentials now and before
# Send the result to the client
} elsif ($user) {
my @return = login(
$command eq 'PASS' and
$user eq 'user' and
$parameters eq 'password'
);
print $client @return;
# Elseif the user name is passed (and none given before)
# If we only allow APOP
# Let the client know it's not ok
# Else
# Save the user name (for later checking with PASS)
# Let the client know it's ok so far
} elsif ($command eq 'USER') {
if ($apoponly) {
print $client "-ERR APOP authorization allowed only$lf";
} else {
$user = $parameters;
print $client "+OK$lf";
}
# Elseif the password is given (but no user name before)
# Let the client know it's wrong
# Else (attempting to do anything else without authorization)
# Let the client know it's wrong
} elsif ($command eq 'PASS') {
print $client "-ERR user first$lf";
} else {
print $client "-ERR authorization first$lf";
}
}
# Reset user name
# Reset connected flag
# Shut down the client connection
$user = '';
$connected = 0;
close( $client );
}
# Show number of successful logins
# For all the commands that were issued
# Return name and frequency of it
# And shut down the server
print "$logins\n";
foreach (sort keys %command) {
print "$_ $command{$_}\n";
}
close($server);
#------------------------------------------------------------------------
# OUT: 1 whatever needs to be sent to client
sub STAT {
# Initialize number of messages
# Initialize number of bytes they have
# Initialize ordinal number
my $messages = 0;
my $octets = 0;
my $ordinal = 0;
# For all of the messages
# Reloop if message marked as delete, incrementing ordina on the fly
# Increment number of messages
# Add number of bytes
# Return the result
foreach (@message) {
next if exists( $delete{$ordinal++} );
$messages++;
$octets += -s;
}
return "+OK $messages $octets$lf";
} #STAT
#------------------------------------------------------------------------
# OUT: 1 whatever needs to be sent to client
sub UIDL {
# Return now if running a minimal POP3 server
return "-ERR unimplemented$lf" if $minimal;
# Initialize message number
# If a number was specified
# Obtain ordinal number and possible error message
# Return error message if there is one
# Return the message number and the identifier of the message otherwise
my $number = shift;
if (defined($number)) {
my ($ordinal,$error) = ordinal( $number,1 );
return $error if $error;
return "+OK $number $message[$ordinal]$lf";
}
# Initialize ordinal number
# Initialize text to be returned
# For all of the messages
# Reloop if message marked as deleted, incrementing ordinal on the fly
# Add the ordinal number and the identifier (just use filename for that)
# Return the result with an extra . at the end to indicate end of list
my $ordinal = 0;
my $text = "+OK$lf";
foreach (@message) {
next if exists( $delete{$ordinal++} );
$text .= "$ordinal $_$lf"; # external numbers 1-based, internal 0-based
}
return "$text.$lf";
} #UIDL
#------------------------------------------------------------------------
# IN: 1 message to obtain (optionally)
# OUT: 1 whatever needs to be sent to client
sub LIST {
# Initialize message number
# If a number was specified
# Obtain ordinal number and possible error message
# Return error message if there is one
# Return the message number and size of message otherwise
my $number = shift;
if (defined($number)) {
my ($ordinal,$error) = ordinal( $number,1 );
return $error if $error;
return "+OK $number ".(-s $message[$ordinal]).$lf;
}
# Initialize ordinal number
# Initialize text to be returned
# For all of the messages
# Reloop if message marked as deleted, incrementing ordinal on the fly
# Add the ordinal number and the identifier (just use filename for that)
# Return the result with an extra . at the end to indicate end of list
my $ordinal = 0;
my $text = "+OK$lf";
foreach (@message) {
next if exists( $delete{$ordinal++} );
$text .= "$ordinal ".(-s).$lf; # external numbers 1-based, internal 0-based
}
return "$text.$lf";
} #LIST
#------------------------------------------------------------------------
# IN: 1 ordinal number of message to retrieve
# OUT: 1 whatever needs to be sent to client
sub RETR {
# Obtain ordinal number and possible error message
# Return now if there was an error message
my ($ordinal,$error) = ordinal( shift,1 );
return $error if $error;
# Open file for reading or return with empty message
# Initialize text to be returned
# While there are lines to be returned
# Make sure any period at the start of the line becomes a double period
# Add the line to the text to be returned
open( my $handle,'<',$message[$ordinal] ) or return "+OK$lf.$lf";
my $text = "+OK$lf";
while (<$handle>) {
s#^\.#..#;
$text .= $_;
}
# Mark this message to be deleted automatically if flag set
# Add the right marker to the text
# Return the finished text
$autodelete{$ordinal} = undef if $autodelete;
addmarker( \$text );
$text;
} #RETR
#------------------------------------------------------------------------
# IN: 1 ordinal number of message to retrieve
# 2 number of lines of the message to retrieve
# OUT: 1 whatever needs to be sent to client
sub TOP {
# Return now if running a minimal POP3 server
# Obtain ordinal number and possible error message
# Return now if there was an error message
return "-ERR unimplemented$lf" if $minimal;
my ($ordinal,$error) = ordinal( shift,1 );
return $error if $error;
# Open file for reading or return with empty message
# Initialize text to be returned
open( my $handle,'<',$message[$ordinal] ) or return "+OK$lf.$lf";
my $text = "+OK$lf";
# Obtain the number of lines
# If a number of lines was specified
# While there are lines to be returned
# Make sure any period at the start of the line becomes a double period
# Add the line to the text to be returned
# Outloop if we're reached the end of the headers
my $lines = shift;
if (defined($lines)) {
while (<$handle>) {
s#^\.#..#;
$text .= $_;
last if m#^\s+$#s;
}
# While there are lines to be fetched
# Outloop if no line left to be fetched
# Make sure any period at the start of the line becomes a double period
# Add the line to the text to be returned
while ($lines--) {
last unless defined($_ = <$handle>);
s#^\.#..#;
$text .= $_;
}
# Else (no limit)
# While there are lines to be returned
# Make sure any period at the start of the line becomes a double period
# Add the line to the text to be returned
# Mark this message to be deleted automatically if flag set
} else {
while (<$handle>) {
s#^\.#..#;
$text .= $_;
}
$autodelete{$ordinal} = undef if $autodelete;
}
# Add the right marker to the text
# Return the result with an extra . at the end to indicate end of list
addmarker( \$text );
$text;
} #TOP
#------------------------------------------------------------------------
# IN: 1 ordinal number of message to delete
# OUT: 1 whatever needs to be sent to client
sub DELE {
# Obtain ordinal number and possible error message
# Return now if there was an error message
# Mark this message as deletable
# Return the result with an extra . at the end to indicate end of list
my ($ordinal,$error) = ordinal( shift,1 );
return $error if $error;
$delete{$ordinal} = undef;
return "+OK$lf";
} #DELE
#------------------------------------------------------------------------
# IN: 1 ordinal number of message to undelete
# OUT: 1 whatever needs to be sent to client
sub RSET {
# Obtain ordinal number and possible error message
# Return now if there was an error message
# Unmark this message as deletable
# Return the result with an extra . at the end to indicate end of list
my ($ordinal,$error) = ordinal( shift );
return $error if $error;
delete( $delete{$ordinal} );
return "+OK$lf";
} #RSET
#------------------------------------------------------------------------
# OUT: 1 whatever needs to be sent to client
sub NOOP { "+OK$lf" } #NOOP
#------------------------------------------------------------------------
sub EXIT { $exitonquit = 1; return } #EXIT
#------------------------------------------------------------------------
# OUT: 1 whatever needs to be sent to client
sub QUIT {
# Remove all of the files that were supposed to be deleted
# Remove all of the files that were supposed to be deleted automatically
# Set exit now flag if QUIT is to operate as EXIT
# Mark the connection as ended
# Let the client now it was fun while it lasted
unlink( map {$message[$_]} keys %delete );
unlink( map {$message[$_]} keys %autodelete );
$exitnow = $exitonquit;
$connected = 0;
return "+OK$lf";
} #QUIT
#------------------------------------------------------------------------
# IN: 1 flag whether login successful
# OUT: 1 what needs to be returned to the client
sub login {
# If successful
# Increment number of successful logins
# Set connected flag
# Let the client know it's ok
if (shift) {
$logins++;
$connected = 1;
return "+OK$lf";
}
# Reset the user that was entered before
# Let the client know authorization has failed
$user = '';
return "-ERR authorization failed$lf";
} #login
#------------------------------------------------------------------------
# IN: 1 ordinal number of message
# 2 flag: check whether message deleted already
# OUT: 1 normalize message number
# 2 error message (if any)
sub ordinal {
# Obtain the message number
# Initialize error message
# Set error if too low
# Set error if zero
# Set error if too high
my $ordinal = shift;
my $error = '';
$error ||= "-ERR syntax error$lf" if $ordinal < 0;
$error ||= "-ERR messages are counted from 1$lf" if $ordinal == 0;
$error ||= "-ERR not that many messages$lf" if $ordinal > @message;
# Normalize for arrays
# Set error if checking for deletion and already deleted
# Return the result
$ordinal--;
$error ||= "-ERR already deleted$lf" if shift and exists( $delete{$ordinal} );
return ($ordinal,$error);
} #ordinal
#------------------------------------------------------------------------
# IN: 1 reference to text (to add the right end-of-data marker to)
sub addmarker {
# Obtain the reference to the text
# If we should check for extra newlines at the end
# Add the right stuff depending on the end of the text so far
# Else
# Add it as most POP3 servers do
my $textref = shift;
if ($noextra) {
$$textref .= ($$textref =~ m#\r\n$#so ? ".$lf" : "$lf.$lf");
} else {
$$textref .= "$lf.$lf";
}
}
Mail-Box-POP3-4.01/t/02break.t 0000644 0001750 0000144 00000002350 15117237340 016164 0 ustar 00markov users 0000000 0000000 #!/usr/bin/env perl
use strict;
use warnings;
use Mail::Box::POP3::Test;
use Mail::Box::Test;
use File::Basename qw(dirname);
use File::Spec ();
use Test::More;
$ENV{MARKOV_DEVEL} or plan skip_all => "tests are fragile, skipped";
use_ok('Mail::Transport::POP3');
my $here = dirname __FILE__;
my $original = File::Spec->catdir($here, 'original');
my $popbox = File::Spec->catdir($here, 'popbox');
copy_dir($original, $popbox);
my ($server, $port) = start_pop3_server($popbox);
my $receiver = start_pop3_client($port);
isa_ok($receiver, 'Mail::Transport::POP3');
my $socket = $receiver->socket;
ok($socket, "Could not get socket of POP3 server");
print $socket "EXIT\n"; # make server exit on QUIT
$receiver->message($_) foreach $receiver->ids;
$receiver->deleteFetched;
print $socket "BREAK\n"; # force breaking of connection
ok($receiver->disconnect, 'Failed to properly disconnect from server');
my @message = <$popbox/????>;
cmp_ok(scalar(@message) ,'==', 0, 'Did not remove messages at QUIT');
ok(rmdir($popbox), "Failed to remove $popbox directory: $!");
is(join('', <$server>), < "tests are fragile, skipped";
use_ok('Mail::Transport::POP3');
my $here = dirname __FILE__;
my $original = File::Spec->catdir($here, 'original');
my $popbox = File::Spec->catdir($here, 'popbox');
copy_dir($original, $popbox);
my ($server, $port) = start_pop3_server($popbox, 'minimal');
my $receiver = start_pop3_client($port);
isa_ok($receiver, 'Mail::Transport::POP3');
my $socket = $receiver->socket;
ok($socket, "Could not get socket of POP3 server");
print $socket "EXIT\n"; # make server exit on QUIT
$receiver->deleted(1, $receiver->ids);
ok($receiver->disconnect, 'Failed to properly disconnect from server');
my @message = <$popbox/????>;
cmp_ok(scalar(@message) ,'==', 0, 'Did not remove messages at QUIT');
ok(rmdir($popbox), "Failed to remove $popbox directory: $!");
is(join('', <$server>), < "tests are fragile, skipped";
use_ok('Mail::Transport::POP3');
my $here = dirname __FILE__;
my $original = File::Spec->catdir($here, 'original');
my $popbox = File::Spec->catdir($here, 'popbox');
copy_dir($original, $popbox);
my ($server, $port) = start_pop3_server($popbox, 'autodelete');
my $receiver = start_pop3_client($port, authenticate => 'LOGIN');
isa_ok($receiver, 'Mail::Transport::POP3');
my $socket = $receiver->socket;
ok($socket, "Could not get socket of POP3 server");
print $socket "EXIT\n"; # make server exit on QUIT
$receiver->message($_) foreach $receiver->ids;
ok($receiver->disconnect, 'Failed to properly disconnect from server');
my @message = <$popbox/????>;
cmp_ok(scalar(@message) ,'==', 0, 'Did not remove messages at QUIT');
ok(rmdir($popbox), "Failed to remove $popbox directory: $!");
is(join('', <$server>), <{body_type} ||= 'Mail::Message::Body::Lines';
$self->SUPER::init($args);
}
sub size($)
{ my $self = shift;
$self->isDelayed
? $self->folder->popClient->messageSize($self->unique)
: $self->SUPER::size;
}
sub label(@)
{ my $self = shift;
$self->loadHead; # be sure the labels are read
return $self->SUPER::label(@_) if @_==1;
# POP3 can only set 'deleted' in the source folder. Don't forget
my $olddel = $self->label('deleted') ? 1 : 0;
my $ret = $self->SUPER::label(@_);
my $newdel = $self->label('deleted') ? 1 : 0;
$self->folder->popClient->deleted($newdel, $self->unique)
if $newdel != $olddel;
$ret;
}
sub labels(@)
{ my $self = shift;
$self->loadHead; # be sure the labels are read
$self->SUPER::labels(@_);
}
#--------------------
sub loadHead()
{ my $self = shift;
my $head = $self->head;
$head->isDelayed or return $head;
$head = $self->folder->getHead($self);
$self->head($head);
$self->statusToLabels; # not supported by al POP3 servers
$head;
}
sub loadBody()
{ my $self = shift;
my $body = $self->body;
$body->isDelayed or return $body;
(my $head, $body) = $self->folder->getHeadAndBody($self);
$self->head($head) if $head->isDelayed;
$self->storeBody($body);
}
1;
Mail-Box-POP3-4.01/lib/Mail/Box/POP3/Message.pod 0000644 0001750 0000144 00000035706 15117246023 021310 0 ustar 00markov users 0000000 0000000 =encoding utf8
=head1 NAME
Mail::Box::POP3::Message - one message on a POP3 server
=head1 INHERITANCE
Mail::Box::POP3::Message
is a Mail::Box::Net::Message
is a Mail::Box::Message
is a Mail::Message
is a Mail::Reporter
=head1 SYNOPSIS
my $folder = new Mail::Box::POP3 ...
my $message = $folder->message(10);
=head1 DESCRIPTION
A C represents one message on a POP3 server,
maintained by a L folder. Each message is stored as
separate entity on the server, and maybe temporarily in your program
as well.
Extends L<"DESCRIPTION" in Mail::Box::Net::Message|Mail::Box::Net::Message/"DESCRIPTION">.
=head1 METHODS
Extends L<"METHODS" in Mail::Box::Net::Message|Mail::Box::Net::Message/"METHODS">.
=head2 Constructors
Extends L<"Constructors" in Mail::Box::Net::Message|Mail::Box::Net::Message/"Constructors">.
=over 4
=item $obj-EB(%options)
Inherited, see L
=item $class-EB(%options)
Inherited, see L
-Option --Defined in --Default
body Mail::Message undef
body_type Mail::Box::Message Mail::Message::Body::Lines
deleted Mail::Message false
field_type Mail::Message undef
folder Mail::Box::Message
head Mail::Message undef
head_type Mail::Message Mail::Message::Head::Complete
labels Mail::Message +{}
messageId Mail::Message undef
modified Mail::Message false
size Mail::Box::Message undef
trusted Mail::Message false
unique Mail::Box::Net::Message
=over 2
=item body => $object
=item body_type => CODE|$class
=item deleted => BOOLEAN
=item field_type => $class
=item folder => $folder
=item head => $object
=item head_type => $class
=item labels => \@pairs|\%settings
=item messageId => $id
=item modified => BOOLEAN
=item size => $bytes
=item trusted => BOOLEAN
=item unique => STRING
=back
=back
=head2 Attributes
Extends L<"Attributes" in Mail::Box::Net::Message|Mail::Box::Net::Message/"Attributes">.
=over 4
=item $obj-EB( [$folder] )
Inherited, see L
=item $obj-EB( [$integer] )
Inherited, see L
=item $obj-EB( [STRING|undef] )
Inherited, see L
=back
=head2 Constructing a message
Extends L<"Constructing a message" in Mail::Box::Net::Message|Mail::Box::Net::Message/"Constructing a message">.
=over 4
=item $obj-EB( [<$rg_object|%options>] )
Inherited, see L
=item $class-EB( [$message|$part|$body], @fields, %options )
Inherited, see L
=item $class-EB($body, [$head], $headers)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB(STRING)
Inherited, see L
=item $class-EB($fh|$text|\$text|\@lines, %options)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB( [STRING|$field|$address|\@addrs|\@fields] )
Inherited, see L
=item $any-EB(STRING)
Inherited, see L
=back
=head2 The message
Extends L<"The message" in Mail::Box::Net::Message|Mail::Box::Net::Message/"The message">.
=over 4
=item $obj-EB()
Inherited, see L
=item $obj-EB($folder, %options)
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB($folder, %options)
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB( [$fh] )
Inherited, see L
=item $obj-EB( [$mailer], %options )
Inherited, see L
=item $obj-EB()
Returns the size of this message. If the message is still on the remote
server, POP is used to ask for the size. When the message is already loaded
onto the local system, the size of the parsed message is taken. These
sizes can differ because the difference in line-ending representation.
Improves base, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB( [$fh] )
Inherited, see L
=back
=head2 The header
Extends L<"The header" in Mail::Box::Net::Message|Mail::Box::Net::Message/"The header">.
=over 4
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB($fieldname)
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB( [$head] )
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB($fieldname)
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=back
=head2 The body
Extends L<"The body" in Mail::Box::Net::Message|Mail::Box::Net::Message/"The body">.
=over 4
=item $obj-EB( [$body] )
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB(%options)
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB( [<'ALL'|'ACTIVE'|'DELETED'|'RECURSE'|$filter>] )
Inherited, see L
=back
=head2 Flags
Extends L<"Flags" in Mail::Box::Net::Message|Mail::Box::Net::Message/"Flags">.
=over 4
=item $obj-EB()
Inherited, see L
=item $obj-EB( [BOOLEAN] )
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB()
Inherited, see L
=item $obj-EB