r1697 - in packages: . libemail-localdelivery-perl
libemail-localdelivery-perl/branches
libemail-localdelivery-perl/branches/upstream
libemail-localdelivery-perl/branches/upstream/current
libemail-localdelivery-perl/branches/upstream/current/LocalDelivery
libemail-localdelivery-perl/branches/upstream/current/t
Niko Tyni
ntyni-guest at costa.debian.org
Mon Dec 19 22:41:08 UTC 2005
Author: ntyni-guest
Date: 2005-12-19 22:41:07 +0000 (Mon, 19 Dec 2005)
New Revision: 1697
Added:
packages/libemail-localdelivery-perl/
packages/libemail-localdelivery-perl/branches/
packages/libemail-localdelivery-perl/branches/upstream/
packages/libemail-localdelivery-perl/branches/upstream/current/
packages/libemail-localdelivery-perl/branches/upstream/current/Changes
packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery.pm
packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/
packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Maildir.pm
packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Mbox.pm
packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST
packages/libemail-localdelivery-perl/branches/upstream/current/META.yml
packages/libemail-localdelivery-perl/branches/upstream/current/Makefile.PL
packages/libemail-localdelivery-perl/branches/upstream/current/README
packages/libemail-localdelivery-perl/branches/upstream/current/t/
packages/libemail-localdelivery-perl/branches/upstream/current/t/.cvsignore
packages/libemail-localdelivery-perl/branches/upstream/current/t/00compile.t
packages/libemail-localdelivery-perl/branches/upstream/current/t/mbox.t
packages/libemail-localdelivery-perl/branches/upstream/current/t/test_mbox
packages/libemail-localdelivery-perl/tags/
Log:
[svn-inject] Installing original source of libemail-localdelivery-perl
Added: packages/libemail-localdelivery-perl/branches/upstream/current/Changes
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/Changes 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/Changes 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,43 @@
+0.09 2004-12-17
+
+ - New author.
+ - Allow for subclassing flexibility in Email::LocalDelivery::Mbox.
+ - New contact information.
+
+0.08 Saturday 29th May, 2004
+ Make fix_lines not be a no-op (Toby Johnson)
+
+0.07 Friday 14th November, 2003
+ http://rt.cpan.org/NoAuth/Bug.html?id=4394 bug caused by flawed
+ implementation of #2480. the test suite is woefully poor not
+ to have caught this
+
+0.06 Wednesday 29th October, 2003
+ http://rt.cpan.org/NoAuth/Bug.html?id=2480 quoting of From_
+ lines in bodies of messages in Mboxes
+
+ http://rt.cpan.org/NoAuth/Bug.html?id=2483 expansion of ~ elements
+
+0.05 Thursday 24th July 2003
+ - Fix bug in ::Maildir
+ - quell warning
+
+0.04 Fri May 2 12:56:34 BST 2003
+ - Handle failure to open mboxen properly
+ - Insert blank line before new message in mbox.
+
+0.03 Wednesday 16th April, 2003, just after the PAUSE indexer got in touch
+ - Increment the version numbers in E::LD::{Mbox,Maildir}
+
+0.02 Wednesday 16th April, 2003
+ - now depends on Email::Simple and Email::FolderType
+ - changes to make code -w clean
+ - http://rt.cpan.org/NoAuth/Bug.html?id=2356
+ - http://rt.cpan.org/NoAuth/Bug.html?id=2357
+
+0.01 Fri Feb 21 13:26:07 2003
+ - original version; created by h2xs 1.2 with options
+ -AX -n Email::LocalDelivery
+
+For full details consult:
+http://cvs.simon-cozens.org/viewcvs.cgi/Email-LocalDelivery/?cvsroot=Email
Added: packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Maildir.pm
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Maildir.pm 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Maildir.pm 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,89 @@
+use strict;
+package Email::LocalDelivery::Maildir;
+use Email::Simple;
+use File::Path;
+
+our $VERSION = "1.06";
+my $maildir_time = 0;
+my $maildir_counter = 0;
+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 $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);
+}
+
+sub update_time {
+ 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;
+}
+
+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;
+}
+
+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);
+ }
+ }
+ }
+ return @rv;
+}
+
+sub write_message {
+ my ($class, $mail, $file) = @_;
+ open my $fh, ">$file" or return;
+ print $fh $mail->as_string;
+ return close $fh;
+}
+
+1;
Added: packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Mbox.pm
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Mbox.pm 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery/Mbox.pm 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,95 @@
+package Email::LocalDelivery::Mbox;
+use File::Path;
+use File::Basename;
+use Email::Simple;
+use Fcntl ':flock';
+
+our $VERSION = "1.07";
+
+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;
+}
+
+sub _open_fh {
+ my ($class, $file) = @_;
+ my $dir = dirname($file);
+ return if ! -d $dir and not mkpath($dir);
+
+ open my $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;
+}
+
+sub _escape_from_body {
+ my ($class, $mail_r) = @_;
+
+ # breaking encapsulation is evil, but this routine is tricky
+ my ($head, $body) = Email::Simple::_split_head_from_body($$mail_r);
+ $body =~ s/^(From\s)/>$1/gm;
+
+ return $$mail_r = "$head\n$body";
+}
+
+sub _from_line {
+ my ($class, $mail_r) = @_;
+
+ # The trivial way
+ return if $$mail_r =~ /^From\s/;
+
+ # 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));
+}
+
+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 $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 ;
+}
+
+sub unlock {
+ my ($class,$fh) = @_;
+ flock ($fh, LOCK_UN);
+}
+
+1;
Added: packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery.pm
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery.pm 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/LocalDelivery.pm 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,79 @@
+package Email::LocalDelivery;
+# $Id: LocalDelivery.pm,v 1.16 2004/12/17 17:16:10 cwest Exp $
+use strict;
+
+use File::Path::Expand qw(expand_filename);
+use Email::FolderType qw(folder_type);
+use Carp;
+our $VERSION = '0.09';
+
+=head1 NAME
+
+Email::LocalDelivery - Deliver a piece of email - simply
+
+=head1 SYNOPSIS
+
+ use Email::LocalDelivery;
+ my @delivered_to = Email::LocalDelivery->deliver($mail, @boxes);
+
+=head1 DESCRIPTION
+
+This module delivers an email to a list of mailboxes.
+
+=head1 METHODS
+
+=head2 deliver
+
+This takes an email, as a plain string, and a list of mailboxes to
+deliver that mail to. It returns the list of boxes actually written to.
+If no boxes are given, it assumes the standard Unix mailbox. (Either
+C<$ENV{MAIL}>, F</var/spool/mail/you>, F</var/mail/you>, or
+F<~you/Maildir/>)
+
+=cut
+
+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/";
+
+ @boxes = $ENV{MAIL}
+ || (-e $default_unixbox && $default_unixbox)
+ || (-d $default_maildir."cur" && $default_maildir);
+
+ }
+ my %to_deliver;
+ push @{$to_deliver{folder_type($_)}}, $_
+ for map { expand_filename $_ } @boxes;
+ my @rv;
+ for my $method (keys %to_deliver) {
+ eval "require Email::LocalDelivery::$method";
+ croak "Couldn't load a module to handle $method mailboxes" if $@;
+ push @rv,
+ "Email::LocalDelivery::$method"->deliver($mail,
+ @{$to_deliver{$method}});
+ }
+ return @rv;
+}
+
+1;
+
+__END__
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2003 by Simon Cozens
+
+Copyright 2004 by Casey West
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 CONTACT
+
+http://pep.kwiki.org
+
+=cut
Added: packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/MANIFEST 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,12 @@
+Changes
+LocalDelivery.pm
+LocalDelivery/Maildir.pm
+LocalDelivery/Mbox.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/.cvsignore
+t/00compile.t
+t/mbox.t
+t/test_mbox
Added: packages/libemail-localdelivery-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/META.yml 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/META.yml 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,14 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Email-LocalDelivery
+version: 0.09
+version_from: LocalDelivery.pm
+installdirs: site
+requires:
+ Email::FolderType: 0.7
+ Email::Simple: 1.92
+ File::Path::Expand: 1.01
+ Test::More: 0.47
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.24
Added: packages/libemail-localdelivery-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/Makefile.PL 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/Makefile.PL 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,12 @@
+use strict;
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Email::LocalDelivery',
+ VERSION_FROM => 'LocalDelivery.pm',
+ PREREQ_PM => {
+ 'Email::FolderType' => '0.7',
+ 'Email::Simple' => '1.92',
+ 'File::Path::Expand' => '1.01',
+ 'Test::More' => '0.47',
+ },
+);
Added: packages/libemail-localdelivery-perl/branches/upstream/current/README
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/README 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/README 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,28 @@
+NAME
+ Email::LocalDelivery - Deliver a piece of email - simply
+
+SYNOPSIS
+ use Email::LocalDelivery;
+ my @delivered_to = Email::LocalDelivery->deliver($mail, @boxes);
+
+DESCRIPTION
+ This module delivers an email to a list of mailboxes.
+
+METHODS
+ deliver
+ This takes an email, as a plain string, and a list of mailboxes to
+ deliver that mail to. It returns the list of boxes actually written to.
+ If no boxes are given, it assumes the standard Unix mailbox. (Either
+ $ENV{MAIL}, /var/spool/mail/you, /var/mail/you, or ~you/Maildir/)
+
+COPYRIGHT AND LICENSE
+ Copyright 2003 by Simon Cozens
+
+ Copyright 2004 by Casey West
+
+ This library is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+CONTACT
+ http://pep.kwiki.org
+
Added: packages/libemail-localdelivery-perl/branches/upstream/current/t/.cvsignore
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/t/.cvsignore 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/t/.cvsignore 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1 @@
+test_mbox
Added: packages/libemail-localdelivery-perl/branches/upstream/current/t/00compile.t
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/t/00compile.t 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/t/00compile.t 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,6 @@
+#!perl -w
+use strict;
+use Test::More tests => 3;
+require_ok("Email::LocalDelivery");
+require_ok("Email::LocalDelivery::Mbox");
+require_ok("Email::LocalDelivery::Maildir");
\ No newline at end of file
Added: packages/libemail-localdelivery-perl/branches/upstream/current/t/mbox.t
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/t/mbox.t 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/t/mbox.t 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,28 @@
+#!perl -w
+use strict;
+use Test::More tests => 6;
+use Email::LocalDelivery;
+
+my $name = 't/test_mbox';
+unlink $name;
+
+my $mail = <<'MAIL';
+To: foot at body
+From: brane at body
+
+From here I can see the pub.
+MAIL
+
+my @delivered = Email::LocalDelivery->deliver( $mail, $name );
+is( scalar @delivered, 1, "just delivered to one mbox" );
+is( $delivered[0], $name, "delivered to the right location" );
+ok( -e $name, "file exists" );
+
+open my $fh, $name or die "couldn't open $name: $!";
+my $line = <$fh>;
+like( $line, qr/^From /, "added a From_ line" );
+
+ok( seek($fh, 0, 0), "rewound" );
+my $count;
+my @lines = grep { /^From / } <$fh>;
+is( scalar @lines, 1, "Just the one From_ line" );
Added: packages/libemail-localdelivery-perl/branches/upstream/current/t/test_mbox
===================================================================
--- packages/libemail-localdelivery-perl/branches/upstream/current/t/test_mbox 2005-12-19 22:39:03 UTC (rev 1696)
+++ packages/libemail-localdelivery-perl/branches/upstream/current/t/test_mbox 2005-12-19 22:41:07 UTC (rev 1697)
@@ -0,0 +1,5 @@
+From brane at body Fri Dec 17 12:11:24 2004
+To: foot at body
+From: brane at body
+
+>From here I can see the pub.
More information about the Pkg-perl-cvs-commits
mailing list