r5825 - in /packages/libemail-localdelivery-perl/branches/upstream/current: Changes MANIFEST META.yml lib/Email/LocalDelivery.pm lib/Email/LocalDelivery/Maildir.pm lib/Email/LocalDelivery/Mbox.pm t/test_mbox
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Sun Jul 15 14:53:37 UTC 2007
Author: gregoa-guest
Date: Sun Jul 15 14:53:37 2007
New Revision: 5825
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=5825
Log:
[svn-upgrade] Integrating new upstream version, libemail-localdelivery-perl (0.217)
Removed:
packages/libemail-localdelivery-perl/branches/upstream/current/t/test_mbox
Modified:
packages/libemail-localdelivery-perl/branches/upstream/current/Changes
packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST
packages/libemail-localdelivery-perl/branches/upstream/current/META.yml
packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery.pm
packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Maildir.pm
packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Mbox.pm
Modified: packages/libemail-localdelivery-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-localdelivery-perl/branches/upstream/current/Changes?rev=5825&op=diff
==============================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/Changes (original)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/Changes Sun Jul 15 14:53:37 2007
@@ -1,3 +1,9 @@
+0.217 2007-06-22
+ remove dross test file from dist
+
+0.216 2007-06-22
+ allow Maildir deliveries to be streamed to disk
+
0.215 2007-04-15
mbox is /From / not /From\s/ (rt 26373 from Simon Law)
Modified: packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST?rev=5825&op=diff
==============================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST (original)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST Sun Jul 15 14:53:37 2007
@@ -10,5 +10,4 @@
t/mbox.t
t/pod.t
t/pod-coverage.t
-t/test_mbox
LICENSE
Modified: packages/libemail-localdelivery-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-localdelivery-perl/branches/upstream/current/META.yml?rev=5825&op=diff
==============================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/META.yml (original)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/META.yml Sun Jul 15 14:53:37 2007
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Email-LocalDelivery
-version: 0.215
+version: 0.217
abstract: ~
license: perl
generated_by: ExtUtils::MakeMaker version 6.32
Modified: packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery.pm?rev=5825&op=diff
==============================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery.pm (original)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery.pm Sun Jul 15 14:53:37 2007
@@ -6,7 +6,7 @@
use Carp;
use vars qw($VERSION);
-$VERSION = '0.215';
+$VERSION = '0.217';
=head1 NAME
@@ -35,8 +35,10 @@
sub deliver {
my ($class, $mail, @boxes) = @_;
+
croak "Mail argument to deliver should just be a plain string"
if ref $mail;
+
if (!@boxes) {
my $default_unixbox = ( grep { -d $_ } qw(/var/spool/mail/ /var/mail/) )[0] . getpwuid($>);
my $default_maildir = ((getpwuid($>))[7])."/Maildir/";
@@ -74,6 +76,12 @@
L<http://emailproject.perl.org/wiki/Email::LocalDelivery>
+=head1 CONTACT INFO
+
+To report bugs, please use the request tracker at L<http://rt.cpan.org>. For
+all other information, please contact the PEP mailing list (see the wiki,
+above) or Ricardo SIGNES.
+
=head1 COPYRIGHT AND LICENSE
Copyright 2003 by Simon Cozens
Modified: packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Maildir.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Maildir.pm?rev=5825&op=diff
==============================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Maildir.pm (original)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Maildir.pm Sun Jul 15 14:53:37 2007
@@ -1,92 +1,109 @@
use strict;
+
package Email::LocalDelivery::Maildir;
use Email::Simple;
use File::Path;
use Symbol qw(gensym);
use vars qw($VERSION);
-$VERSION = "1.10";
+$VERSION = "1.101";
my $maildir_time = 0;
my $maildir_counter = 0;
-use Sys::Hostname; (my $HOSTNAME = hostname) =~ s/\..*//;
+use Sys::Hostname;
+(my $HOSTNAME = hostname) =~ s/\..*//;
sub deliver {
- my ($class, $mail, @files) = @_;
- $mail = Email::Simple->new($mail)
- unless ref $mail eq "Email::Simple"; # For when we recurse
- $class->fix_lines($mail);
- $class->update_time();
+ my ($class, $mail, @files) = @_;
- my $temp_file = $class->write_temp($mail, @files) or return;
+ $mail = Email::Simple->new($mail)
+ unless eval { $mail->isa('Email::Simple') }; # For when we recurse
- my @written = $class->write_links($mail, $temp_file, @files);
- unlink $temp_file;
- return @written;
+ $class->fix_lines($mail);
+ $class->update_time();
+
+ my $temp_file = $class->write_temp($mail, @files) or return;
+
+ my @written = $class->write_links($mail, $temp_file, @files);
+ unlink $temp_file;
+ return @written;
}
sub fix_lines {
- my ($class, $mail) = @_;
- return if $mail->header("Lines");
- my @lines = split /\n/, $mail->body;
- $mail->header_set("Lines", scalar @lines);
+ my ($class, $mail) = @_;
+ return if $mail->header("Lines");
+ my @lines = split /\n/, $mail->body;
+ $mail->header_set("Lines", scalar @lines);
}
sub update_time {
- if ($maildir_time != time) {
- $maildir_time = time;
- $maildir_counter = 0
- } else { $maildir_counter++ }
+ if ($maildir_time != time) {
+ $maildir_time = time;
+ $maildir_counter = 0;
+ } else {
+ $maildir_counter++;
+ }
}
sub write_temp {
- my ($class, $mail, @files) = @_;
- for my $file (@files) {
- $file =~ s{/$}{};
- my $tmp_file = $class->get_filename_in($file."/tmp");
- eval { mkpath([map { "$file/$_" } qw(tmp new cur)]); 1 } or next;
- $class->write_message($mail, $tmp_file)
- and return $tmp_file;
- }
- return;
+ my ($class, $mail, @files) = @_;
+ for my $file (@files) {
+ $file =~ s{/$}{};
+ my $tmp_file = $class->get_filename_in($file . "/tmp");
+ eval {
+ mkpath([ map { "$file/$_" } qw(tmp new cur) ]);
+ 1;
+ } or next;
+ $class->write_message($mail, $tmp_file)
+ and return $tmp_file;
+ }
+ return;
}
sub get_filename_in {
- my ($class, $tmpdir) = @_;
- my ($msg_file, $tmppath);
- do {
- $msg_file = join ".", ($maildir_time,
- $$. "_$maildir_counter",
- $HOSTNAME)
- } while -e ($tmppath="$tmpdir/$msg_file")
- and ++$maildir_counter;
- return $tmppath;
+ my ($class, $tmpdir) = @_;
+ my ($msg_file, $tmppath);
+ do {
+ $msg_file = join ".", ($maildir_time, $$ . "_$maildir_counter", $HOSTNAME);
+ } while -e ($tmppath = "$tmpdir/$msg_file")
+ and ++$maildir_counter;
+ return $tmppath;
}
sub write_links {
- my ($class, $mail, $temp_file, @files) = @_;
- my @rv;
- for my $file (@files) {
- $file =~ s{/$}{};
- my $new_location = $class->get_filename_in($file."/new");
- eval { mkpath([map { "$file/$_" } qw(tmp new cur)]); 1 } or next;
- if (link $temp_file, $new_location) {
- push @rv, $new_location;
- } else {
- require Errno; import Errno qw(EXDEV);
- if ($! == &EXDEV) {
- push @rv, $class->deliver($mail, $file);
- }
- }
+ my ($class, $mail, $temp_file, @files) = @_;
+ my @rv;
+ for my $file (@files) {
+ $file =~ s{/$}{};
+ my $new_location = $class->get_filename_in($file . "/new");
+ eval {
+ mkpath([ map { "$file/$_" } qw(tmp new cur) ]);
+ 1;
+ } or next;
+ if (link $temp_file, $new_location) {
+ push @rv, $new_location;
+ } else {
+ require Errno;
+ import Errno qw(EXDEV);
+ if ($! == &EXDEV) {
+ push @rv, $class->deliver($mail, $file);
+ }
}
- return @rv;
+ }
+ return @rv;
}
sub write_message {
- my ($class, $mail, $file) = @_;
- my $fh = gensym;
- open $fh, ">$file" or return;
+ my ($class, $mail, $file) = @_;
+ my $fh = gensym;
+ open $fh, ">$file" or return;
+
+ if (eval { $mail->can('stream_to') }) {
+ eval { $mail->stream_to($fh); 1 } or return;
+ } else {
print $fh $mail->as_string or return;
- return close $fh;
+ }
+
+ return close $fh;
}
1;
Modified: packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Mbox.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Mbox.pm?rev=5825&op=diff
==============================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Mbox.pm (original)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/lib/Email/LocalDelivery/Mbox.pm Sun Jul 15 14:53:37 2007
@@ -3,7 +3,7 @@
use File::Path;
use File::Basename;
-use Email::Simple 1.998; # needed for ->header_obj
+use Email::Simple 1.998; # needed for ->header_obj
use Fcntl ':flock';
use Symbol qw(gensym);
@@ -11,91 +11,104 @@
$VERSION = "1.103";
sub deliver {
- my ($class, $mail, @files) = @_;
- my @rv;
- for my $file (@files) {
- my $fh = $class->_open_fh($file) or next;
- print $fh "\n" if tell($fh) > 0;
- print $fh $class->_from_line(\$mail); # Avoid passing $mail where poss.
- print $fh $class->_escape_from_body(\$mail);
- print $fh "\n" unless $mail =~ /\n$/;
- $class->_close_fh($fh) || next;
- push @rv, $file
- }
- return @rv;
+ # The slightly convoluted method of unrolling the stack is intended to limit
+ # the scope of which a large string at $_[1] might be in memory before being
+ # constructed into an Email::Simple. -- rjbs, 2007-05-25
+ my $class = shift;
+
+ my $email;
+ if (eval { $_[0]->isa('Email::Simple') }) {
+ $email = shift;
+ } else {
+ my $text = shift;
+ $email = Email::Simple->new(\$text); # requires Email::Simple 1.998 or so
+ }
+
+ my @files = @_;
+
+ my @rv;
+
+ for my $file (@files) {
+ my $fh = $class->_open_fh($file) or next;
+ print $fh "\n" if tell($fh) > 0;
+ print $fh $class->_from_line($email);
+ print $fh $class->_escape_from_body($email);
+
+ # This will make streaming a bit more annoying. -- rjbs, 2007-05-25
+ print $fh "\n" unless $email->as_string =~ /\n$/;
+
+ $class->_close_fh($fh) || next;
+ push @rv, $file;
+ }
+ return @rv;
}
sub _open_fh {
- my ($class, $file) = @_;
- my $dir = dirname($file);
- return if ! -d $dir and not mkpath($dir);
+ my ($class, $file) = @_;
+ my $dir = dirname($file);
+ return if !-d $dir and not mkpath($dir);
- my $fh = gensym;
- open $fh, ">> $file" or return;
- $class->getlock($fh) || return;
- seek $fh, 0, 2;
- return $fh;
+ my $fh = gensym;
+ open $fh, ">> $file" or return;
+ $class->getlock($fh) || return;
+ seek $fh, 0, 2;
+ return $fh;
}
sub _close_fh {
- my ($class, $fh) = @_;
- $class->unlock($fh) || return;
- close $fh or return;
- return 1;
+ my ($class, $fh) = @_;
+ $class->unlock($fh) || return;
+ close $fh or return;
+ return 1;
}
sub _escape_from_body {
- my ($class, $mail_r) = @_;
+ my ($class, $email) = @_;
- my $email = Email::Simple->new($$mail_r);
+ my $body = $email->body;
+ $body =~ s/^(From )/>$1/gm;
- my $body = $email->body;
- $body =~ s/^(From )/>$1/gm;
-
- return $email->header_obj->as_string . $email->crlf . $body;
+ return $email->header_obj->as_string . $email->crlf . $body;
}
sub _from_line {
- my ($class, $mail_r) = @_;
+ my ($class, $email) = @_;
- # The trivial way
- return if $$mail_r =~ /^From /;
+ # The qmail way.
+ return $ENV{UFLINE} . $ENV{RPLINE} . $ENV{DTLINE} if exists $ENV{UFLINE};
- # The qmail way.
- return $ENV{UFLINE}.$ENV{RPLINE}.$ENV{DTLINE} if exists $ENV{UFLINE};
-
- # The boring way.
- return _from_line_boring(Email::Simple->new($$mail_r));
+ # The boring way.
+ return _from_line_boring($email);
}
sub _from_line_boring {
- my $mail = shift;
- my $from = $mail->header("Return-path") ||
- $mail->header("Sender") ||
- $mail->header("Reply-To") ||
- $mail->header("From") ||
- 'root at localhost';
- $from = $1 if $from =~ /<(.*?)>/; # comment <email at address> -> email at address
- $from =~ s/\s*\(.*\)\s*//; # email at address (comment) -> email at address
- $from =~ s/\s+//g; # if any whitespace remains, get rid of it.
+ my $mail = shift;
+ my $from = $mail->header("Return-path")
+ || $mail->header("Sender")
+ || $mail->header("Reply-To")
+ || $mail->header("From")
+ || 'root at localhost';
+ $from = $1 if $from =~ /<(.*?)>/; # comment <email at address> -> email at address
+ $from =~ s/\s*\(.*\)\s*//; # email at address (comment) -> email at address
+ $from =~ s/\s+//g; # if any whitespace remains, get rid of it.
- my $fromtime = localtime;
- $fromtime =~ s/(:\d\d) \S+ (\d{4})$/$1 $2/; # strip timezone.
- return "From $from $fromtime\n";
+ my $fromtime = localtime;
+ $fromtime =~ s/(:\d\d) \S+ (\d{4})$/$1 $2/; # strip timezone.
+ return "From $from $fromtime\n";
}
sub getlock {
- my ($class, $fh) = @_;
- for (1..10) {
- return 1 if flock ($fh, LOCK_EX | LOCK_NB);
- sleep $_;
- }
- return 0 ;
+ my ($class, $fh) = @_;
+ for (1 .. 10) {
+ return 1 if flock($fh, LOCK_EX | LOCK_NB);
+ sleep $_;
+ }
+ return 0;
}
sub unlock {
- my ($class,$fh) = @_;
- flock ($fh, LOCK_UN);
+ my ($class, $fh) = @_;
+ flock($fh, LOCK_UN);
}
1;
More information about the Pkg-perl-cvs-commits
mailing list