| Subject: | E::D::Maildir is B<very> slow |
| Subject: | bugfix |
diff -ur orig.Email-Delete-1.022/META.yml bugfix.Email-Delete-1.022/META.yml
--- orig.Email-Delete-1.022/META.yml 2007-02-15 15:24:47.000000000 +0200
+++ bugfix.Email-Delete-1.022/META.yml 2008-03-03 00:07:16.000000000 +0200
@@ -10,7 +10,6 @@
Email::FolderType: 0.7
Email::LocalDelivery: 0.213
Email::Simple: 1.92
- File::Find::Rule: 0.28
Test::More: 0.47
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.2.html
diff -ur orig.Email-Delete-1.022/Makefile.PL bugfix.Email-Delete-1.022/Makefile.PL
--- orig.Email-Delete-1.022/Makefile.PL 2007-02-15 15:22:48.000000000 +0200
+++ bugfix.Email-Delete-1.022/Makefile.PL 2008-03-03 00:07:16.000000000 +0200
@@ -10,7 +10,6 @@
'Email::FolderType' => '0.7',
'Email::LocalDelivery' => '0.213', # avoid 0.21[12], mangle tests
'Email::Simple' => '1.92',
- 'File::Find::Rule' => '0.28',
'Test::More' => '0.47',
},
VERSION_FROM => 'lib/Email/Delete.pm',
diff -ur orig.Email-Delete-1.022/lib/Email/Delete/Maildir.pm bugfix.Email-Delete-1.022/lib/Email/Delete/Maildir.pm
--- orig.Email-Delete-1.022/lib/Email/Delete/Maildir.pm 2006-08-14 19:34:48.000000000 +0300
+++ bugfix.Email-Delete-1.022/lib/Email/Delete/Maildir.pm 2008-03-07 17:39:57.000000000 +0200
@@ -5,24 +5,24 @@
use vars qw[$VERSION];
$VERSION = sprintf "%d.%02d", split m/\./, (qw$Revision: 1.1 $)[1];
-use File::Find::Rule;
use Email::Simple;
sub delete_message {
my %args = @_;
- my @files = File::Find::Rule->file
- ->grep(sub {
- local $_ = shift;
- local *MSG;
- open MSG, $_ or return;
- my $msg = Email::Simple->new(do{
- local $/; <MSG>;
- });
- close MSG;
- $args{matching}->($msg);
- })
- ->in($args{from});
+ my @files;
+# Whatever in F<tmp/> is undelivered yet, right?
+ foreach my $sect ( qw( new cur ) ) {
+# What if C<$args{from}> is something but directory? Never mind, just skip it.
+ opendir my($dh), "$args{from}/$sect" or next;
+ while(my $mail = readdir $dh) {
+# Faild to open subfolder? Here? Immaterial, go away.
+ -f "$args{from}/$sect/$mail" or next;
+ open my $fh, '<', "$args{from}/$sect/$mail" or next;
+ my $msg = Email::Simple->new(do { local $/; <$fh>; }) or next;
+ $args{matching}->($msg) and push @files, "$args{from}/$sect/$mail";
+ };
+ };
return unlink @files;
}
| Subject: | bugsample |
#!/usr/bin/perl
# $Id$
package main;
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = q(0.0.0);
use File::Temp qw(tempfile tempdir);
use Email::Simple;
use Email::Simple::Creator;
use Email::LocalDelivery;
use Email::Delete;
use Benchmark qw(timethese cmpthese timediff);
use Getopt::Std;
our($opt_a, $opt_b, $opt_d, $opt_f, $opt_m, $opt_r, $opt_x);
my $body = 'x' x 72 . "\n";
sub dump_stuff ($$) {
my($lib, $mbox) = ( @_ );
my $stuff = Email::Simple->create(
header => [
From => q(nobody@localhost.localdomain),
To => q(adm@localhost.localdomain), ],
body => $body x (256 * $opt_x),);
for my $flag (0 .. $opt_m - 1) {
$stuff->header_set(Subject => qq(This is $flag mail for $lib));
$stuff->header_set(q(X-Bugsample) => $flag % $opt_f ? 0 : 1);
Email::LocalDelivery->deliver($stuff->as_string, $mbox); }; };
sub bench_stuff ($$) {
defined(my $pid = fork) or
die qq|can't fork: $!\n|;
$pid and return;
my $lib = shift @_;
my $arch = shift @_;
my $mbox;
if($arch eq q(mbox)) {
(undef, $mbox) = tempfile qq(ed-bugsample.$lib.XXXXXX), DIR => q(/tmp); }
elsif($arch eq q(maildir)) {
$mbox = tempdir qq(ed-bugsample.$lib.XXXXXX), DIR => q(/tmp);
mkdir qq($mbox/$_)
foreach(qw(tmp new cur)); };
dump_stuff $lib, $mbox;
eval qq|use lib q(./$lib.Email-Delete-1.022/blib/lib);|;
if($lib ne q(none) && !$opt_a) {
for(1 .. ($opt_m + 1)/$opt_f) {
my $flag = 0;
Email::Delete::delete_message(
from => $mbox,
matching => sub {
warn q(looking at: ), $_[0]->header(q(Subject)), "\n"
if($ENV{VERBOSE});
$flag and return;
return ++$flag if(int shift(@_)->header(q(X-Bugsample)));
return; }); }; }
elsif($lib ne q(none)) {
Email::Delete::delete_message(
from => $mbox,
matching => sub {
warn q(looking at: ), $_[0]->header(q(Subject)), "\n" if($ENV{VERBOSE});
return int shift(@_)->header(q(X-Bugsample)); }); };
defined($pid = fork) or
die qq|can't fork to cleanup: $!\n|;
$pid and exit 0;
if(-f $mbox) {
unlink $mbox; }
elsif(-d $mbox) {
for my $kind (qw(tmp new cur)) {
opendir my $dh, qq($mbox/$kind) or
die qq|can't opendir ($mbox/$kind): $!\n|;
while(my $drop = readdir $dh) {
-f qq($mbox/$kind/$drop) or next;
unlink qq($mbox/$kind/$drop); };
rmdir qq($mbox/$kind) or
die qq|can't rmdir ($mbox/$kind): $!\n|; };
rmdir qq($mbox) or
die qq|can't rmdir ($mbox): $!\n|; };
exit 0; };
if(grep { m/.*help$/; } @ARGV) {
print STDERR <<"END_OF_HELP";
orig.Email-Delete-1.022 - original upstream distribution
bugfix.Email-Delete-1.022 - patched
both have C<perl Makefile.PL> and C<make> done
orig_ - upstream code
bugfix_ - bugfix code
none_ - void loop
_d - maildir
_b - mbox
-a - do one run
-b - skip mbox
-d - skip maildir
-f ratio - kill each <ratio> mail
-m number - fill folder with <number> mails
-r times - cycle tests number <times>
-x factor - enlarge each body <factor> times
\$ENV{VERBOSE} - enable messaging inside loop
END_OF_HELP
exit 0;
};
getopts q(abdm:r:x:f:);
$opt_m = 10 unless($opt_m);
$opt_r = 5 unless($opt_r);
$opt_x = 1 unless($opt_x);
$opt_f = 1 unless($opt_f);
my $rc =
timethese $opt_r, {
!$opt_b ? (
none_b => sub {
bench_stuff q(none), q(mbox);
undef until(wait == -1); },
orig_b => sub {
bench_stuff q(orig), q(mbox);
undef until(wait == -1); },) : ( ),
!$opt_d ? (
none_d => sub {
bench_stuff q(none), q(maildir);
undef until(wait == -1); },
orig_d => sub {
bench_stuff q(orig), q(maildir);
undef until(wait == -1); },
bugfix_d => sub {
bench_stuff q(bugfix), q(maildir);
undef until(wait == -1); },) : ( ), },
q(nop);
cmpthese $rc, q(nop);
# vim: set filetype=perl