Package: libmail-mbox-messageparser-perl Version: 1.4002-1 Severity: grave Justification: causes non-serious data loss
Hello, my program mail-expire uses this module to split mbox files into individual messages. Sometimes, however, the end of file is reported too early and data is _lost_ because of that. I did not try to investigate the issue yet, test data is in: http://people.debian.org/~blade/debian-user-german.Apr_2006.bz2 and the current version of the script is attached, with debugging output enabled. If you look at that, it stops splitting the contents at <[EMAIL PROTECTED]> and returns the rest as one big message. Regards, Eduard. -- System Information: Debian Release: testing/unstable APT prefers unstable APT policy: (500, 'unstable'), (1, 'experimental') Architecture: amd64 (x86_64) Shell: /bin/sh linked to /bin/bash Kernel: Linux 2.6.16-1-amd64-k8 Locale: LANG=de_DE.UTF-8, LC_CTYPE=de_DE.UTF-8 (charmap=UTF-8) Versions of packages libmail-mbox-messageparser-perl depends on: ii libfilehandle-unget-perl 0.1621-2 a FileHandle which supports ungett ii perl 5.8.8-4 Larry Wall's Practical Extraction libmail-mbox-messageparser-perl recommends no packages. -- no debconf information --
#!/usr/bin/perl # SEE DEBIAN CHANGELOG FOR NEWER ENTRIES # mail-expire, Version 0.2; Fri, 16 Aug 2002 11:39:10 +0200 # Copyright: Eduard Bloch <[EMAIL PROTECTED]> # # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. The full text of GPL can be # found on http://www.gnu.org or in /usr/share/common-licenses/GPL on # modern Debian systems. # # ---------------------------------------------------------- # If you make changes to this script, please forward the new # version to <[EMAIL PROTECTED]> or <[EMAIL PROTECTED]> # ---------------------------------------------------------- # # REQUIRED PACKAGES: # # libcompress-zlib-perl - Perl module for creation of gzip files # libdate-calc-perl - Perl library for accessing dates # # Changes by Johannes Kolb: # * use Date::Calc instead of Date::Manip to increase performance # * no buffering of whole mailbox-files in memory # # Changes by Florian Krohs <[EMAIL PROTECTED]> # * append old mails to mailbox.month_year.gz # * added zlib to free some space:] # # Changes by Eduard Bloch <[EMAIL PROTECTED]> # * small hack to vary the output filename to prevent overwritting # * some cosmetics, fixed typos # * dropped silly size comparison, trust return values of syswrite use strict; my $target="./"; sub help { die "Usage: $0 [ options ] DAYS FILES where DAYS is an integer specifying the maximum age of a mail in days and FILES one or more mbox file(s). Options: -u choose different filenames if the target file already exists --delete drops the old messages. Be warned, no backup will be made! --dry-run Just print what it would do, no real action -t DIR new target directory DIR "; } use Getopt::Long qw(:config no_ignore_case bundling pass_through); my $uoption=0; my $deloption=0; my $dry_run=0; my $help; my %opts = ( "t=s", \$target, "delete", \$deloption, "dry-run", \$dry_run, "help|h", \$help, "u", \$uoption ); &help if !GetOptions(%opts); &help if $help; my $days=shift(@ARGV); die "Please specify a valid day count!\n" if abs($days)<1; die "Please specify mbox file names!\n" if ! @ARGV; for(@ARGV) { die "Unable to read $_\n" if not -r $_ }; use Date::Calc qw(Parse_Date Today Delta_Days); use Compress::Zlib ; use Fcntl; use Mail::Mbox::MessageParser; my $c=-1; my @today = Today(); my $old_all = localtime(time - $days * 86400); $old_all =~ s/\ +/\ /g; my @splitdate=split(/\ /,$old_all); my $olddate=$splitdate[1] . "_" . $splitdate[4] . ".gz"; JOB: foreach my $filename (@ARGV) { my @st; my @time; my $c; my $oldsize = (stat($filename))[7]; if ($oldsize == 0) { syswrite(STDOUT,"Empty file $filename, skipping."); next JOB; }; if(-e "$filename.new") { syswrite(STDOUT,"Temporary file $filename.new already exists, skipping $filename.\n"); next JOB; }; if(!open(fh,$filename)) { syswrite(STDOUT,"$filename could not be opened, skipping"); next JOB; }; if(flock(fh,2|4)){ # lock when not locked already by another process flock(fh,2) || die "unexpected trouble on locking $filename"; } else { # skip file close(fh); syswrite(STDOUT,"$filename is locked by an other prozess, skipping."); next JOB; }; my $file_handle = new FileHandle($filename); my $folder_reader = new Mail::Mbox::MessageParser( { 'file_name' => $filename, 'file_handle' => $file_handle, 'enable_cache' => 0 } ); # die "he? ".ref($folder_reader); #die ref($folder_reader); if (ref($folder_reader) ne "Mail::Mbox::MessageParser::Grep") { syswrite STDERR, "Unable to parse contents of $filename, skipping.\n"; next JOB; } my $gzfilename; if(!$dry_run) { sysopen(neu,"$filename.new", O_RDWR|O_EXCL|O_CREAT) || die "Error creating temporary file, move $filename.new out of the way"; $gzfilename="$target/$filename".".$olddate"; } while(-s $gzfilename && $uoption) { my $modnumber += 0; # to preset a value $gzfilename="$target/$filename.".$splitdate[1] . "($modnumber)_" . $splitdate[4] . ".gz";; $modnumber++; } my $gzfile_ist_neu=1 if(!-e $gzfilename); my $alt; if(!$deloption && !$dry_run) { $alt = gzopen($gzfilename, "ab") or die "cannot open file: $gzerrno\n"; } syswrite (STDOUT,"I: Reading and splitting $filename ($oldsize bytes)...\n"); syswrite(STDOUT, "I: Analyzing ages (days before expiration): "); my $alte=0; my $neue=0; while(!$folder_reader->end_of_file()) { my $email = $folder_reader->read_next_email(); my $isold; $$email=~/^From\s\S+\s+(.*)/m; my $date=$1; #syswrite (STDERR, "hm, $1\n"); if($1) { $c++; my @maildate = Parse_Date($date); @maildate = (1970,1,1) if scalar @maildate ==0; my $diff = Delta_Days(@maildate,@today); syswrite(STDERR, "Date, Diff, Contents:\n$date, $diff\n$$email\nEND_OF_MAIL\n"); if ($#maildate != 2) { # mail header broken $neue++; syswrite(STDOUT, "(new: date could not be parsed!), "); } else # mail okay { syswrite(STDOUT, $diff); if ($diff > $days) { $isold = 1; $alte++; syswrite(STDOUT, "(old), "); } else { $neue++; syswrite(STDOUT, "(new), "); } } } if ($isold) { if(!$deloption && !$dry_run) { $alt->gzwrite($$email) or die "error writing to gz buffer : $gzerrno\n"; } } else { defined(syswrite(neu, $$email)) || die "Failure while writting - disc full?"; } } $alt->gzclose if(!$deloption && !$dry_run); flock(fh, 8); close(fh); close(neu); #die "ohje"; if($alte==0 && $gzfile_ist_neu==1 && !$deloption && !$dry_run) { unlink($gzfilename)|| die "failed - removed gzip file [empty]\n"; } if( ($alte+$neue) < 1) { syswrite STDOUT, "No changes, ignoring file\n"; next JOB; } my $newsize = (stat($gzfilename))[7]; # no longer interessting, beautify it $gzfilename=~s!^\.//?!!; syswrite (STDOUT,"\n\nI: Wrote $neue new entries to $filename.new\n") if(!$deloption); syswrite (STDOUT,"\nI: Wrote $alte old entries to $gzfilename\n"); if(!$dry_run) { syswrite (STDOUT,"Deleting $filename... "); unlink($filename) || die "failed while deleting original mbox"; syswrite (STDOUT,"replacing with the new mailbox... "); rename("$filename.new", $filename) || die "failed"; syswrite (STDOUT,"done"); # syswrite (STDOUT," (saved $diff bytes)") if(!$deloption); syswrite (STDOUT,".\n"); if(-e "$filename.new"){unlink("$filename.new") || die "Could not remove temporary file... Odd things happen!";} } }
