grepmail-5.3033/0000755000076500001200000000000010571626331012556 5ustar coppitadmingrepmail-5.3033/anonymize_mailbox0000755000076500001200000000704510474661661016245 0ustar coppitadmin#!/usr/bin/perl -w $VERSION = '1.00'; use strict; use FileHandle; #------------------------------------------------------------------------------- my $LINE = 0; my $FILE_HANDLE = undef; my $START = 0; my $END = 0; my $READ_BUFFER = ''; sub reset_file { my $file_handle = shift; $FILE_HANDLE = $file_handle; $LINE = 1; $START = 0; $END = 0; $READ_BUFFER = ''; } #------------------------------------------------------------------------------- # Need this for a lookahead. my $READ_CHUNK_SIZE = 0; sub read_email { # Undefined read buffer means we hit eof on the last read. return 0 unless defined $READ_BUFFER; my $line = $LINE; $START = $END; # Look for the start of the next email LOOK_FOR_NEXT_HEADER: while($READ_BUFFER =~ m/^(From\s.*\d:\d+:\d.* \d{4})/mg) { $END = pos($READ_BUFFER) - length($1); # Don't stop on email header for the first email in the buffer next if $END == 0; # Keep looking if the header we found is part of a "Begin Included # Message". my $end_of_string = substr($READ_BUFFER, $END-200, 200); if ($end_of_string =~ /\n-----( Begin Included Message |Original Message)-----\n[^\n]*\n*$/i) { next; } # Found the next email! my $email = substr($READ_BUFFER, $START, $END-$START); $LINE += ($email =~ tr/\n//); return (1, $email, $line); } # Didn't find next email in current buffer. Most likely we need to read some # more of the mailbox. Shift the current email to the front of the buffer # unless we've already done so. $READ_BUFFER = substr($READ_BUFFER,$START) unless $START == 0; $START = 0; # Start looking at the end of the buffer, but back up some in case the edge # of the newly read buffer contains the start of a new header. I believe the # RFC says header lines can be at most 90 characters long. my $search_position = length($READ_BUFFER) - 90; $search_position = 0 if $search_position < 0; # Can't use sysread because it doesn't work with ungetc if ($READ_CHUNK_SIZE == 0) { local $/ = undef; if (eof $FILE_HANDLE) { my $email = $READ_BUFFER; undef $READ_BUFFER; return (1, $email, $line); } else { $READ_BUFFER = <$FILE_HANDLE>; pos($READ_BUFFER) = $search_position; goto LOOK_FOR_NEXT_HEADER; } } else { if (read($FILE_HANDLE, $READ_BUFFER, $READ_CHUNK_SIZE, length($READ_BUFFER))) { pos($READ_BUFFER) = $search_position; goto LOOK_FOR_NEXT_HEADER; } else { my $email = $READ_BUFFER; undef $READ_BUFFER; return (1, $email, $line); } } } sub Read_Chunk_Of_Body { my $email = shift; local $/ = "\nFrom "; my $chunk = <$FILE_HANDLE>; local $/ = "From "; chomp $chunk; $LINE += ($chunk =~ tr/\n//); $$email .= $chunk; } die unless @ARGV; $FILE_HANDLE = new FileHandle($ARGV[0]); while(1) { my ($status,$email,$line) = read_email(); exit unless $status; my ($header,$body) = $email =~ /(.*?\n\n)(.*)/s; $body =~ s/\w/X/g; { my ($header_to) = $header =~ /^To: (.*)$/m; my ($header_subject) = $header =~ /^Subject: (.*)$/m; if (defined $header_to) { my $modified_header_to = $header_to; $modified_header_to =~ s/\w/X/g; $header =~ s/To: \Q$header_to\E/To: $modified_header_to/g; } if (defined $header_subject) { my $modified_header_subject = $header_subject; $modified_header_subject =~ s/\w/X/g; $header =~ s/Subject: \Q$header_subject\E/Subject: $modified_header_subject/g; } } print $header,$body; } grepmail-5.3033/CHANGES0000644000076500001200000007405010571625565013567 0ustar coppitadminFeatures which haven't made it in yet: - Support for searches on email threads. (Thanks to Zack Brown for the excellent feature idea and a prototype implementation.) Version 5.3033: - Improved the documentation for -Y. (Thanks to Justin Gombos for the suggestion.) - Dropped tzip support in Mail::Mbox::MessageParser - Added -L flag to follow symbolic links. (Thanks to Peter Teuben for prompting the idea.) - Fixed grepmail so that it works with Mail::Mbox::MessageParser 1.5000 (Thanks to Paul for the bug report, and Alexey Tourbin for the fix.) - Fixed testspeed.pl to properly call report() instead of get_report() on new versions of Benchmark::Timer Version 5.3032: Tue Aug 2 2005 - Fixed backwards diff in test cases - Updated Mail::Mbox::MessageParser dependency to latest version, and updated test cases as well. (Thanks to Christoph Thiel for the heads up.) Version 5.3031: Mon Jun 6 2005 - Fixed a bug that would cause the date_manip test to fail in some time zones. (Thanks to Kurt Roeckx for the Debian bug report, and Joey Hess for notifying me.) - Added a missing "use" statement in Test::Utils. - Improved date matching for mailboxes containing invalid dates. (Thanks to Steve Revilak for the patch.) Version 5.3030: Tue Dec 21 2004 - Improved test failure reporting - Fixed version numbers, which were incompatible with some modules. (Thanks to Tassilo von Parseval for the bug report) - Cleaned up code a bit Version 5.30.2: - Switched to Test::More for better test reporting Version 5.30.1: Thu Sep 16 2004 - Fixed Date::Manip parsing of single-point times such as "today". (Bug found by Marten van Wezel ) - Changed Makefile.PL to use Module::Install - Changed version numbering - Dropped Benchmark::Timer from the distribution, since the updated version has been released New in version 5.30: - Updated t/recursive.t to work better when there are version control directories in t/mailboxes/directory. (Thanks to Joey Hess for the feature suggestion and initial patch.) - Updated t/invalid_mailbox.t to be more robust. (Thanks to an anonymous bug report on SourceForge.) - Fixed a bug in t/invalid_mailbox.t for Solaris. (Thanks to Jost Krieger for the bug report.) - -F now works again (Thanks to Graham Gough for the bug report.) - Changed incorrect "-h" to "--help" in two error messages. (Thanks to David Sewell for catching this.) - Now correctly handles DOS-style line endings in mailboxes. (Thanks to Martin Hosken for the initial patch.) Requires Mail::Mbox::MessageParser 1.20 or better now. - Changed single dates so that they are treated as inferred spans, instead of a single day. For example "2004" now means "between Jan 1 2004 and Jan 1 2005" instead of "between Jan 1 2004 and Jan 2 2004". (Thanks to Dan Pritts for the feature suggestion.) New in version 5.23: - Updated test cases to run under Windows. - Fixed a bug in speed tests which would cause the grep implementation to fail. - Fixed incorrect output for emails without message bodies. (Thanks to Volker Kuhlmann for the bug report.) - Fixed filename output for -n, -m and other situations when input comes from standard input. (Thanks to an anonymous submittor on SourceForge for an initial patch.) - Added -w flag to match word boundaries. (Thanks to Ed Avis for the feature request.) - A warning is now issued and caching is disabled if -C is not specified and $HOME is not set (as might be the case when running grepmail in a cron job). (Thanks to Dr. Oliver Muth for the bug report.) New in version 5.22: - X-Mailfolder header no longer has a line number when -n is used. (bugfix by Kevin Pfeiffer ) - New -B flag prints abbreviated headers (initial patch by Kevin Pfeiffer ) - Headers spanning multiple lines are now printed correctly in warnings and such. - Fixed a spurious warning which would be printed if caching was not enabled. - grepmail will now disable caching if the caching version of Mail::Mbox::MessageParser can not be loaded, instead of exiting. New in version 5.21: - Fixed line ending bugs under MS-DOS/Windows. New in version 5.20: - Added speed testing to the distribution - Fixed Makefile.PL so that test modules would not be installed. - Changed testing to use PERLRUN instead of FULLPERLRUN, which is not available with older versions of MakeMaker that ship with older versions of Perl. (Thanks to Ed Avis for catching this.) - Fixed interactive installation problems. (Thanks to Joey Hess for catching this (again).) - Fixed broken searching of $HOME/mail, $HOME/Mail, and $HOME/Mailbox directories when a mail folder can not be found. Changed $MAIL to $MAILDIR since $MAIL usually points to the user's inbox. (Bug found and initial patch by Peter Cordes .) - Cache file permissions are now set to protect against prying eyes. (Patch by Joey Hess ) - The user can now specify the cache file location with the -C flag. - Fixed compatibility problems with perl 5.005_01 New in version 5.10: - Extracted mail parsing into the new Mail::Mbox::MessageParser module. - Fixed small performance loss bugs in short-circuit matching of headers which were introduced in the last version - Fixed some uses of uninitialized values (Originally reported by Ed Avis .) - Improved performance a bit. - The Makefile.PL now uses the default values when run non-interactively. - Caching is now enabled by default. (It's no longer experimental.) Users can disable it during installation. - Date specifications without times (e.g. "today") are interpreted as midnight of the given day instead of the current time of that day. grepmail now relies on Date::Manip to handle this--users must upgrade Date::Manip to get this support. (Thanks to Reuben Thomas for working with Sullivan Beck to get TodayIsMidnight added to Date::Manip. Original bug report by Philip Douglass ) - Restructured test cases New in version 5.00: - grepmail is now orders of magnitude faster for mailboxes which have very large (>30MB) emails in them - "grep" is now used to find the start of emails, if it is installed. For mailboxes with large emails in them, this can speed things up by about 5x. - Reduced memory consumption by about 3 times. - -- now marks the end of options and the beginning of folders (Thanks to Reuben Thomas for the idea.) - -f now reads patterns from a file like GNU grep does. (Feature suggestion by Darxus@chaosreigns.com) -j is now used for status - Added smail compatibility. (Thanks to Roy for the patch.) - The "**" prefix on warnings has been changed to "grepmail:" - Date specifications without times (e.g. "today") are interpreted as midnight of the given day instead of the current time of that day. (Bugfix and initial patch by Reuben Thomas .) - Fixed -i when used with -Y--it was always case sensitive. (Bugfix by Michael C. Toren ) - Updated t/functionality.t to avoid running gzip-related test cases when gzip is not installed on the system. - Improved some error messages so that they prepend "grepmail: " as they should - Cleaned up some warnings about ambiguous hash values (Thanks to Philip Douglass for pointing them out in a bug report.) - Added a warning about the version of perl required for new pattern features (Thanks to Philip Douglass for the bug report.) - -t flag is now -j - Fixed broken Gnus support - Improved test case for Gnus New in version 4.91: - Added missing dependency for Storable. - Storable now only necessary if you plan on using caching - Fixed a bug in test case 83 - Changed -s to support "<", ">", "<=", ">=" and "-". (Feature suggestion by Jens Schleusener ) New in version 4.90: - Made Mail::Folder::SlowReader object-oriented - Removed FastReader from distribution. (It's no longer faster! Also, I couldn't integrate it easily with the new object-oriented reader design.) - Fixed a bug where in some cases emails were not being converted to mbox format before being printed - Made searches involving header-related constraints a bit faster - Added missing documentation for -F flag - Added -f flag to search based on message status. (Feature suggestion by Richard D Alloway ) - Fixed a bug where -X and -Y flags after a pattern would not be processed - Added experimental caching capability, which is perhaps 5% slower the first time you run grepmail on a mail folder, and 10-20% faster on subsequent runs. The cache is stored in ~/.grepmail-cache. You must edit the grepmail file and set $USE_CACHING to true to use this feature. (Idea and initial patch by terry jones ) New in version 4.81: - Fixed incompatibilities with older (5.005_03) versions of Perl - Fixed test cases which fail on operating systems (shells?) which emit "Broken Pipe" to standard output. I'd rather break the pipe than have grepmail gobble megabytes of data when it can't handle it. - Added --version flag (patch by Gerald Pfeifer ) - Added documentation for -V flag. New in version 4.80: - Added prototype -E flag to support complex searches. (Thanks to Nelson Minar for the original suggestion in Sep 2000, And terry jones for seconding the idea.) - Added -F flag to force processing of files which grepmail determines are not mailboxes. (feature suggested by terry jones ) - Documentation updated to reflect that -B no longer exists. (By terry jones ) - The test to determine if a file is a mailbox was improved to adhere better to RFC 822, while still providing some flexibility. (Initial suggestion and patch by terry jones ) - Improved date extraction to also look at the 'From ' line when both the Received and Date headers fail. (patch by terry jones ) - Fixed a long-standing bug in which filenames of compressed mailboxes which contained special shell characters would cause problems. (Thanks to Jost Krieger for giving me the kick in the pants to finally fix this.) - Fixed a long-standing bug in which grepmail would incorrectly report the filename of compressed mailboxes in error messages. (Thanks to Jost Krieger for giving me the kick in the pants to finally fix this.) New in version 4.72: - 20% speed improvement in the Perl mailbox parser (By terry jones ) - Fixed a number of potential bugs in command line processing and date processing. (By terry jones ) - Cleaned up return values and use of quotes in the code. (By terry jones ) - Fixed a bug in -X signature processing (By terry jones ) - Modified anonymize_mailbox to anonymize To: and Subject: in the header. (Thanks to terry jones for the idea.) - Fixed a bug in FastReader where emails less than 255 characters in size would occasionally cause a core dump. (Thanks to terry jones for submitting a bug report and sample mailbox.) - Made "big" test mailboxes 4 times bigger for more meaningful speed tests New in version 4.71: - Fixed warning about SIGHUP on Windows. - Fixed -u functionality for emails without the Message-Id header. (Thanks to Felix E. Klee for finding the bug.) NOTE: grepmail will use Digest::MD5 to compute a hash for the email header. If you don't have Digest::MD5, grepmail will just store the header. So, the default tradeoff is time for space. - Fixed a bug in the test script. (Thanks to Joey Hess for finding and fixing the bug.) - Extended workaround for spurious warning about undefined variable to Perl 5.8. (Thanks to Joey Hess for reporting the ongoing heisenbug.) New in version 4.7: - Fixed signal handling to make grepmail easier to debug. Thanks to Ilya Zakharevich for providing the solution. - Fixed a possible performance problem in reading of emails (Perl implementation), and documented the settings in the README. - Expanded the pattern for matching the start of emails to allow different types of emails to be parsed. - Fixed a bug where -R was reported as not recognized. (Thanks to Nicholas Riley for the bug report and fix.) - "anonymize_mailbox" utility included to help people submit bug reports - If a mailbox can not be found, grepmail now searches the $home/mail, $home/Mail, $home/Mailbox directories (or the directory specified by the MAIL environment variable). (Thanks to Michael Friendly for the feature suggestion and initial patch.) - Added -X flag to allow the user to specify a pattern for the signature separator. (Thanks to Michael Friendly for the feature suggestion.) - Added -Y flag to search specific headers. (Thanks to Terry Jones for the idea to automatically wrap header lines as necessary.) New in version 4.60: - Removed -B flag and added -S flag. -B is now performed using -bS. - Added installation flags to suppress interactive installation. (Thanks to Joey Hess for the problem report. He had to patch Makefile.PL for his Debian packaging.) - Fixed a slow implementation of searching for signatures that would cause grepmail to crawl for very large emails. Thanks to Joey Hess for discovering the inefficiency. - Fixed a short-circuit which should have bypassed the search for signatures if -B was not specified. Thanks to Joey Hess for finding the bug. - Implemented a new Perl parser which is 5% to 50% faster depending on how I/O-bound your system is. - Restructured the code a bit and improved detection of invalid arguments. New in version 4.51: - grepmail now dies gracefully when invalid patterns like 'strcpy(' are supplied. (It should be 'strcpy\('.) - Fixed a bug in attachment boundary matching which would cause the boundary match to fail if the boundary contained special pattern matching characters. (Thanks to Richard Everson for identifying the bug, and providing a sample email which demonstrates the problem.) - Added a check for Inline 0.41 or better during "perl Makefile.PL" when Mail::Folder::FastReader is selected to be installed. (Thanks to Brian L. Johnson for the problem report.) - Fixed a bug where grepmail would fail to print matching emails which had signatures, and added a test case for it. This bug was introduced with -B support in version 4.49. (A *huge* thanks to Moritz Barsnick for reporting the bug and doing the initial analysis of the cause.) - Modified Makefile.PL to ask whether the user wants FastReader regardless of whether they specified arguments to "make Makefile.PL". - Modified Makefile.PL to allow the user to interactively specify the installation path. - Fixed a typo in debugging output for emails without "Date:" headers. - Improved error messages. - Usage message now displays just the flags, --help shows a summary of their meanings as well. New in version 4.50: - Added X-Draft-From to support newer versions of Gnus (Thanks to Nevin Kapur for the patch). New in version 4.49: - Fixed test cases to work around PATH modifications made by Date::Manip - Added -B to search the body but not the signature. (Thanks to Helmut Springer for the feature request.) - Added LICENSE file. (Thanks to Janet Casey for the reminder.) New in version 4.48: - Mail::Folder::FastReader migrated from XS to Inline. - -H flag added by Nevin Kapur - Error messages are localized in test cases. (Thanks to cpan-testers and in particular Jost Krieger for finding this bug and diagnosing it.) - Fixed a problem with timezones in the test cases. (Thanks to Roy Lanek for helping me debug this.) - Added a check in the test cases for determining if the user's timezone is not recognized by Date::Manip. New in version 4.47: - Grepmail now converts Gnus emails into mbox emails before printing them. (Thanks to Johan Vromans for supplying a patch and explaining the need for it. - Fixed a couple bugs in -M processing - -M is now 19% faster. (It's now only about 9% slower than without -M.) New in version 4.46: - Fixed a bug in -u message id processing. (Thanks go to an anonymous bug reporter on SourceForge.) - Added more workarounds to prevent warnings resulting from a bug in Perl 5.6 (Thanks to Joey Hess ) - Added -Z flag to tell grepmail not to use Mail::Folder::FastReader even if it is installed. - Fixed a bug introduced in version 4.44 where -m would not work unless used with -n. (Thanks to Imre Simon for catching this.) - --help anywhere on the command line now causes the help to be printed, instead of only when used as the first argument. - Test script now exercises both the Mail::Folder::FastReader and perl mailbox implementations as appropriate. - Restructured code to separate out Perl mailbox implementation as Mail::Folder::SlowReader. (This module is embedded in the grepmail script.) New in version 4.45: - Added -n and -V to usage message. (Thanks to Wolfgang Rohdewald for catching this.) - Added workarounds to prevent warnings resulting from a bug in Perl 5.6 - A blank line before the start of an email is not required now. This allows broken folders created by Netscape to be read. (Thanks to Jeremy Malcolm for the bug report.) - Mail::FastReader is 8% faster. New in version 4.44: - execution with -M flag now 35% faster - Added a Mail::Folder::FastReader module which can cause grepmail to run 10-40% faster, depending on your system. Since this module is experimental, the installation script will allow you to not install the module. A C compiler is required. - "-----Original Message-----" now recognized as beginning an included message - Fixed a bug where errors would not be displayed if compressed data was piped to grepmail - Date::Parse is now only required if -d is used. (Date::Manip is still only required if you use complex date specfications.) (Thanks to Richard Stallman for pointing this out.) - Added -n flag to print line numbers a la grep. (Thanks to Richard Stallman for the suggestion) - Fixed a bug in debug output where the email subject was actually the sender - Fixed an undefined value in the printing of flag information - An ASCII file is now determined to be a mailbox if it has a line whose prefix is 'From' or 'X-From-Line:', and another line whose prefix is 'Received ', 'Date:', 'Subject:', 'X-Status:', or 'Status:'. - Error exits now return 1 (Thanks to Wolfgang Rohdewald for the bug report) - -V flag prints the version (Thanks to Wolfgang Rohdewald for the feature request) - Restructured code: localized reading of the emails from the file, removed two functions New in version 4.43: - Fixed a bug in -r counting when used with -h. (Thanks to Andrew for the bug report.) - Fixed a bug in the handling of included messages. (Thanks to Antoine Martin for the bug report and suggestion for the fix.) New in version 4.42: - Added -a flag to use received date instead of sent date for -d matches. (Thanks to Michael Liljeblad for the patch.) - Included emails are now ignored properly (Thanks to an anonymous submittor for the bug report and part of a patch https://sourceforge.net/bugs/?func=detailbug&bug_id=112159&group_id=2207) - If an email has no date, the -d switch now issues a warning and does not treat the email as a match (Thanks to David Blaine for the bug report.) - -d "" can be used to find emails without dates - Mailbox files are now detected as files using if ($buffer =~ /^(X-From-Line:|From) /im && $buffer =~ /^Subject: /im) rather than if ($buffer =~ /^(X-From-Line:|From) /im && $buffer =~ /^Date: /im) - Improved detection of binary files. (Thanks to Dan Sugalski for the sample code.) - STDERR and STDOUT now checked separately during "make test" - Headers can now be in the format "Date:" in addition to "Date: " (Thanks to Benjamin Korvemaker for the patch and concept.) New in version 4.41: - Support for Gnus-style mail files added (Thanks to Werner Bosse for the patch.) - Test mail files tweaked to make the test cases work better across all time zones. (Thanks to Andreas Kutschera for the patch.) - Added check for unparsable dates in email headers. - Fixed a Perl warning raised when date parsing fails. - Added instructions for getting the necessary modules to README. New in version 4.40: - Date::Parse and Date::Manip version unified -- Date::Parse is now required, and Date::Manip (if present) is used to parse complex dates. (Patch by Seth Cohn , modified by David Coppit) New in version 4.31: - Distro has missing test cases for -u functionality. Doh! New in version 4.30: - Updated code to avoid warnings under Perl 5.6 (Thanks to Andreas Kutschera for the bug report.) - Fixed a bug in the test script where bzip2, gzip, and tzip support would not be tested even though the programs were available. (Thanks to Andreas Kutschera for the patch.) - Added standard --help flag (Patch by Seth Cohn ) - Added -u ("unique") flag, which ensures that no duplicate messages will be output. (A BIG thanks to Seth Cohn .) New in version 4.23: - Updated the test cases to work better in timezones close to +0000 and +2300. (email if you have problems with tests 1 and 23. Thanks to Harald Krause for first finding the bug, and Adam Huffman for his help debugging it.) - Fixed a bug in the "ignore attachments" code New in version 4.22: - grepmail now behaves better when tzip, bzip2 or gunzip aren't present on the system. - The code has been restructured to compile more easily with perlcc. New in version 4.21: - Fixed a bug that would cause grepmail to runaway when a pipe following it was broken. (Thanks to Gerald Pfeifer for the bug report) New in version 4.20: - grepmail development has been moved to SourceForge, and made public. Visit http://grepmail.sourceforge.net/ - Added -s flag, which limits matched emails to a given size - Restructured the code to be more robust with respect to feature interaction. (At a 5-10% slowdown cost.) - Fixed an uninitialized variable warning caused by emails without subjects in debug mode. New in version 4.11: - Fixed a bug where an ASCII file would not be recognized as a mailbox when the first couple emails did not have a "From:" line. (Thanks to Jeff Flowers ) - Added standard Perl testing. New in version 4.1: - Stripped auto-perl execution code, since it never works on all platforms. (Installation instructions modified to require the user to fix the #! line.) - Minor changes to allow grepmail to run without -w complaints. New in version 4.0: - Fixed a bug where shell characters needed to be escaped for compressed files. (Bug found by Richard Clamp - Added #!/bin/sh as first line to make the rest compatible with csh/tcsh users. (Bug found by Ed Arnold ) New in version 3.9: - Took out specialization engine because there wasn't enough support to program in that style. - Offering 2 main versions now -- Date::Manip and Date::Parse - Added -R option, which causes grepmail to recurse any directories encountered. (Thanks to Emil Tiller for the initial code.) - Fixed a small bug that would cause some attachments not to be identified. New in version 3.8: - Added a prototype engine to allow users to specialize grepmail at installation time. (See below) - Fixed buggy mailbox detection algorithm - Fixed bug in identification of email headers. - Fixed bug in parsing timezones of emails. (Thanks to Wolfgang Weisselberg ) - Fixed bug in handling of date specifications like "2 days ago" and "2 weeks ago" - Added -M switch, which causes grepmail to ignore non-text attachments. - Added "quiet mode", -q switch, which supresses warnings about directories, non-mailbox ASCII files, binary files that can't be decompressed, etc. - Restructured code a bit. Moved file and STDIN processing out of main. The whole email is now read before the match is made to the body, instead of trying to match the pattern while reading the body. (This simplifies the algorithms and makes -M support a lot easier, at the cost of increasing the required memory slightly.) Now uses ungetc to put the test characters used during file type detection back on the stream. New in version 3.7: - Added -D for debugging output - Now ignores ASCII files that don't look like mailboxes. Thanks to oak for pointing this out. - Uses Date::Parse instead of Date::Manip, which results in faster execution time at the expense of less flexibility. (e.g. You can't do "12pm January 5 1997" any more) New in version 3.6: - No more temporary files! This addresses the security issues that a few people have sent me email about. The script may use slightly more memory, depending on the size of the largest email. (Email is now buffered as it is read, and the whole buffer is printed when a match occurs. This is in contrast to storing the file pointer and seeking back to the start of the email.) The script is substantially faster for large amounts of data piped as STDIN. Many thanks go to Joey Hess (), who supplied insights and contributions toward making this release happen, especially the buffering code. New in version 3.5: - grepmail will not try to decompress piped input that is empty. - Temporary files are now placed in the user's home directory to help avoid privacy attacks (or in the directory specified by the TMPDIR environment variable, if it exists). - Fixed a bug that would occasionally leave a tempfile around. New in version 3.4.1: - Fixed a bug that added an extra line to the start of output. (Thanks to Moritz Barsnick for helping to find this.) New in version 3.4: - Added tzip support. (thanks to Marc Lehmann ) - Reordered flags to better match grep. - Changed command line syntax again. (Last time, I hope.) New in version 3.3: - Added bzip2 support. (thanks to Josh Plautz ). - Improved error checking on piped binary input. - Added debugging code. New in version 3.2: - Added TMPFILE environment variable support, and a signal handler. (thanks to Ulli Horlacher (). - Fixed a bug where the last paragraph of the last email in a mailbox would not be printed on Linux. (How's that for obscure? Thanks to Eli Criffield for discovering it.) New in version 3.1: - Modified the decompression to be more compatible with older versions of gzip. - Improved error checking so that "grepmail -h" prints a usage message. - Added -m flag, which causes an "X-Mailfolder" line to be added to the header, thereby showing which folder contained the message. (by Ulli Horlacher ). - Improved error checking on flags. - Changed "zcat" to "gunzip -c" to help with backwards compatibility with older versions of gzip (thanks to Eugene Kim ). New in version 3.0: - -h and -b can be used together. - Rewrote the ProcessMailFile to run 2 to 3 times faster, and use less memory. - Correctly diagnoses directories as such (by Gerald Pfeifer ). New in version 2.1: - Added -l,-r, and -e, as suggested by Reinhard Max . - Now uses about 1/3 the memory, and is a little faster. New in version 2.0.1: - Added POD documentation at the end of the script (thanks, Jeffrey Haemer ). - -h for headers only -b for body only New in version 1.9: - "Ignore empty files" by Gerald Pfeifer . - Emails without dates are now automatically output no matter what the date specification is. (Better safe than sorry!) New in version 1.7: - Sped up by Andrew Johnson. It no longer looks for dates unless the email matches the search string. New in version 1.6: - Removed use of Compress::Zlib because it was 30% slower, complicated the code, and because any user with gzip'd mail has zcat... New in version 1.5: - Andrew Johnson fixed a couple of bugs. New in version 1.4: - Incorporated conditional loading of the date module (submitted by Andrew Johnson Many thanks!). - compress::Zlib used instead of shelling out to gunzip (submitted by Andrew Johnson Many thanks!). - Some bug fixes (submitted by Andrew Johnson Many thanks!). - Also restructured the code a bit. New in version 1.3: - Made it pipeable so you can do: grepmail file | grepmail New in version 1.2: - Restructured the code a bit. New in version 1.1: - Support for dates. New in version 1.0: - Initial version, with -v -i, and gzip support grepmail-5.3033/grepmail0000755000076500001200000021701710571625711014315 0ustar coppitadmin#!/usr/bin/perl -w # grepmail $VERSION = sprintf "%d.%02d%02d", q/5.30.33/ =~ /(\d+)/g; # Grepmail searches a normal, gzip'd, or bzip2'd mailbox for a given regular # expression and returns those emails that match the query. It also supports # piped compressed or ascii input, and searches constrained by date and size. # Visit the grepmail project homepage at http://grepmail.sourceforge.net/ # There you can join the announcements mailing list to be notified of updates, # grab the development environment via CVS, participate in chats and mailing # lists, report bugs, submit patches, etc. # Do a pod2text on this file to get full documentation, or pod2man to get # man pages. # Written by David Coppit (david@coppit.org, http://coppit.org/) with lots of # debugging and patching by others -- see the CHANGES file for a complete # list. # This code is distributed under the GNU General Public License (GPL). See # http://www.opensource.org/gpl-license.html and http://www.opensource.org/. require 5.00396; use vars qw( %opts $commandLine $VERSION %message_ids_seen $USE_CACHING $USE_GREP ); use Getopt::Std; use strict; use Mail::Mbox::MessageParser; use FileHandle; use Carp; # Set to 1 to enable caching capability $USE_CACHING = 1; # Set to 0 to disable use of external grep utility $USE_GREP = 1; # Internal function return values. my $PRINT = 0; my $DONE = 1; my $SKIP = 2; my $CONTINUE = 3; my $NONE = 4; my $BEFORE = 5; my $AFTER = 6; my $NODATE = 8; my $BETWEEN = 9; my $LESS_THAN = 10; my $LESS_THAN_OR_EQUAL = 11; my $GREATER_THAN = 12; my $GREATER_THAN_OR_EQUAL = 13; my $EQUAL = 14; my $NO_PATTERN = '\127\235NO PATTERN\725\125'; my %HEADER_PATTERNS = ( '^TO:' => '(^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To):)', '^FROM_DAEMON:' => '(^(Mailing-List:|Precedence:.*(junk|bulk|list)|To: Multiple recipients of |(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma?(st(e?r)?|n)|office)|(send)?Mail(er)?|daemon|m(mdf|ajordomo)|n?uucp|LIST(SERV|proc)|NETSERV|o(wner|ps)|r(e(quest|sponse)|oot)|b(ounce|bs\.smtp)|echo|mirror|s(erv(ices?|er)|mtp(error)?|ystem)|A(dmin(istrator)?|MMGR|utoanswer))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t ][^<)]*(\(.*\).*)?)?))', '^FROM_MAILER:' => '(^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From)([^>]*[^(.%@a-z0-9])?(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t][^<)]*(\(.*\).*)?)?$([^>]|$))', ); #------------------------------------------------------------------------------- # Outputs debug messages with the -D flag. Be sure to return 1 so code like # 'dprint "blah\n" and exit' works. sub dprint { return 1 unless $opts{'D'}; my $message = join '',@_; foreach my $line (split /\n/, $message) { warn "DEBUG: $line\n"; } return 1; } #------------------------------------------------------------------------------- # Print a nice error message before exiting sub Report_And_Exit { my $message = shift; $message .= "\n" unless $message =~ /\n$/; warn "grepmail: $message"; exit 1; } #------------------------------------------------------------------------------- # Filter signals to print error messages when CTRL-C is caught, a pipe is # empty, a pipe is killed, etc. my %signals_and_messages = ( 'PIPE' => 'Broken Pipe', 'HUP' => 'Hangup', 'INT' => 'Canceled', 'QUIT' => 'Quit', 'SEGV' => 'Segmentation violation', 'TERM' => 'Terminated', ); # We'll store a copy of the original signal handlers and call them when we're # done. This helps when running under the debugger. my %old_SIG = %SIG; sub Signal_Handler { my $signal = $_[0]; $old_SIG{$signal}->(@_) if $old_SIG{$signal}; Report_And_Exit($signals_and_messages{$signal}); } # Delete the HUP signal for Windows, where it doesn't exist delete $signals_and_messages{HUP} if $^O eq 'MSWin32'; # We have to localize %SIG to prevent odd bugs from cropping up (see # changelog). Using an array slice on %SIG, I assign an array consisting of as # many copies of \&Signal_Handler as there are keys in %signals_and_messages. local @SIG{keys %signals_and_messages} = (\&Signal_Handler) x keys %signals_and_messages; ################################ MAIN PROGRAM ################################# binmode STDOUT; binmode STDERR; my ($dateRestriction, $date1, $date2); my ($sizeRestriction, $size1, $size2); { # PROCESS ARGUMENTS my (@remaining_arguments,$pattern); { my ($opts_ref,$remaining_arguments_ref); ($opts_ref,$remaining_arguments_ref,$pattern) = Get_Options(@ARGV); %opts = %$opts_ref; @remaining_arguments = @$remaining_arguments_ref; } # Initialize seen messages data structure to empty. %message_ids_seen = (); # Save the command line for later when we try to decompress standard input { # Need to quote arguments with spaces my @args = @ARGV; grep { $_ = "'$_'" if index($_, ' ') != -1; $_ } @args; $commandLine = "$0 @args"; } Print_Debug_Information($commandLine); sub Process_Date($); sub Process_Size($); sub Get_Files(@); # Make the pattern insensitive if we need to $pattern = "(?i)$pattern" if ($opts{'i'}) && $pattern ne $NO_PATTERN; # Make the pattern match word boundaries if we need to $pattern = "\\b$pattern\\b" if ($opts{'w'}) && $pattern ne $NO_PATTERN; if (defined $opts{'d'}) { ($dateRestriction,$date1,$date2) = Process_Date($opts{'d'}); } else { $dateRestriction = $NONE; } if (defined $opts{'s'}) { ($sizeRestriction,$size1,$size2) = Process_Size($opts{'s'}); } else { $sizeRestriction = $NONE; } dprint "PATTERN: $pattern\n" unless $pattern eq $NO_PATTERN; dprint "PATTERN: \n" if $pattern eq $NO_PATTERN; dprint "FILES: @remaining_arguments\n"; dprint "DATE RESTRICTION: $dateRestriction\n"; dprint "FIRST DATE: $date1\n" unless $dateRestriction == $NONE; dprint "SECOND DATE: $date2\n" unless $dateRestriction == $NONE; dprint "SIZE RESTRICTION: $sizeRestriction\n"; dprint "FIRST SIZE: $size1\n" unless $sizeRestriction == $NONE; dprint "SECOND SIZE: $size2\n" unless $sizeRestriction == $NONE; Validate_Pattern($pattern); my @files = Get_Files(@remaining_arguments); # If the user provided input files... if (@files) { Handle_Input_Files(@files,$pattern); } # Using STDIN else { Handle_Standard_Input($pattern); } exit 0; } #------------------------------------------------------------------------------- sub Get_Options { local @ARGV = @_; my @argv = @ARGV; # Print usage error if no arguments given Report_And_Exit("No arguments given.\n\n" . usage()) unless @ARGV; # Check for --help, the standard usage command, or --version. print usage() and exit(0) if grep { /^--help$/ } @ARGV; print "$VERSION\n" and exit(0) if grep { /^--version$/ } @ARGV; my @valid_options = qw( a b B C d D e E f F i j h H l L M m n q r R s S t T u v V w X Y Z ); my %opts; my $pattern; # Initialize all options to zero. map { $opts{$_} = 0; } @valid_options; # And some to non-zero. $opts{'d'} = $opts{'V'} = undef; $opts{'X'} = '^-- $'; $opts{'C'} = undef; # Ensure valid options. ALSO UPDATE 2ND GETOPT CALL BELOW getopt("CdeEfjsXY",\%opts); # Here we have to deal with the possibility that the user specified the # search pattern without the -e flag. # getopts stops as soon as it sees a non-flag, so $ARGV[0] may contain the # pattern with more flags after it. unless ($opts{'e'} || $opts{'E'} || $opts{'f'}) { my $missing_flags = ''; foreach my $flag (keys %opts) { $missing_flags .= $flag unless $opts{$flag}; } $missing_flags = "[$missing_flags]"; # If it looks like more flags are following, then grab the pattern and # process them. unless (defined $argv[-($#ARGV+2)] && $argv[-($#ARGV+2)] eq '--') { if ( $#ARGV > 0 && $ARGV[1] =~ /^-$missing_flags$/) { $pattern = shift @ARGV; getopt("CdfjsXY",\%opts); } # If we've seen a -d, -j, -s, or -u flag, and it doesn't look like there # are flags following $ARGV[0], then look at the value in $ARGV[0] elsif ( ( defined $opts{'d'} || $opts{'j'} || $opts{'s'} || $opts{'u'} ) && ( $#ARGV <= 0 || ( $#ARGV > 0 && $ARGV[1] !~ /^-$missing_flags$/ ) ) ) { # If $ARGV[0] looks like a file we assume there was no pattern and # set a default pattern of "." to match everything. if ($#ARGV != -1 && -f Search_Mailbox_Directories($ARGV[0])) { $pattern = '.'; } # Otherwise we take the pattern and move on else { $pattern = shift @ARGV; } } # If we still don't have a pattern or any -d, -j, -s, or -u flag, we # assume that $ARGV[0] is the pattern elsif (!defined $opts{'d'} && !$opts{'j'} && !$opts{'s'} && !$opts{'u'}) { $pattern = shift @ARGV; } } } if ($opts{'e'} || $opts{'E'} || $opts{'f'}) { Report_And_Exit("You specified two search patterns, or a pattern and a pattern file.\n") if defined $pattern; if ($opts{'e'}) { $pattern = $opts{'e'}; } elsif ($opts{'E'}) { $pattern = $opts{'E'}; } else { open PATTERN_FILE, $opts{'f'} or Report_And_Exit("Can't open pattern file $opts{'f'}"); $pattern = '('; my $first = 1; while (my $line = ) { if ($first) { $first = 0; } else { $pattern .= '|'; } chomp $line; $pattern .= $line; } close PATTERN_FILE; $pattern .= ')'; } } elsif (defined $opts{'V'}) { # Print version and exit if we need to print "$VERSION\n"; exit (0); } elsif (!defined $pattern) { # The only times you don't have to specify the pattern is when -d, -j, -s, or -u # is being used. This should catch people who do "grepmail -h" thinking # it's help. Report_And_Exit("Invalid arguments.\n\n" . usage()) unless defined $opts{'d'} || $opts{'j'} || $opts{'s'} || $opts{'u'}; $pattern = '.'; } if (defined $opts{'d'}) { if (eval 'require Date::Parse;') { import Date::Parse; } else { Report_And_Exit('You specified -d, but do not have Date::Parse. ' . "Get it from CPAN.\n"); } if (eval 'require Time::Local;') { import Time::Local; } else { Report_And_Exit('You specified -d, but do not have Time::Local. ' . "Get it from CPAN.\n"); } if (eval 'require Date::Manip') { my ($version_number) = $Date::Manip::VERSION =~ /^(\d+\.\d+)/; Date::Manip::Date_Init("TodayIsMidnight=1") if $version_number >= 5.43; } } $opts{'h'} = 1 if $opts{'Y'}; # Make sure no unknown flags were given foreach my $option (keys %opts) { unless (grep {/^$option$/} @valid_options) { Report_And_Exit("Invalid option \"$option\".\n\n" . usage()); } } # Check for -E flag incompatibilities. if ($opts{'E'}) { # Have to do -Y before -h because the former implies the latter my @options = qw(e f M S Y); for my $option (@options) { if ($opts{$option}) { Report_And_Exit "-$option can not be used with -E"; } } if ($opts{'i'}) { Report_And_Exit "-i can not be used with -E. Use -E '\$email =~ /pattern/i' instead"; } if ($opts{'b'}) { Report_And_Exit "-b can not be used with -E. Use -E '\$email_body =~ /pattern/' instead"; } if ($opts{'h'}) { Report_And_Exit "-h can not be used with -E. Use -E '\$email_header =~ /pattern/' instead"; } } # Check for -f flag incompatibilities. if ($opts{'f'}) { # Have to do -Y before -h because the former implies the latter my @options = qw(E e); for my $option (@options) { if ($opts{$option}) { Report_And_Exit "-$option can not be used with -E"; } } } unless (defined $opts{'C'}) { if(defined $ENV{'HOME'}) { $opts{'C'} = "$ENV{'HOME'}/.grepmail-cache"; } elsif ($USE_CACHING) { # No cache file, so disable caching $USE_CACHING = 0; warn "grepmail: No cache file specified, and \$HOME not set. " . "Disabling cache.\n" unless $opts{'q'}; } } $opts{'R'} = 1 if $opts{'L'}; $pattern = $NO_PATTERN if $pattern eq '()'; return (\%opts, \@ARGV, $pattern); } #------------------------------------------------------------------------------- sub Print_Debug_Information { my $commandLine = shift; return unless $opts{'D'}; dprint "Version: $VERSION"; dprint "Command line was (special characters not escaped):"; dprint " $commandLine"; if (defined $Date::Parse::VERSION) { dprint "Date::Parse VERSION: $Date::Parse::VERSION"; } dprint "Options are:"; foreach my $i (sort keys %opts) { if (defined $opts{$i}) { dprint " $i: $opts{$i}"; } else { dprint " $i: undef"; } } dprint "INC is:"; foreach my $i (@INC) { dprint " $i"; } } #------------------------------------------------------------------------------- # Dies if the given pattern's syntax is invalid sub Validate_Pattern { my $pattern = shift; local $@; if ($opts{'E'}) { eval {if ($pattern) {}}; Report_And_Exit "The match condition \"$pattern\" is invalid.\n" if $@; } elsif ($pattern ne $NO_PATTERN) { eval {'string' =~ /$pattern/}; Report_And_Exit "The pattern \"$pattern\" is invalid.\n" if $@; } } #------------------------------------------------------------------------------- # Get a list of files, taking recursion into account if necessary. sub Get_Files(@) { my @files_and_directories = @_; # We just return what we were given unless we need to recurse subdirectories. return @files_and_directories unless $opts{'R'}; my @files; foreach my $arg (@files_and_directories) { if (-f $arg) { push @files, $arg; } elsif( -d $arg || -l $arg && $opts{'L'} ) { dprint "Recursing directory $arg looking for files..." if -d $arg; dprint "Following symbolic link $arg looking for files..." if -l $arg; unless (eval "require File::Find;") { Report_And_Exit("You specified -R or -L, but do not have File::Find. " . "Get it from CPAN.\n"); } import File::Find; # Gets all plain files in directory and descendents. Puts them in @files $File::Find::name = ''; if ($opts{'L'}) { find( { wanted => sub {push @files,"$File::Find::name" if -f $_}, follow => 1 }, $arg); } else { find(sub {push @files,"$File::Find::name" if -f $_}, $arg); } } else { # Ignore unknown file types } } return @files; } #------------------------------------------------------------------------------- sub Handle_Input_Files { my $pattern = pop @_; my @files = @_; # For each input file... foreach my $file (@files) { dprint '#'x70; dprint "Processing file $file"; # First of all, silently ignore empty files... next if -z $file; # ...and also ignore directories. if (-d $file) { warn "grepmail: Skipping directory: '$file'\n" unless $opts{'q'}; next; } $file = Search_Mailbox_Directories($file) unless -f $file; Process_Mail_File(undef,$file,$#files+1,$pattern); } } #------------------------------------------------------------------------------- sub Search_Mailbox_Directories { my $file = shift; my @maildirs; push @maildirs, $ENV{'MAILDIR'} if defined $ENV{'MAILDIR'} && -d $ENV{'MAILDIR'}; push @maildirs, "$ENV{HOME}/mail" if defined $ENV{'HOME'} && -d "$ENV{HOME}/mail"; push @maildirs, "$ENV{HOME}/Mail" if defined $ENV{'HOME'} && -d "$ENV{HOME}/Mail"; push @maildirs, "$ENV{HOME}/Mailbox" if defined $ENV{'HOME'} && -d "$ENV{HOME}/Mailbox"; foreach my $mail_folder (@maildirs) { my $path_and_file = "$mail_folder/$file"; return $path_and_file if -e $path_and_file; } return $file; } #------------------------------------------------------------------------------- sub Handle_Standard_Input { my $pattern = shift; dprint "Handling STDIN"; # We have to implement our own -B and -s, because STDIN gets eaten by them binmode STDIN; my $fileHandle = new FileHandle; $fileHandle->open('-'); Process_Mail_File($fileHandle,undef,1,$pattern); } #------------------------------------------------------------------------------- # This algorithm is complicated by code to short-circuit some # computations. For example, if the user specified -h but not -b, when # we can analyze the header for a match and avoid needing to search # the body, which may be much larger. sub Do_Simple_Pattern_Matching { my $email_header = shift; my $email_body = shift; my $fileHandle = shift; my $fileName = shift; my $number_files = shift; my $numberOfMatches = shift; my $line = shift; my $endline = shift; my $pattern = shift; die unless ref $email_header && ref $email_body; return ($CONTINUE,$numberOfMatches) if $pattern eq $NO_PATTERN; dprint "Checking for early match or abort based on header information." if $opts{'D'}; my ($result,$matchesHeader) = Analyze_Header($email_header,$email_body,$fileHandle,$pattern,1,$endline); if ($result == $SKIP) { dprint "Doing an early abort based on header." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } if ($result == $PRINT) { dprint "Doing an early printout based on header." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- my $matchesBody = 0; my $signature_offset = undef; if ($opts{'S'}) { my $signature_pattern = $opts{'X'}; $signature_pattern =~ s#\$#$/#; if ($$email_body =~ m/($signature_pattern)/mg) { $signature_offset = pos($$email_body) - length($1); pos($$email_body) = 0; dprint "Signature offset: $signature_offset"; } } # Ignore the MIME attachments if -M was specified if ($opts{'M'} && ($$email_header =~ /^Content-Type:.*?boundary=(?:"([^"]*)"|([^\r\n]*))/ism)) { my $boundary; $boundary = $1 if defined $1; $boundary = $2 if defined $2; dprint "Found attachments with boundary:\n $boundary" if $opts{'D'}; my @attachment_positions; # Get each of the binary attachment beginnings and endings. while ($$email_body =~ m/\n((?:--)?\Q$boundary\E(?:--)?$endline(?:(.*?)$endline$endline)?)/sg) { my $position = pos($$email_body) - length($1); my $header = $2; # Remember that the beginning of the next attachment is the # end of the previous. $attachment_positions[-1]{'end'} = $position if @attachment_positions; # If it's the beginning of a binary attachment, store the position if (defined $header && $header =~ /^Content-Type:\s+(?!text)/i) { $attachment_positions[$#attachment_positions+1]{'beginning'} = $position; } } pos($$email_body) = 0; # Now search the body, ignoring any matches in binary # attachments. # Avoid perl 5.6 bug which causes spurious warning even though # $pattern is defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; SEARCH: while ($$email_body =~ m/($pattern)/omg) { my $position = pos($$email_body) - length($1); last SEARCH if $opts{'S'} && defined $signature_offset && $position > $signature_offset; foreach my $attachment (@attachment_positions) { next SEARCH if ($position > $attachment->{'beginning'} && $position < $attachment->{'end'}); } $matchesBody = 1; last; } pos($$email_body) = 0; } else { # Avoid perl 5.6 bug which causes spurious warning even though # $pattern is defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; pos($$email_body) = 0; if ($$email_body =~ m/($pattern)/omg) { my $position = pos($$email_body) - length($1); $matchesBody = 1 unless $opts{'S'} && defined $signature_offset && $position > $signature_offset; } pos($$email_body) = 0; } #---------------------------------------------------------------- my $matchesSize = Is_In_Size($email_header,$email_body,$sizeRestriction,$size1,$size2); #---------------------------------------------------------------- dprint "Checking for early match or abort based on header, body, " . "and size information." if $opts{'D'}; my $isMatch = 1; $isMatch = 0 if $opts{'s'} && !$matchesSize || $opts{'b'} && !$matchesBody || $opts{'h'} && !$matchesHeader || !$opts{'b'} && !$opts{'h'} && !($matchesBody || $matchesHeader); if (!$isMatch && !$opts{'v'}) { dprint "Doing an early abort based on header, body, and size." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } elsif (!$isMatch && $opts{'v'}) { dprint "Doing an early printout based on header, body, and size." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- dprint "Checking date constraint." if $opts{'D'}; $isMatch = 1; { my $matchesDate = Email_Matches_Date($email_header,$endline); $isMatch = 0 if defined $opts{'d'} && !$matchesDate; dprint "Email matches date constraint\n" if $opts{'D'} && defined $opts{'d'} && $matchesDate; dprint "Email doesn't match date constraint\n" if $opts{'D'} && defined $opts{'d'} && !$matchesDate; } $isMatch = !$isMatch if $opts{'v'}; # If the match occurred in the right place... if ($isMatch) { dprint "Email matches all patterns and constraints." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; } } else { dprint "Email did not match all patterns and constraints." if $opts{'D'}; } return ($CONTINUE,$numberOfMatches); } #------------------------------------------------------------------------------- # This algorithm is complicated by code to short-circuit some # computations. For example, if the user specified -h but not -b, when # we can analyze the header for a match and avoid needing to search # the body, which may be much larger. sub Do_Complex_Pattern_Matching { my $email_header = shift; my $email_body = shift; my $fileHandle = shift; my $fileName = shift; my $number_files = shift; my $numberOfMatches = shift; my $line = shift; my $endline = shift; my $pattern = shift; die unless ref $email_header && ref $email_body; return ($CONTINUE,$numberOfMatches) if $pattern eq $NO_PATTERN; dprint "Checking for early match or abort based on header information." if $opts{'D'}; my ($result,$matchesHeader) = Analyze_Header($email_header,$email_body,$fileHandle,$pattern,0,$endline); if ($result == $SKIP) { dprint "Doing an early abort based on header." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } if ($result == $PRINT) { dprint "Doing an early printout based on header." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- my $modified_pattern = $pattern; $modified_pattern =~ s/\$email_header\b/\$\$email_header/g; $modified_pattern =~ s/\$email_body\b/\$\$email_body/g; $modified_pattern =~ s#(=~\s*)/([^/]*)/#$1/$2/om#g; my $matchesEmail; if ($modified_pattern =~ /\$email\b/) { my $header_pattern = $modified_pattern; $header_pattern =~ s/\$email\b/\$\$email_header/g; eval " \$matchesEmail = $header_pattern ? 1 : 0 "; unless ($matchesEmail) { my $body_pattern = $modified_pattern; $body_pattern =~ s/\$email\b/\$\$email_body/g; eval " \$matchesEmail = $body_pattern ? 1 : 0 "; } } else { eval " \$matchesEmail = $modified_pattern ? 1 : 0 "; } #---------------------------------------------------------------- my $isMatch = 1; $isMatch = 0 unless $matchesEmail; if (!$isMatch && !$opts{'v'}) { dprint "Doing an early abort based on header, body, and size." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } elsif (!$isMatch && $opts{'v'}) { dprint "Doing an early printout based on header, body, and size."; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- dprint "Checking date constraint." if $opts{'D'}; $isMatch = 1; { my $matchesDate = Email_Matches_Date($email_header,$endline); $isMatch = 0 if defined $opts{'d'} && !$matchesDate; dprint "Email matches date constraint\n" if $opts{'D'} && defined $opts{'d'} && $matchesDate; dprint "Email doesn't match date constraint\n" if $opts{'D'} && defined $opts{'d'} && !$matchesDate; } $isMatch = !$isMatch if $opts{'v'}; # If the match occurred in the right place... if ($isMatch) { dprint "Email matches all patterns and constraints." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; } } else { dprint "Email did not match all patterns and constraints." if $opts{'D'}; } return ($CONTINUE,$numberOfMatches); } #------------------------------------------------------------------------------- sub Process_Mail_File { my $fileHandle = shift @_; my $fileName = shift @_; my $number_files = shift @_; my $pattern = shift @_; my $setup_result = Mail::Mbox::MessageParser::SETUP_CACHE( { 'file_name' => $opts{'C'} } ) if $USE_CACHING; $USE_CACHING = 0 if $USE_CACHING && $setup_result ne 'ok'; my $folder_reader = new Mail::Mbox::MessageParser( { 'file_name' => $fileName, 'file_handle' => $fileHandle, 'enable_cache' => $USE_CACHING, 'enable_grep' => $USE_GREP, 'force_processing' => $opts{'F'}, 'debug' => $opts{'D'}, } ); unless (ref $folder_reader) { my $error = $folder_reader; # Catch fatal errors if ($error eq 'No data on filehandle') { Report_And_Exit('No data on standard input'); } elsif ($error eq 'Not a mailbox') { unless($opts{'q'}) { if (defined $fileName) { warn "grepmail: \"$fileName\" is not a mailbox, skipping\n" } else { warn "grepmail: Standard input is not a mailbox, skipping\n" } } return; } else { warn "grepmail: $error, skipping\n" unless $opts{'q'}; return; } } my $numberOfMatches = 0; my $endline = $folder_reader->endline(); local $/ = $endline; my $modified_pattern = $pattern; $modified_pattern =~ s#\$([^\w]|$)#$/$1#; # This is the main loop. It's executed once for each email while(!$folder_reader->end_of_file()) { dprint "Reading email" if $opts{'D'}; my $email = $folder_reader->read_next_email(); # Direct access for performance reasons #my $line = $folder_reader->line_number(); my $line = $folder_reader->{'email_line_number'}; my ($email_header,$email_body); { my $end_of_header; my $newlines_position = index($$email,"$endline$endline"); if ($newlines_position != -1) { $end_of_header = $newlines_position+length("$endline$endline"); } else { $end_of_header = length($$email); } $$email_header = substr($$email,0,$end_of_header); $email_body = $email; substr($$email_body,0,$end_of_header) = ''; } Print_Email_Statistics($email_header,$email_body,$endline) if $opts{'D'}; #---------------------------------------------------------------- if ($opts{'E'}) { my $result; ($result, $numberOfMatches) = Do_Complex_Pattern_Matching($email_header, $email_body, $fileHandle, $fileName, $number_files, $numberOfMatches, $line, $endline, $modified_pattern); return if $result == $DONE; } else { my $result; ($result, $numberOfMatches) = Do_Simple_Pattern_Matching($email_header, $email_body, $fileHandle, $fileName, $number_files, $numberOfMatches, $line, $endline, $modified_pattern); return if $result == $DONE; } } print Get_Filename($fileName).": $numberOfMatches\n" if $opts{'r'}; } #------------------------------------------------------------------------------- # Checks that an email is not a duplicate of one already printed. This should # only be called when $opts{'u'} is true. Also, as a side-effect, it updates # the %message_ids_seen when it sees an email that hasn't been printed yet. { my $tried_to_load_digest_md5; sub Not_A_Duplicate { my $email_header = shift; die unless ref $email_header; my ($message_id) = $$email_header =~ /^Message-Id:\s*<([^>]+)>/mi; if (defined $message_id) { dprint "Checking uniqueness of message id: $message_id"; } else { dprint "Email does not have a message id"; # Try to load Digest::MD5 if we haven't already unless (defined $tried_to_load_digest_md5) { $tried_to_load_digest_md5 = 1; if (eval "require Digest::MD5") { dprint "Digest::MD5 VERSION: $Digest::MD5::VERSION"; # To prevent warning about variable being used only once my $dummy = $Digest::MD5::VERSION; } else { dprint "Digest::MD5 could not be loaded"; } } # Now create a message id if (defined $Digest::MD5::VERSION) { $message_id = Digest::MD5::md5_hex($$email_header); dprint "Generated message id $message_id with Digest::MD5"; } else { $message_id = $$email_header; dprint "Using email header as message id."; } } my $result; if (exists $message_ids_seen{$message_id}) { $result = 0; dprint "Found duplicate message"; } else { $result = 1; dprint "Found non-duplicate message"; $message_ids_seen{$message_id} = 1; } return $result; } } #------------------------------------------------------------------------------- # - Returns header lines in the email header which match the given name. # - Example names: 'From:', 'Received:' or 'From ' # - If the calling context wants a list, a list of the matching header lines # are returned. Otherwise, the first (and perhaps only) match is returned. # - Wrapped lines are handled. Look for multiple \n's in the return value(s) # - 'From ' also looks for Gnus 'X-From-Line:' or 'X-Draft-From:' sub Get_Header_Field { my $email_header = shift; my $header_name = shift; my $endline = shift; die unless ref $email_header; # Avoid perl 5.6 bug which causes spurious warning even though $email_header # is defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; if ($header_name =~ /^From$/i && $$email_header =~ /^((?:From\s|X-From-Line:|X-Draft-From:).*$endline(\s.*$endline)*)/im) { return wantarray ? ($1) : $1; } my @matches = $$email_header =~ /^($header_name\s.*$endline(?:\s.*$endline)*)/igm; if (@matches) { return wantarray ? @matches : shift @matches; } if (lc $header_name eq 'from ' && $$email_header =~ /^(From\s.*$endline(\s.*$endline)*)/im) { return wantarray ? ($1) : $1; } return undef; } #------------------------------------------------------------------------------- # Print the email author and subject, given a reference to an email header. sub Print_Email_Statistics { my $email_header = shift; my $email_body = shift; my $endline = shift; die unless ref $email_header && ref $email_body; dprint '-'x70; dprint "Processing email:"; my $message_id = Get_Header_Field($email_header,'Message-Id:',$endline); if (defined $message_id) { dprint " $message_id"; } else { dprint " [No message id line found]"; } my $author = Get_Header_Field($email_header,'From:',$endline); $author = Get_Header_Field($email_header,'From ',$endline) unless defined $author; if (defined $author) { dprint " $author"; } else { dprint " [No from line found]"; } my $subject = Get_Header_Field($email_header,'Subject:',$endline); if (defined $subject) { dprint " $subject"; } else { dprint " [No subject line found]"; } my $date = Get_Header_Field($email_header,'Date:',$endline); if (defined $date) { dprint " $date"; } else { dprint " [No subject line found]"; } dprint " Size: " . (length($$email_header) + length($$email_body)); } #------------------------------------------------------------------------------- # Returns: # A result: # - $PRINT if the email is a match and we need to print it # - $SKIP if we should skip the current email and go on to the next one # - $CONTINUE if we need to keep processing the email. # A boolean for whether the header matches the pattern. # A boolean for whether the header has the correct date. # It turns out that -h, -b, -d, -s , -j, and -v have some nasty feature # interaction. The easy cases are when a constraint is not met--either we skip # if -v is not specified, or we print if -v is specified. # # If a constraint *is* met, we can still do an early abort of there are no other # constraints, or if we know the values of previously checked constraints. # # Finally, -b must be taken into account when analyzing -h matching. Also, we # don't analyze the date here because it is too darn slow. sub Analyze_Header { my $email_header = shift; my $email_body = shift; my $fileHandle = shift; my $pattern = shift; my $doHeaderMatch = shift; my $endline = shift; die unless ref $email_header && ref $email_body; # See if the email fails the status flag restriction my $matchesStatus = 1; if ($opts{'j'}) { foreach my $flag (split //,$opts{'j'}) { $matchesStatus = 0 unless $$email_header =~ /^Status: .*(?i:$flag)/m; } # Easy cases return ($SKIP,0) if !$opts{'v'} && !$matchesStatus; return ($PRINT,1) if $opts{'v'} && !$matchesStatus; # If we know there are no other constraints return ($PRINT,1) if !$opts{'v'} && $matchesStatus && !$opts{'s'} && !defined $opts{'d'} && $pattern eq '.'; return ($SKIP,0) if $opts{'v'} && $matchesStatus && !$opts{'s'} && !defined $opts{'d'} && $pattern eq '.'; } # See if the email header fails the size restriction. my $matchesSize = 1; if ($opts{'s'}) { $matchesSize = 0 if !Is_In_Size($email_header,$email_body,$sizeRestriction,$size1,$size2); # Easy cases return ($SKIP,0) if !$opts{'v'} && !$matchesSize; return ($PRINT,1) if $opts{'v'} && !$matchesSize; # If we know there are no other constraints, or we know their values return ($PRINT,1) if !$opts{'v'} && $matchesSize && $matchesStatus && !defined $opts{'d'} && $pattern eq '.'; return ($SKIP,0) if $opts{'v'} && $matchesSize && $matchesStatus && !defined $opts{'d'} && $pattern eq '.'; } if ($doHeaderMatch) { # See if the header matches the pattern # Avoid perl 5.6 bug which causes spurious warning even though $pattern is # defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; my $matchesHeader = Header_Matches_Pattern($email_header,$pattern,$endline); if ($opts{'h'}) { # Easy cases return ($SKIP,0) if !$opts{'v'} && !$matchesHeader; return ($PRINT,1) if $opts{'v'} && !$matchesHeader; } # If we know there are no other constraints, or we know their values return ($PRINT,1) if !$opts{'v'} && $matchesHeader && $matchesSize && $matchesStatus && !defined $opts{'d'} && !$opts{'b'}; return ($SKIP,0) if $opts{'v'} && $matchesHeader && $matchesSize && $matchesStatus && !defined $opts{'d'} && !$opts{'b'}; return ($CONTINUE,$matchesHeader); } else { return ($CONTINUE,1); } } #------------------------------------------------------------------------------- my $header_pattern = undef; sub Header_Matches_Pattern { my $email_header = ${shift @_}; my $pattern = shift; my $endline = shift; return ($email_header =~ /$pattern/om) || 0 unless $opts{'Y'}; dprint "Searching individual headers."; $email_header =~ s/\n(\s+)/$1/g; unless (defined $header_pattern) { $header_pattern = $opts{'Y'}; for my $special_header_pattern (keys %HEADER_PATTERNS) { $header_pattern =~ s/\Q$special_header_pattern\E/$HEADER_PATTERNS{$special_header_pattern}/g; } # Make the pattern insensitive if we need to $header_pattern = "(?i)$header_pattern" if ($opts{'i'}); } for my $header (split(/$endline/, $email_header)) { if ($header =~ /$header_pattern/) { dprint "Header matched header pattern:\n $header\n"; return 1 if $header =~ /$pattern/om; } } return 0; } #------------------------------------------------------------------------------- sub Convert_Email_To_Mbox_And_Print_It { my $fileName = shift; my $email_header = shift; my $email_body = shift; my $number_files = shift; my $line_number = shift; my $endline = shift; ($email_header,$email_body) = Convert_Email_To_Mbox($email_header,$email_body); Print_Email($fileName,$email_header,$email_body,$number_files,$line_number, $endline); } #------------------------------------------------------------------------------- sub Convert_Email_To_Mbox { my $email_header = shift; my $email_body = shift; dprint "Making email mbox format."; # Check for a Gnus email $$email_header =~ s/^(X-From-Line|X-Draft-From):\s+/From /; return ($email_header,$email_body); } #------------------------------------------------------------------------------- sub Get_Filename { my $fileName = shift; if (defined $fileName) { return "$fileName"; } else { return "(standard input)"; } } #------------------------------------------------------------------------------- sub Print_Email { my $fileName = shift; my $email_header = shift; my $email_body = shift; my $number_files = shift; my $line_number = shift; my $endline = shift; dprint "Printing email."; if ($opts{'n'}) { # Print header-by-header my @headers = $$email_header =~ /^(.*$endline(?:\s.*$endline)*)/gm; foreach my $header (@headers) { # Add the mailfolder to the headers if -m was given. Careful # about line numbers! if ($opts{'m'} && $header eq $endline) { print Get_Filename($fileName).":" if $number_files > 1; print " " x length $line_number, ":X-Mailfolder: ", Get_Filename($fileName), $endline; } # Print only 3-line header if -B if ($opts{'B'} && $header !~ /^(From\s|X-From-Line:|X-Draft-From:|From:|Date:|Subject:|$endline)/i) { $line_number += ($header =~ tr/\n//); } else { my $prefix = ''; $prefix = Get_Filename($fileName).":" if $number_files > 1; $header =~ s/^/$line_number++;$prefix . ($line_number-1) . ':'/mge; print $header; } } # Don't print the body if -H is specified if($opts{'H'}) { $line_number += ($$email_body =~ tr/\n//); return; } while ($$email_body =~ /([^\r\n]*$endline)/g) { my $line = $1; print Get_Filename($fileName).":" if $number_files > 1; print "$line_number:$line"; $line_number++; } } else { # print short headers if -B is specified if ($opts{'B'}) { print Get_Header_Field($email_header,'From ',$endline); print Get_Header_Field($email_header,'Date:',$endline); print Get_Header_Field($email_header,'From:',$endline); print Get_Header_Field($email_header,'Subject:',$endline); print "X-Mailfolder: ".Get_Filename($fileName)."$endline$endline" if $opts{'m'}; } else { chomp $$email_header; print $$email_header; print "X-Mailfolder: ".Get_Filename($fileName).$endline if $opts{'m'}; print $endline; $$email_header .= $endline; } # Don't print the body if -H is specified return if $opts{'H'}; # Print whatever body we've read already. print $$email_body; } } #------------------------------------------------------------------------------- # Checks to see if the date in the header matches the date specification. The # date specification can be $NODATE, meaning that the email doesn't have # a Date: line. sub Email_Matches_Date { my $email_header = shift @_; my $endline = shift; die unless ref $email_header; return 1 unless defined $opts{'d'}; return 0 if $dateRestriction == $NODATE; my $received_header = Get_Header_Field($email_header, 'Received:',$endline); my $date_header = Get_Header_Field($email_header, 'Date:',$endline); my $subject_header = Get_Header_Field($email_header, 'Subject:',$endline); my $from_header = Get_Header_Field($email_header, 'From ',$endline); # Collect different date header values. We'll try each one until # we find a value that parses. my @dateValues = (); push(@dateValues, $1) if $opts{'a'} && defined $received_header && $received_header =~ /.*\;\s*(.*?)$/s; push(@dateValues, $1) if defined $date_header && $date_header =~ /^[^:]*:\s*(.*)$/s; push(@dateValues, $1) if defined $from_header && $from_header =~ /^[^ ]*\s*\S+\s+(.*)$/s; unless (scalar(@dateValues) > 0) { warn "grepmail: Couldn't find a date. Assuming email doesn't match the " . "date constraint:\n"; warn " $from_header\n" if defined $from_header; warn " $subject_header\n" if defined $subject_header; return 0; } foreach my $date (@dateValues) { $date =~ s/$endline//g; } my $emailDate = undef; foreach my $date (@dateValues) { dprint("Trying to parse date: $date"); $emailDate = str2time($date); last if defined($emailDate); } return Is_In_Date($emailDate,$dateRestriction,$date1,$date2) if defined $emailDate; warn "grepmail: Couldn't parse email date(s) [" . join("|", @dateValues) . "]. " . "Assuming message doesn't match the date constraint\n"; warn " $from_header\n" if defined $from_header; warn " $subject_header\n" if defined $subject_header; return 0; } #------------------------------------------------------------------------------- # This function tries to parse a date first with Date::Parse. If Date::Parse # can't parse the date, then the function tries to use Date::Manip to parse # it. Returns the parsed date in unix time format, or undef if it can't be # parsed. sub Parse_Date { my $date = shift; # First try to parse the date with Date::Parse; { my $parsedDate = str2time($date); return $parsedDate if defined $parsedDate; } # Then try Date::Manip, if it is installed if (defined $Date::Manip::VERSION) { my $parsedDate = Date::Manip::UnixDate(Date::Manip::ParseDate($date),'%s'); return $parsedDate if defined $parsedDate; } return undef; } #------------------------------------------------------------------------------- # Figure out what kind of date restriction they want, and what the dates in # question are. An empty date string results in the type of date restriction # being $NODATE. sub Process_Date($) { my $datestring = shift; return ($NODATE,'','') if $datestring eq ''; if ($datestring =~ /^before (.*)/i) { $dateRestriction = $BEFORE; $date1 = Parse_Date($1); $date2 = ''; Report_And_Exit "\"$1\" is not a valid date" unless defined $date1; } elsif ($datestring =~ /^(after|since)\s(.*)/i) { $dateRestriction = $AFTER; $date1 = Parse_Date($2); Report_And_Exit "\"$2\" is not a valid date" unless defined $date1; $date2 = ''; } elsif ($datestring =~ /^between (.+) and (.+)/i) { $dateRestriction = $BETWEEN; $date1 = Parse_Date($1); $date2 = Parse_Date($2); Report_And_Exit "\"$1\" is not a valid date" unless defined $date1; Report_And_Exit "\"$2\" is not a valid date" unless defined $date2; # Swap the dates if the user gave them backwards. if ($date1 > $date2) { my $temp; $temp = $date1; $date1 = $date2; $date2 = $temp; } } else { $dateRestriction = $BETWEEN; ($date1,$date2) = Parse_Date_Span($datestring); Report_And_Exit "\"$datestring\" is an invalid date specification. Use \"$0 --help\" for help" unless defined $date1; } return ($dateRestriction,$date1,$date2); } #------------------------------------------------------------------------------- sub Parse_Date_Span { my $datestring = shift; # @parsed_time == ($ss,$mm,$hh,$day,$month,$year,$zone) my @parsed_time = Date_Parse_strptime($datestring); @parsed_time = Date_Manip_strptime($datestring) if !@parsed_time && defined $Date::Manip::VERSION; # For "jan 2004" if (defined $parsed_time[3] && $parsed_time[3] > 31 && !defined $parsed_time[5]) { $parsed_time[5] = $parsed_time[3] - 1900; $parsed_time[3] = undef; } return (undef,undef) unless grep { defined } @parsed_time; # @current_time == ($ss,$mm,$hh,$day,$month,$year,$zone) my @current_time = ((localtime(time))[0..5],$parsed_time[-1]); # Starting from the largest time unit, set it to the current value as long # as it's undefined. for (my $i = -1; !defined($parsed_time[$i]); $i--) { $parsed_time[$i] = $current_time[$i]; } my @date1 = @parsed_time; my $increment_unit = 1; # Set the low date and the increment unit. Starting from the smallest time # unit, set it to the smallest value as long as it's undefined. unless (defined $date1[0]) { $date1[0] = 0; $increment_unit *= 60; unless (defined $date1[1]) { $date1[1] = 0; $increment_unit *= 60; unless (defined $date1[2]) { $date1[2] = 0; $increment_unit *= 24; unless (defined $date1[3]) { $date1[3] = 1; if (defined $date1[4]) { $increment_unit *= Number_Of_Days_In_Month($date1[4],$date1[5]); } else { $date1[4] = 0; $increment_unit *= Number_Of_Days_In_Year($date1[5]); } } } } } my $date1 = timelocal(@date1); my $date2 = timelocal(@date1)+$increment_unit; return ($date1,$date2); } #------------------------------------------------------------------------------- # http://groups.google.com/groups?selm=8FA9D001darkononenet%40206.112.192.118 # $month: 0..11; $year: CCYY sub Number_Of_Days_In_Month { my ($month, $year) = @_; ( qw(31 0 31 30 31 30 31 31 30 31 30 31) )[$month] || 28 + (($year % 100 && !($year % 4))|| !($year % 400)); } #------------------------------------------------------------------------------- sub Number_Of_Days_In_Year { my $year = @_; 365 + (($year % 100 && !($year % 4))|| !($year % 400)); } #------------------------------------------------------------------------------- sub Date_Parse_strptime { my $datestring = shift; my @parsed_time = strptime($datestring); return () unless @parsed_time; if (defined $parsed_time[3] && $parsed_time[3] > 31 && !defined $parsed_time[5]) { $parsed_time[5] = $parsed_time[3] - 1900; $parsed_time[3] = undef; } # @current_time == ($ss,$mm,$hh,$day,$month,$year,$zone) my @current_time = ((localtime(time))[0..5],$parsed_time[-1]); # Starting from the largest time unit, set it to the current value as long # as it's undefined. for (my $i = -1; !defined($parsed_time[$i]); $i--) { $parsed_time[$i] = $current_time[$i]; } foreach my $item (@parsed_time) { next unless defined $item; $item =~ s/^0+//; $item = 0 if $item eq ''; $item += 0 if $item =~ /^\d+$/; } return @parsed_time; } #------------------------------------------------------------------------------- sub Date_Manip_strptime { my $datestring = shift; my @parsed_time = Date::Manip::UnixDate(Date::Manip::ParseDate($datestring), '%S','%M','%H','%d','%m','%Y','%Z'); return () unless @parsed_time; { my $old_tz = $Date::Manip::Cnf{"TZ"}; my $parsed_time = Date::Manip::ParseDate($datestring); $Date::Manip::Cnf{"TZ"} = 'CST'; my $tz_test_1 = Date::Manip::ParseDate($datestring); $Date::Manip::Cnf{"TZ"} = 'EST'; my $tz_test_2 = Date::Manip::ParseDate($datestring); # Different lines so that CVS doesn't insert the date $Date::Manip::Cnf{"TZ"} = $old_tz; if ($parsed_time eq $tz_test_1 && $parsed_time eq $tz_test_2) { $parsed_time[-1] = undef; } } foreach my $item (@parsed_time) { next unless defined $item; $item =~ s/^0+//; $item = 0 if $item eq ''; $item += 0 if $item =~ /^\d+$/; } $parsed_time[4] -= 1 if defined $parsed_time[4]; $parsed_time[5] -= 1900 if defined $parsed_time[5]; # This is not quite correct, because we can't tell when Date::Manip sets the # time to 0 and when the user specifies it explicitely at 0:00:00. if ($parsed_time[0] == 0 && $parsed_time[1] == 0 && $parsed_time[2] == 0) { $parsed_time[0] = $parsed_time[1] = $parsed_time[2] = undef; } #Until 'Date::Manip::Date_Init("TodayIsMidnight=1");' is released if ($datestring eq 'today' || $datestring eq 'now' || $datestring eq 'yesterday') { $parsed_time[0] = $parsed_time[1] = $parsed_time[2] = undef; } return @parsed_time; } #------------------------------------------------------------------------------- # Figure out what kind of size restriction they want, and what the sizes in # question are. sub Process_Size($) { my $sizestring = shift; if ($sizestring =~ /^\s*(<|<=|>|>=)\s*(\d+)\s*$/i) { if ($1 eq '<') { $sizeRestriction = $LESS_THAN; } elsif ($1 eq '<=') { $sizeRestriction = $LESS_THAN_OR_EQUAL; } elsif ($1 eq '>') { $sizeRestriction = $GREATER_THAN; } elsif ($1 eq '>=') { $sizeRestriction = $GREATER_THAN_OR_EQUAL; } $size1 = $2; $size2 = ''; } elsif ($sizestring =~ /^\s*(\d+)\s*-\s*(\d+)\s*$/i) { $sizeRestriction = $BETWEEN; $size1 = $1; $size2 = $2; # Swap the sizes if the user gave them backwards. if ($size1 > $size2) { my $temp; $temp = $size1; $size1 = $size2; $size2 = $temp; } } elsif ($sizestring =~ /^\s*(\d+)\s*$/i) { $sizeRestriction = $EQUAL; $size1 = $1; $size2 = ''; } else { Report_And_Exit "\"$sizestring\" is an invalid size specification. Use \"$0 --help\" for help"; } return ($sizeRestriction,$size1,$size2); } #------------------------------------------------------------------------------- sub Is_In_Date($$$$) { my $emailDate = shift @_; my $dateRestriction = shift @_; my $date1 = shift @_; my $date2 = shift @_; # Now we do the date checking. return 1 if $dateRestriction == $NONE; return $emailDate < $date1 if $dateRestriction == $BEFORE; return $emailDate > $date1 if $dateRestriction == $AFTER; return $emailDate > $date1 && $emailDate < $date2 if $dateRestriction == $BETWEEN; return 0; } #------------------------------------------------------------------------------- sub Is_In_Size { my $email_header = shift @_; my $email_body = shift @_; my $sizeRestriction = shift @_; my $size1 = shift @_; my $size2 = shift @_; die unless ref $email_header && ref $email_body; my $length = length($$email_header) + length($$email_body); # Now we do the size checking. return 1 if $sizeRestriction == $NONE; return $length < $size1 if $sizeRestriction == $LESS_THAN; return $length <= $size1 if $sizeRestriction == $LESS_THAN_OR_EQUAL; return $length > $size1 if $sizeRestriction == $GREATER_THAN; return $length >= $size1 if $sizeRestriction == $GREATER_THAN_OR_EQUAL; return $length == $size1 if $sizeRestriction == $EQUAL; return $length >= $size1 && $length <= $size2 if $sizeRestriction == $BETWEEN; return 0; } #------------------------------------------------------------------------------- sub usage { <] [-j ] [-s ] [-d ] [-X ] [-Y ] [-e] grepmail [--help|--version] [-abBDFhHilLmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] -E grepmail [--help|--version] [-abBDFhHilLmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] -f At least one of -s, -d, -u, -e, and -E must be specified, and can appear in any relative order following the other flags. The -e flag is optional if pattern appears immediately before -s or -d. Files can be plain ASCII or ASCII files compressed with gzip, or bzip2. -E allows for complex pattern matches involving logical operators. If no file is provided, normal or compressed ASCII input is taken from STDIN. -a Use received date instead of sent date for -d matching -b Search must match body -B Print message bodies but with only limited headers -C Specify the location of the cache file -d Specify a required date range (see below) -D Debug mode -e Explicitly name pattern (when searching for strings beginning with "-") -E Specify a complex search expression -f Read patterns from a file -F Force processing of all data as mailboxes -h Search must match header -H Print headers but not bodies of matching emails -i Ignore case in the search expression -j Search must match status (A=answered, R=read, D=deleted, O=old, F=flagged) -l Output the names of files having an email matching the expression -L Follow symbolic links (implies -R) -M Do not search non-text mime attachments -m Append "X-Mailfolder: " to all headers to indicate in which folder the match occurred -n Print the line number info (and filename if necessary) for the emails -q Quiet mode -- don't output warnings -r Output the names of the files and the number of emails matching the expression -R Recurse directories -s Specify a size range in bytes (see below) -S Ignore signatures -u Ensure that no duplicate emails are output -v Output emails that don't match the expression -V Display the version number -w Match word boundaries -X Specify a regular expression for the signature separator -Y Specify a header to search (implies -h) --help Print a help message Date constraints require Date::Parse. Date specifications must be of the form of: - a date like "today", "1st thursday in June 1992" (requires Date::Manip), "05/18/93", "12:30 Dec 12th 1880", "8:00pm december tenth", - "before", "after", or "since", followed by a date as defined above, - "between and ", where is defined as above. Size constraints must be of the form of: - 12345: match size of exactly 12345 - <12345, <=12345, >12345, >=12345: match size less than, less than or equal, greater than, or greater than or equal to 12345 - 10000-12345: match size between 10000 and 12345 inclusive EOF } #------------------------------------------------------------------------------- =head1 NAME grepmail - search mailboxes for mail matching a regular expression =head1 SYNOPSIS grepmail [--help|--version] [-abBDFhHilLmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] [[-e] |-E |-f ] =head1 DESCRIPTION =over 2 I looks for mail messages containing a pattern, and prints the resulting messages on standard out. By default I looks in both header and body for the specified pattern. When redirected to a file, the result is another mailbox, which can, in turn, be handled by standard User Agents, such as I, or even used as input for another instance of I. At least one of B<-E>, B<-e>, B<-d>, B<-s>, or B<-u> must be specified. The pattern is optional if B<-d>, B<-s>, and/or B<-u> is used. The B<-e> flag is optional if there is no file whose name is the pattern. The B<-E> option can be used to specify complex search expressions involving logical operators. (See below.) If a mailbox can not be found, grepmail first searches the directory specified by the MAILDIR environment variable (if one is defined), then searches the $HOME/mail, $HOME/Mail, and $HOME/Mailbox directories. =back =head1 OPTIONS AND ARGUMENTS Many of the options and arguments are analogous to those of grep. =over 2 =item B The pattern to search for in the mail message. May be any Perl regular expression, but should be quoted on the command line to protect against globbing (shell expansion). To search for more than one pattern, use the form "(pattern1|pattern2|...)". Note that complex pattern features such as "(?>...)" require that you use a version of perl which supports them. You can use the pattern "()" to indicate that you do not want to match anything. This is useful if you want to initialize the cache without printing any output. =item B Mailboxes must be traditional, UNIX C mailbox format. The mailboxes may be compressed by gzip, or bzip2, in which case gunzip, or bzip2 must be installed on the system. If no mailbox is specified, takes input from stdin, which can be compressed or not. grepmail's behavior is undefined when ASCII and binary data is piped together as input. =item B<-a> Use arrival date instead of sent date. =item B<-b> Asserts that the pattern must match in the body of the email. =item B<-B> Print the body but with only minimal ('From ', 'From:', 'Subject:', 'Date:') headers. This flag can be used with -H, in which case it will print only short headers and no email bodies. =item B<-C> Specifies the location of the cache file. The default is $HOME/.grepmail-cache. =item B<-D> Enable debug mode, which prints diagnostic messages. =item B<-d> Date specifications must be of the form of: - a date like "today", "yesterday", "5/18/93", "5 days ago", "5 weeks ago", - OR "before", "after", or "since", followed by a date as defined above, - OR "between and ", where is defined as above. Simple date expressions will first be parsed by Date::Parse. If this fails, grepmail will attempt to parse the date with Date::Manip, if the module is installed on the system. Use an empty pattern (i.e. B<-d "">) to find emails without a "Date: ..." line in the header. Date specifications without times are interpreted as having a time of midnight of that day (which is the morning), except for "after" and "since" specifications, which are interpreted as midnight of the following day. For example, "between today and tomorrow" is the same as simply "today", and returns emails whose date has the current day. ("now" is interpreted as "today".) The date specification "after July 5th" will return emails whose date is midnight July 6th or later. =item B<-E> Specify a complex search expression using logical operators. The current syntax allows the user to specify search expressions using Perl syntax. Three values can be used: $email (the entire email message), $email_header (just the header), or $email_body (just the body). A search is specified in the form "$email =~ /pattern/", and multiple searches can be combined using "&&" and "||" for "and" and "or". For example, the expression $email_header =~ /^From: .*\@coppit.org/ && $email =~ /grepmail/i will find all emails which originate from coppit.org (you must escape the "@" sign with a backslash), and which contain the keyword "grepmail" anywhere in the message, in any capitalization. B<-E> is incompatible with B<-b>, B<-h>, and B<-e>. B<-i>, B<-M>, B<-S>, and B<-Y> have not yet been implemented. NOTE: The syntax of search expressions may change in the future. In particular, support for size, date, and other constraints may be added. The syntax may also be simplified in order to make expression formation easier to use (and perhaps at the expense of reduced functionality). =item B<-e> Explicitly specify the search pattern. This is useful for specifying patterns that begin with "-", which would otherwise be interpreted as a flag. =item B<-f> Obtain patterns from FILE, one per line. The empty file contains zero patterns, and therefore matches nothing. =item B<-F> Force grepmail to process all files and streams as though they were mailboxes. (i.e. Skip checks for non-mailbox ASCII files or binary files that don't look like they are compressed using known schemes.) =item B<-h> Asserts that the pattern must match in the header of the email. =item B<-H> Print the header but not body of matching emails. =item B<-i> Make the search case-insensitive (by analogy to I). =item B<-j> Asserts that the email "Status:" header must contain the given flags. Order and case are not important, so use I<-j AR> or I<-j ra> to search for emails which have been read and answered. =item B<-l> Output the names of files having an email matching the expression, (by analogy to I). =item B<-L> Follow symbolic links. (Implies I<-R>) =item B<-M> Causes grepmail to ignore non-text MIME attachments. This removes false positives resulting from binaries encoded as ASCII attachments. =item B<-m> Append "X-Mailfolder: " to all email headers, indicating which folder contained the matched email. =item B<-n> Prefix each line with line number information. If multiple files are specified, the filename will precede the line number. NOTE: When used in conjunction with B<-m>, the X-Mailfolder header has the same line number as the next (blank) line. =item B<-q> Quiet mode. Suppress the output of warning messages about non-mailbox files, directories, etc. =item B<-r> Generate a report of the names of the files containing emails matching the expression, along with a count of the number of matching emails. =item B<-R> Causes grepmail to recurse any directories encountered. =item B<-s> Return emails which match the size (in bytes) specified with this flag. Note that this size includes the length of the header. Size constraints must be of the form of: - 12345: match size of exactly 12345 - <12345, <=12345, >12345, >=12345: match size less than, less than or equal, greater than, or greater than or equal to 12345 - 10000-12345: match size between 10000 and 12345 inclusive =item B<-S> Ignore signatures. The signature consists of everything after a line consisting of "-- ". =item B<-u> Output only unique emails, by analogy to I. Grepmail determines email uniqueness by the Message-ID header. =item B<-v> Invert the sense of the search, by analogy to I. This results in the set of emails printed being the complement of those that would be printed without the B<-v> switch. =item B<-V> Print the version and exit. =item B<-w> Search for only those lines which contain the pattern as part of a word group. That is, the start of the pattern must match the start of a word, and the end of the pattern must match the end of a word. (Note that the start and end need not be for the I word.) If you are familiar with Perl regular expressions, this flag simply puts a "\b" before and after the search pattern. =item B<-X> Specify a regular expression for the signature separator. By default this pattern is '^-- $'. =item B<-Y> Specify a pattern which indicates specific headers to be searched. The search will automatically treat headers which span multiple lines as one long line. This flag implies B<-h>. In the style of procmail, special strings in the pattern will be expanded as follows: =over 2 If the regular expression contains "^TO:" it will be substituted by ^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To): which should match all headers with destination addresses. If the regular expression contains "^FROM_DAEMON:" it will be substituted by (^(Mailing-List:|Precedence:.*(junk|bulk|list)|To: Multiple recipients of |(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma?(st(e?r)?|n)|office)|(send)?Mail(er)?|daemon|m(mdf|ajordomo)|n?uucp|LIST(SERV|proc)|NETSERV|o(wner|ps)|r(e(quest|sponse)|oot)|b(ounce|bs\.smtp)|echo|mirror|s(erv(ices?|er)|mtp(error)?|ystem)|A(dmin(istrator)?|MMGR|utoanswer))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t ][^<)]*(\(.*\).*)?)? which should catch mails coming from most daemons. If the regular expression contains "^FROM_MAILER:" it will be substituted by (^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From)([^>]*[^(.%@a-z0-9])?(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t][^<)]*(\(.*\).*)?)?$([^>]|$)) (a stripped down version of "^FROM_DAEMON:"), which should catch mails coming from most mailer-daemons. So, to search for all emails to or from "Andy": grepmail -Y '(^TO:|^From:)' Andy mailbox =back =item B<--help> Print a help message summarizing the usage. =item B<--> All arguments following I<--> are treated as mail folders. =back =head1 EXAMPLES Count the number of emails. ("." matches every email.) grepmail -r . sent-mail Get all email between 2000 and 3000 bytes about books grepmail books -s 2000-3000 sent-mail Get all email that you mailed yesterday grepmail -d yesterday sent-mail Get all email that you mailed before the first thursday in June 1998 that pertains to research (requires Date::Manip): grepmail research -d "before 1st thursday in June 1992" sent-mail Get all email that you mailed before the first of June 1998 that pertains to research: grepmail research -d "before 6/1/92" sent-mail Get all email you received since 8/20/98 that wasn't about research or your job, ignoring case: grepmail -iv "(research|job)" -d "since 8/20/98" saved-mail Get all email about mime but not about Netscape. Constrain the search to match the body, since most headers contain the text "mime": grepmail -b mime saved-mail | grepmail Netscape -v Print a list of all mailboxes containing a message from Rodney. Constrain the search to the headers, since quoted emails may match the pattern: grepmail -hl "^From.*Rodney" saved-mail* Find all emails with the text "Pilot" in both the header and the body: grepmail -hb "Pilot" saved-mail* Print a count of the number of messages about grepmail in all saved-mail mailboxes: grepmail -br grepmail saved-mail* Remove any duplicates from a mailbox: grepmail -u saved-mail Convert a Gnus mailbox to mbox format: grepmail . gnus-mailbox-dir/* > mbox Search for all emails to or from an address (taking into account wrapped headers and different header names): grepmail -Y '(^TO:|^From:)' my@email.address saved-mail Find all emails from postmasters: grepmail -Y '^FROM_MAILER:' . saved-mail =head1 FILES grepmail will I create temporary files while decompressing compressed archives. The last version to do this was 3.5. While the new design uses more memory, the code is much simpler, and there is less chance that email can be read by malicious third parties. Memory usage is determined by the size of the largest email message in the mailbox. =head1 ENVIRONMENT The MAILDIR environment variable can be used to specify the default mail directory. This directory will be searched if the specified mailbox can not be found directly. The HOME environment variable is also used to find mailboxes if they can not be found directly. It is also used to store grepmail state information such as its cache file. =head1 BUGS AND LIMITATIONS =over 2 =item Patterns containing "$" may cause problems Currently I look for "$" followed by a non-word character and replace it with the line ending for the current file (either "\n" or "\r\n"). This may cause problems with complex patterns specified with -E, but I'm not aware of any. =item Mails without bodies cause problems According to RFC 822, mail messages need not have message bodies. I've found and removed one bug related to this. I'm not sure if there are others. =item Complex single-point dates not parsed correctly If you specify a point date like "September 1, 2004", grepmail creates a date range that includes the entire day of September 1, 2004. If you specify a complex point date such as "today", "1st Monday in July", or "9/1/2004 at 0:00" grepmail may parse the time incorrectly. The reason for this problem is that Date::Manip, as of version 5.42, forces default values for parsed dates and times. This means that grepmail has a hard time determining whether the user supplied certain time/date fields. (e.g. Did Date::Manip provide a default time of 0:00, or did the user specify it?) grepmail tries to work around this problem, but the workaround is inherently incomplete in some rare cases. =item File names that look like flags cause problems. In some special circumstances, grepmail will be confused by files whose names look like flags. In such cases, use the B<-e> flag to specify the search pattern. =back =head1 AUTHOR David Coppit, , http://coppit.org/ =head1 SEE ALSO elm(1), mail(1), grep(1), perl(1), printmail(1), Mail::Internet(3), procmailrc(5). Crocker, D. H., Standard for the Format of Arpa Internet Text Messages, RFC 822. =cut grepmail-5.3033/grepmail.old0000644000076500001200000021663310571623426015073 0ustar coppitadmin#!/usr/bin/perl -w # grepmail $VERSION = sprintf "%d.%02d%02d", q/5.30.31/ =~ /(\d+)/g; # Grepmail searches a normal, gzip'd, tzip'd, or bzip2'd mailbox for a given # regular expression and returns those emails that match the query. It also # supports piped compressed or ascii input, and searches constrained by date # and size. # Visit the grepmail project homepage at http://grepmail.sourceforge.net/ # There you can join the announcements mailing list to be notified of updates, # grab the development environment via CVS, participate in chats and mailing # lists, report bugs, submit patches, etc. # Do a pod2text on this file to get full documentation, or pod2man to get # man pages. # Written by David Coppit (david@coppit.org, http://coppit.org/) with lots of # debugging and patching by others -- see the CHANGES file for a complete # list. # This code is distributed under the GNU General Public License (GPL). See # http://www.opensource.org/gpl-license.html and http://www.opensource.org/. require 5.00396; use vars qw( %opts $commandLine $VERSION %message_ids_seen $USE_CACHING $USE_GREP ); use Getopt::Std; use strict; use Mail::Mbox::MessageParser; use FileHandle; use Carp; # Set to 1 to enable caching capability $USE_CACHING = 1; # Set to 0 to disable use of external grep utility $USE_GREP = 1; # Internal function return values. my $PRINT = 0; my $DONE = 1; my $SKIP = 2; my $CONTINUE = 3; my $NONE = 4; my $BEFORE = 5; my $AFTER = 6; my $NODATE = 8; my $BETWEEN = 9; my $LESS_THAN = 10; my $LESS_THAN_OR_EQUAL = 11; my $GREATER_THAN = 12; my $GREATER_THAN_OR_EQUAL = 13; my $EQUAL = 14; my $NO_PATTERN = '\127\235NO PATTERN\725\125'; my %HEADER_PATTERNS = ( '^TO:' => '(^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To):)', '^FROM_DAEMON:' => '(^(Mailing-List:|Precedence:.*(junk|bulk|list)|To: Multiple recipients of |(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma?(st(e?r)?|n)|office)|(send)?Mail(er)?|daemon|m(mdf|ajordomo)|n?uucp|LIST(SERV|proc)|NETSERV|o(wner|ps)|r(e(quest|sponse)|oot)|b(ounce|bs\.smtp)|echo|mirror|s(erv(ices?|er)|mtp(error)?|ystem)|A(dmin(istrator)?|MMGR|utoanswer))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t ][^<)]*(\(.*\).*)?)?))', '^FROM_MAILER:' => '(^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From)([^>]*[^(.%@a-z0-9])?(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t][^<)]*(\(.*\).*)?)?$([^>]|$))', ); #------------------------------------------------------------------------------- # Outputs debug messages with the -D flag. Be sure to return 1 so code like # 'dprint "blah\n" and exit' works. sub dprint { return 1 unless $opts{'D'}; my $message = join '',@_; foreach my $line (split /\n/, $message) { warn "DEBUG: $line\n"; } return 1; } #------------------------------------------------------------------------------- # Print a nice error message before exiting sub Report_And_Exit { my $message = shift; $message .= "\n" unless $message =~ /\n$/; warn "grepmail: $message"; exit 1; } #------------------------------------------------------------------------------- # Filter signals to print error messages when CTRL-C is caught, a pipe is # empty, a pipe is killed, etc. my %signals_and_messages = ( 'PIPE' => 'Broken Pipe', 'HUP' => 'Hangup', 'INT' => 'Canceled', 'QUIT' => 'Quit', 'SEGV' => 'Segmentation violation', 'TERM' => 'Terminated', ); # We'll store a copy of the original signal handlers and call them when we're # done. This helps when running under the debugger. my %old_SIG = %SIG; sub Signal_Handler { my $signal = $_[0]; $old_SIG{$signal}->(@_) if $old_SIG{$signal}; Report_And_Exit($signals_and_messages{$signal}); } # Delete the HUP signal for Windows, where it doesn't exist delete $signals_and_messages{HUP} if $^O eq 'MSWin32'; # We have to localize %SIG to prevent odd bugs from cropping up (see # changelog). Using an array slice on %SIG, I assign an array consisting of as # many copies of \&Signal_Handler as there are keys in %signals_and_messages. local @SIG{keys %signals_and_messages} = (\&Signal_Handler) x keys %signals_and_messages; ################################ MAIN PROGRAM ################################# binmode STDOUT; binmode STDERR; my ($dateRestriction, $date1, $date2); my ($sizeRestriction, $size1, $size2); { # PROCESS ARGUMENTS my (@remaining_arguments,$pattern); { my ($opts_ref,$remaining_arguments_ref); ($opts_ref,$remaining_arguments_ref,$pattern) = Get_Options(@ARGV); %opts = %$opts_ref; @remaining_arguments = @$remaining_arguments_ref; } # Initialize seen messages data structure to empty. %message_ids_seen = (); # Save the command line for later when we try to decompress standard input { # Need to quote arguments with spaces my @args = @ARGV; grep { $_ = "'$_'" if index($_, ' ') != -1; $_ } @args; $commandLine = "$0 @args"; } Print_Debug_Information($commandLine); sub Process_Date($); sub Process_Size($); sub Get_Files(@); # Make the pattern insensitive if we need to $pattern = "(?i)$pattern" if ($opts{'i'}) && $pattern ne $NO_PATTERN; # Make the pattern match word boundaries if we need to $pattern = "\\b$pattern\\b" if ($opts{'w'}) && $pattern ne $NO_PATTERN; if (defined $opts{'d'}) { ($dateRestriction,$date1,$date2) = Process_Date($opts{'d'}); } else { $dateRestriction = $NONE; } if (defined $opts{'s'}) { ($sizeRestriction,$size1,$size2) = Process_Size($opts{'s'}); } else { $sizeRestriction = $NONE; } dprint "PATTERN: $pattern\n" unless $pattern eq $NO_PATTERN; dprint "PATTERN: \n" if $pattern eq $NO_PATTERN; dprint "FILES: @remaining_arguments\n"; dprint "DATE RESTRICTION: $dateRestriction\n"; dprint "FIRST DATE: $date1\n" unless $dateRestriction == $NONE; dprint "SECOND DATE: $date2\n" unless $dateRestriction == $NONE; dprint "SIZE RESTRICTION: $sizeRestriction\n"; dprint "FIRST SIZE: $size1\n" unless $sizeRestriction == $NONE; dprint "SECOND SIZE: $size2\n" unless $sizeRestriction == $NONE; Validate_Pattern($pattern); my @files = Get_Files(@remaining_arguments); # If the user provided input files... if (@files) { Handle_Input_Files(@files,$pattern); } # Using STDIN else { Handle_Standard_Input($pattern); } exit 0; } #------------------------------------------------------------------------------- sub Get_Options { local @ARGV = @_; my @argv = @ARGV; # Print usage error if no arguments given Report_And_Exit("No arguments given.\n\n" . usage()) unless @ARGV; # Check for --help, the standard usage command, or --version. print usage() and exit(0) if grep { /^--help$/ } @ARGV; print "$VERSION\n" and exit(0) if grep { /^--version$/ } @ARGV; my @valid_options = qw( a b B C d D e E f F i j h H l M m n q r R s S t T u v V w X Y Z ); my %opts; my $pattern; # Initialize all options to zero. map { $opts{$_} = 0; } @valid_options; # And some to non-zero. $opts{'d'} = $opts{'V'} = undef; $opts{'X'} = '^-- $'; $opts{'C'} = undef; # Ensure valid options. ALSO UPDATE 2ND GETOPT CALL BELOW getopt("CdeEfjsXY",\%opts); # Here we have to deal with the possibility that the user specified the # search pattern without the -e flag. # getopts stops as soon as it sees a non-flag, so $ARGV[0] may contain the # pattern with more flags after it. unless ($opts{'e'} || $opts{'E'} || $opts{'f'}) { my $missing_flags = ''; foreach my $flag (keys %opts) { $missing_flags .= $flag unless $opts{$flag}; } $missing_flags = "[$missing_flags]"; # If it looks like more flags are following, then grab the pattern and # process them. unless (defined $argv[-($#ARGV+2)] && $argv[-($#ARGV+2)] eq '--') { if ( $#ARGV > 0 && $ARGV[1] =~ /^-$missing_flags$/) { $pattern = shift @ARGV; getopt("CdfjsXY",\%opts); } # If we've seen a -d, -j, -s, or -u flag, and it doesn't look like there # are flags following $ARGV[0], then look at the value in $ARGV[0] elsif ( ( defined $opts{'d'} || $opts{'j'} || $opts{'s'} || $opts{'u'} ) && ( $#ARGV <= 0 || ( $#ARGV > 0 && $ARGV[1] !~ /^-$missing_flags$/ ) ) ) { # If $ARGV[0] looks like a file we assume there was no pattern and # set a default pattern of "." to match everything. if ($#ARGV != -1 && -f Search_Mailbox_Directories($ARGV[0])) { $pattern = '.'; } # Otherwise we take the pattern and move on else { $pattern = shift @ARGV; } } # If we still don't have a pattern or any -d, -j, -s, or -u flag, we # assume that $ARGV[0] is the pattern elsif (!defined $opts{'d'} && !$opts{'j'} && !$opts{'s'} && !$opts{'u'}) { $pattern = shift @ARGV; } } } if ($opts{'e'} || $opts{'E'} || $opts{'f'}) { Report_And_Exit("You specified two search patterns, or a pattern and a pattern file.\n") if defined $pattern; if ($opts{'e'}) { $pattern = $opts{'e'}; } elsif ($opts{'E'}) { $pattern = $opts{'E'}; } else { open PATTERN_FILE, $opts{'f'} or Report_And_Exit("Can't open pattern file $opts{'f'}"); $pattern = '('; my $first = 1; while (my $line = ) { if ($first) { $first = 0; } else { $pattern .= '|'; } chomp $line; $pattern .= $line; } close PATTERN_FILE; $pattern .= ')'; } } elsif (defined $opts{'V'}) { # Print version and exit if we need to print "$VERSION\n"; exit (0); } elsif (!defined $pattern) { # The only times you don't have to specify the pattern is when -d, -j, -s, or -u # is being used. This should catch people who do "grepmail -h" thinking # it's help. Report_And_Exit("Invalid arguments.\n\n" . usage()) unless defined $opts{'d'} || $opts{'j'} || $opts{'s'} || $opts{'u'}; $pattern = '.'; } if (defined $opts{'d'}) { if (eval 'require Date::Parse;') { import Date::Parse; } else { Report_And_Exit('You specified -d, but do not have Date::Parse. ' . "Get it from CPAN.\n"); } if (eval 'require Time::Local;') { import Time::Local; } else { Report_And_Exit('You specified -d, but do not have Time::Local. ' . "Get it from CPAN.\n"); } if (eval 'require Date::Manip') { my ($version_number) = $Date::Manip::VERSION =~ /^(\d+\.\d+)/; Date::Manip::Date_Init("TodayIsMidnight=1") if $version_number >= 5.43; } } $opts{'h'} = 1 if $opts{'Y'}; # Make sure no unknown flags were given foreach my $option (keys %opts) { unless (grep {/^$option$/} @valid_options) { Report_And_Exit("Invalid option \"$option\".\n\n" . usage()); } } # Check for -E flag incompatibilities. if ($opts{'E'}) { # Have to do -Y before -h because the former implies the latter my @options = qw(e f M S Y); for my $option (@options) { if ($opts{$option}) { Report_And_Exit "-$option can not be used with -E"; } } if ($opts{'i'}) { Report_And_Exit "-i can not be used with -E. Use -E '\$email =~ /pattern/i' instead"; } if ($opts{'b'}) { Report_And_Exit "-b can not be used with -E. Use -E '\$email_body =~ /pattern/' instead"; } if ($opts{'h'}) { Report_And_Exit "-h can not be used with -E. Use -E '\$email_header =~ /pattern/' instead"; } } # Check for -f flag incompatibilities. if ($opts{'f'}) { # Have to do -Y before -h because the former implies the latter my @options = qw(E e); for my $option (@options) { if ($opts{$option}) { Report_And_Exit "-$option can not be used with -E"; } } } unless (defined $opts{'C'}) { if(defined $ENV{'HOME'}) { $opts{'C'} = "$ENV{'HOME'}/.grepmail-cache"; } elsif ($USE_CACHING) { # No cache file, so disable caching $USE_CACHING = 0; warn "grepmail: No cache file specified, and \$HOME not set. " . "Disabling cache.\n" unless $opts{'q'}; } } $pattern = $NO_PATTERN if $pattern eq '()'; return (\%opts, \@ARGV, $pattern); } #------------------------------------------------------------------------------- sub Print_Debug_Information { my $commandLine = shift; return unless $opts{'D'}; dprint "Version: $VERSION"; dprint "Command line was (special characters not escaped):"; dprint " $commandLine"; if (defined $Date::Parse::VERSION) { dprint "Date::Parse VERSION: $Date::Parse::VERSION"; } dprint "Options are:"; foreach my $i (sort keys %opts) { if (defined $opts{$i}) { dprint " $i: $opts{$i}"; } else { dprint " $i: undef"; } } dprint "INC is:"; foreach my $i (@INC) { dprint " $i"; } } #------------------------------------------------------------------------------- # Dies if the given pattern's syntax is invalid sub Validate_Pattern { my $pattern = shift; local $@; if ($opts{'E'}) { eval {if ($pattern) {}}; Report_And_Exit "The match condition \"$pattern\" is invalid.\n" if $@; } elsif ($pattern ne $NO_PATTERN) { eval {'string' =~ /$pattern/}; Report_And_Exit "The pattern \"$pattern\" is invalid.\n" if $@; } } #------------------------------------------------------------------------------- # Get a list of files, taking recursion into account if necessary. sub Get_Files(@) { my @files_and_directories = @_; # We just return what we were given unless we need to recurse subdirectories. return @files_and_directories unless $opts{'R'}; my @files; foreach my $arg (@files_and_directories) { if (-f $arg) { push @files, $arg; } elsif( -d $arg) { dprint "Recursing directory $arg looking for files..."; unless (eval "require File::Find;") { Report_And_Exit("You specified -R, but do not have File::Find. " . "Get it from CPAN.\n"); } import File::Find; # Gets all plain files in directory and descendents. Puts them in @files $File::Find::name = ''; find(sub {push @files,"$File::Find::name" if -f $_}, $arg); } else { # Ignore unknown file types } } return @files; } #------------------------------------------------------------------------------- sub Handle_Input_Files { my $pattern = pop @_; my @files = @_; # For each input file... foreach my $file (@files) { dprint '#'x70; dprint "Processing file $file"; # First of all, silently ignore empty files... next if -z $file; # ...and also ignore directories. if (-d $file) { warn "grepmail: Skipping directory: '$file'\n" unless $opts{'q'}; next; } $file = Search_Mailbox_Directories($file) unless -f $file; Process_Mail_File(undef,$file,$#files+1,$pattern); } } #------------------------------------------------------------------------------- sub Search_Mailbox_Directories { my $file = shift; my @maildirs; push @maildirs, $ENV{'MAILDIR'} if defined $ENV{'MAILDIR'} && -d $ENV{'MAILDIR'}; push @maildirs, "$ENV{HOME}/mail" if defined $ENV{'HOME'} && -d "$ENV{HOME}/mail"; push @maildirs, "$ENV{HOME}/Mail" if defined $ENV{'HOME'} && -d "$ENV{HOME}/Mail"; push @maildirs, "$ENV{HOME}/Mailbox" if defined $ENV{'HOME'} && -d "$ENV{HOME}/Mailbox"; foreach my $mail_folder (@maildirs) { my $path_and_file = "$mail_folder/$file"; return $path_and_file if -e $path_and_file; } return $file; } #------------------------------------------------------------------------------- sub Handle_Standard_Input { my $pattern = shift; dprint "Handling STDIN"; # We have to implement our own -B and -s, because STDIN gets eaten by them binmode STDIN; my $fileHandle = new FileHandle; $fileHandle->open('-'); Process_Mail_File($fileHandle,undef,1,$pattern); } #------------------------------------------------------------------------------- # This algorithm is complicated by code to short-circuit some # computations. For example, if the user specified -h but not -b, when # we can analyze the header for a match and avoid needing to search # the body, which may be much larger. sub Do_Simple_Pattern_Matching { my $email_header = shift; my $email_body = shift; my $fileHandle = shift; my $fileName = shift; my $number_files = shift; my $numberOfMatches = shift; my $line = shift; my $endline = shift; my $pattern = shift; die unless ref $email_header && ref $email_body; return ($CONTINUE,$numberOfMatches) if $pattern eq $NO_PATTERN; dprint "Checking for early match or abort based on header information." if $opts{'D'}; my ($result,$matchesHeader) = Analyze_Header($email_header,$email_body,$fileHandle,$pattern,1,$endline); if ($result == $SKIP) { dprint "Doing an early abort based on header." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } if ($result == $PRINT) { dprint "Doing an early printout based on header." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- my $matchesBody = 0; my $signature_offset = undef; if ($opts{'S'}) { my $signature_pattern = $opts{'X'}; $signature_pattern =~ s#\$#$/#; if ($$email_body =~ m/($signature_pattern)/mg) { $signature_offset = pos($$email_body) - length($1); pos($$email_body) = 0; dprint "Signature offset: $signature_offset"; } } # Ignore the MIME attachments if -M was specified if ($opts{'M'} && ($$email_header =~ /^Content-Type:.*?boundary=(?:"([^"]*)"|([^\r\n]*))/ism)) { my $boundary; $boundary = $1 if defined $1; $boundary = $2 if defined $2; dprint "Found attachments with boundary:\n $boundary" if $opts{'D'}; my @attachment_positions; # Get each of the binary attachment beginnings and endings. while ($$email_body =~ m/\n((?:--)?\Q$boundary\E(?:--)?$endline(?:(.*?)$endline$endline)?)/sg) { my $position = pos($$email_body) - length($1); my $header = $2; # Remember that the beginning of the next attachment is the # end of the previous. $attachment_positions[-1]{'end'} = $position if @attachment_positions; # If it's the beginning of a binary attachment, store the position if (defined $header && $header =~ /^Content-Type:\s+(?!text)/i) { $attachment_positions[$#attachment_positions+1]{'beginning'} = $position; } } pos($$email_body) = 0; # Now search the body, ignoring any matches in binary # attachments. # Avoid perl 5.6 bug which causes spurious warning even though # $pattern is defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; SEARCH: while ($$email_body =~ m/($pattern)/omg) { my $position = pos($$email_body) - length($1); last SEARCH if $opts{'S'} && defined $signature_offset && $position > $signature_offset; foreach my $attachment (@attachment_positions) { next SEARCH if ($position > $attachment->{'beginning'} && $position < $attachment->{'end'}); } $matchesBody = 1; last; } pos($$email_body) = 0; } else { # Avoid perl 5.6 bug which causes spurious warning even though # $pattern is defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; pos($$email_body) = 0; if ($$email_body =~ m/($pattern)/omg) { my $position = pos($$email_body) - length($1); $matchesBody = 1 unless $opts{'S'} && defined $signature_offset && $position > $signature_offset; } pos($$email_body) = 0; } #---------------------------------------------------------------- my $matchesSize = Is_In_Size($email_header,$email_body,$sizeRestriction,$size1,$size2); #---------------------------------------------------------------- dprint "Checking for early match or abort based on header, body, " . "and size information." if $opts{'D'}; my $isMatch = 1; $isMatch = 0 if $opts{'s'} && !$matchesSize || $opts{'b'} && !$matchesBody || $opts{'h'} && !$matchesHeader || !$opts{'b'} && !$opts{'h'} && !($matchesBody || $matchesHeader); if (!$isMatch && !$opts{'v'}) { dprint "Doing an early abort based on header, body, and size." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } elsif (!$isMatch && $opts{'v'}) { dprint "Doing an early printout based on header, body, and size." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- dprint "Checking date constraint." if $opts{'D'}; $isMatch = 1; { my $matchesDate = Email_Matches_Date($email_header,$endline); $isMatch = 0 if defined $opts{'d'} && !$matchesDate; dprint "Email matches date constraint\n" if $opts{'D'} && defined $opts{'d'} && $matchesDate; dprint "Email doesn't match date constraint\n" if $opts{'D'} && defined $opts{'d'} && !$matchesDate; } $isMatch = !$isMatch if $opts{'v'}; # If the match occurred in the right place... if ($isMatch) { dprint "Email matches all patterns and constraints." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; } } else { dprint "Email did not match all patterns and constraints." if $opts{'D'}; } return ($CONTINUE,$numberOfMatches); } #------------------------------------------------------------------------------- # This algorithm is complicated by code to short-circuit some # computations. For example, if the user specified -h but not -b, when # we can analyze the header for a match and avoid needing to search # the body, which may be much larger. sub Do_Complex_Pattern_Matching { my $email_header = shift; my $email_body = shift; my $fileHandle = shift; my $fileName = shift; my $number_files = shift; my $numberOfMatches = shift; my $line = shift; my $endline = shift; my $pattern = shift; die unless ref $email_header && ref $email_body; return ($CONTINUE,$numberOfMatches) if $pattern eq $NO_PATTERN; dprint "Checking for early match or abort based on header information." if $opts{'D'}; my ($result,$matchesHeader) = Analyze_Header($email_header,$email_body,$fileHandle,$pattern,0,$endline); if ($result == $SKIP) { dprint "Doing an early abort based on header." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } if ($result == $PRINT) { dprint "Doing an early printout based on header." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- my $modified_pattern = $pattern; $modified_pattern =~ s/\$email_header\b/\$\$email_header/g; $modified_pattern =~ s/\$email_body\b/\$\$email_body/g; $modified_pattern =~ s#(=~\s*)/([^/]*)/#$1/$2/om#g; my $matchesEmail; if ($modified_pattern =~ /\$email\b/) { my $header_pattern = $modified_pattern; $header_pattern =~ s/\$email\b/\$\$email_header/g; eval " \$matchesEmail = $header_pattern ? 1 : 0 "; unless ($matchesEmail) { my $body_pattern = $modified_pattern; $body_pattern =~ s/\$email\b/\$\$email_body/g; eval " \$matchesEmail = $body_pattern ? 1 : 0 "; } } else { eval " \$matchesEmail = $modified_pattern ? 1 : 0 "; } #---------------------------------------------------------------- my $isMatch = 1; $isMatch = 0 unless $matchesEmail; if (!$isMatch && !$opts{'v'}) { dprint "Doing an early abort based on header, body, and size." if $opts{'D'}; return ($CONTINUE,$numberOfMatches); } elsif (!$isMatch && $opts{'v'}) { dprint "Doing an early printout based on header, body, and size."; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; return ($CONTINUE,$numberOfMatches); } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; return ($CONTINUE,$numberOfMatches); } } #---------------------------------------------------------------- dprint "Checking date constraint." if $opts{'D'}; $isMatch = 1; { my $matchesDate = Email_Matches_Date($email_header,$endline); $isMatch = 0 if defined $opts{'d'} && !$matchesDate; dprint "Email matches date constraint\n" if $opts{'D'} && defined $opts{'d'} && $matchesDate; dprint "Email doesn't match date constraint\n" if $opts{'D'} && defined $opts{'d'} && !$matchesDate; } $isMatch = !$isMatch if $opts{'v'}; # If the match occurred in the right place... if ($isMatch) { dprint "Email matches all patterns and constraints." if $opts{'D'}; if ($opts{'l'}) { print Get_Filename($fileName)."\n"; # We can return since we found at least one email that matches. return ($DONE,$numberOfMatches); } elsif ($opts{'r'}) { $numberOfMatches++; } else { Convert_Email_To_Mbox_And_Print_It($fileName,$email_header, $email_body,$number_files,$line,$endline) if $opts{'u'} && Not_A_Duplicate($email_header) || !$opts{'u'}; } } else { dprint "Email did not match all patterns and constraints." if $opts{'D'}; } return ($CONTINUE,$numberOfMatches); } #------------------------------------------------------------------------------- sub Process_Mail_File { my $fileHandle = shift @_; my $fileName = shift @_; my $number_files = shift @_; my $pattern = shift @_; my $setup_result = Mail::Mbox::MessageParser::SETUP_CACHE( { 'file_name' => $opts{'C'} } ) if $USE_CACHING; $USE_CACHING = 0 if $USE_CACHING && $setup_result ne 'ok'; my $folder_reader = new Mail::Mbox::MessageParser( { 'file_name' => $fileName, 'file_handle' => $fileHandle, 'enable_cache' => $USE_CACHING, 'enable_grep' => $USE_GREP, 'force_processing' => $opts{'F'}, 'debug' => $opts{'D'}, } ); unless (ref $folder_reader) { my $error = $folder_reader; # Catch fatal errors if ($error eq 'No data on filehandle') { Report_And_Exit('No data on standard input'); } elsif ($error eq 'Not a mailbox') { unless($opts{'q'}) { if (defined $fileName) { warn "grepmail: \"$fileName\" is not a mailbox, skipping\n" } else { warn "grepmail: Standard input is not a mailbox, skipping\n" } } return; } else { warn "grepmail: $error, skipping\n" unless $opts{'q'}; return; } } my $numberOfMatches = 0; my $endline = $folder_reader->endline(); local $/ = $endline; my $modified_pattern = $pattern; $modified_pattern =~ s#\$([^\w]|$)#$/$1#; # This is the main loop. It's executed once for each email while(!$folder_reader->end_of_file()) { dprint "Reading email" if $opts{'D'}; my $email = $folder_reader->read_next_email(); # Direct access for performance reasons #my $line = $folder_reader->line_number(); my $line = $folder_reader->{'email_line_number'}; my ($email_header,$email_body); { my $end_of_header; my $newlines_position = index($$email,"$endline$endline"); if ($newlines_position != -1) { $end_of_header = $newlines_position+length("$endline$endline"); } else { $end_of_header = length($$email); } $$email_header = substr($$email,0,$end_of_header); $email_body = $email; substr($$email_body,0,$end_of_header) = ''; } Print_Email_Statistics($email_header,$email_body,$endline) if $opts{'D'}; #---------------------------------------------------------------- if ($opts{'E'}) { my $result; ($result, $numberOfMatches) = Do_Complex_Pattern_Matching($email_header, $email_body, $fileHandle, $fileName, $number_files, $numberOfMatches, $line, $endline, $modified_pattern); return if $result == $DONE; } else { my $result; ($result, $numberOfMatches) = Do_Simple_Pattern_Matching($email_header, $email_body, $fileHandle, $fileName, $number_files, $numberOfMatches, $line, $endline, $modified_pattern); return if $result == $DONE; } } print Get_Filename($fileName).": $numberOfMatches\n" if $opts{'r'}; } #------------------------------------------------------------------------------- # Checks that an email is not a duplicate of one already printed. This should # only be called when $opts{'u'} is true. Also, as a side-effect, it updates # the %message_ids_seen when it sees an email that hasn't been printed yet. { my $tried_to_load_digest_md5; sub Not_A_Duplicate { my $email_header = shift; die unless ref $email_header; my ($message_id) = $$email_header =~ /^Message-Id:\s*<([^>]+)>/mi; if (defined $message_id) { dprint "Checking uniqueness of message id: $message_id"; } else { dprint "Email does not have a message id"; # Try to load Digest::MD5 if we haven't already unless (defined $tried_to_load_digest_md5) { $tried_to_load_digest_md5 = 1; if (eval "require Digest::MD5") { dprint "Digest::MD5 VERSION: $Digest::MD5::VERSION"; # To prevent warning about variable being used only once my $dummy = $Digest::MD5::VERSION; } else { dprint "Digest::MD5 could not be loaded"; } } # Now create a message id if (defined $Digest::MD5::VERSION) { $message_id = Digest::MD5::md5_hex($$email_header); dprint "Generated message id $message_id with Digest::MD5"; } else { $message_id = $$email_header; dprint "Using email header as message id."; } } my $result; if (exists $message_ids_seen{$message_id}) { $result = 0; dprint "Found duplicate message"; } else { $result = 1; dprint "Found non-duplicate message"; $message_ids_seen{$message_id} = 1; } return $result; } } #------------------------------------------------------------------------------- # - Returns header lines in the email header which match the given name. # - Example names: 'From:', 'Received:' or 'From ' # - If the calling context wants a list, a list of the matching header lines # are returned. Otherwise, the first (and perhaps only) match is returned. # - Wrapped lines are handled. Look for multiple \n's in the return value(s) # - 'From ' also looks for Gnus 'X-From-Line:' or 'X-Draft-From:' sub Get_Header_Field { my $email_header = shift; my $header_name = shift; my $endline = shift; die unless ref $email_header; # Avoid perl 5.6 bug which causes spurious warning even though $email_header # is defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; if ($header_name =~ /^From$/i && $$email_header =~ /^((?:From\s|X-From-Line:|X-Draft-From:).*$endline(\s.*$endline)*)/im) { return wantarray ? ($1) : $1; } my @matches = $$email_header =~ /^($header_name\s.*$endline(?:\s.*$endline)*)/igm; if (@matches) { return wantarray ? @matches : shift @matches; } if (lc $header_name eq 'from ' && $$email_header =~ /^(From\s.*$endline(\s.*$endline)*)/im) { return wantarray ? ($1) : $1; } return undef; } #------------------------------------------------------------------------------- # Print the email author and subject, given a reference to an email header. sub Print_Email_Statistics { my $email_header = shift; my $email_body = shift; my $endline = shift; die unless ref $email_header && ref $email_body; dprint '-'x70; dprint "Processing email:"; my $message_id = Get_Header_Field($email_header,'Message-Id:',$endline); if (defined $message_id) { dprint " $message_id"; } else { dprint " [No message id line found]"; } my $author = Get_Header_Field($email_header,'From:',$endline); $author = Get_Header_Field($email_header,'From ',$endline) unless defined $author; if (defined $author) { dprint " $author"; } else { dprint " [No from line found]"; } my $subject = Get_Header_Field($email_header,'Subject:',$endline); if (defined $subject) { dprint " $subject"; } else { dprint " [No subject line found]"; } my $date = Get_Header_Field($email_header,'Date:',$endline); if (defined $date) { dprint " $date"; } else { dprint " [No subject line found]"; } dprint " Size: " . (length($$email_header) + length($$email_body)); } #------------------------------------------------------------------------------- # Returns: # A result: # - $PRINT if the email is a match and we need to print it # - $SKIP if we should skip the current email and go on to the next one # - $CONTINUE if we need to keep processing the email. # A boolean for whether the header matches the pattern. # A boolean for whether the header has the correct date. # It turns out that -h, -b, -d, -s , -j, and -v have some nasty feature # interaction. The easy cases are when a constraint is not met--either we skip # if -v is not specified, or we print if -v is specified. # # If a constraint *is* met, we can still do an early abort of there are no other # constraints, or if we know the values of previously checked constraints. # # Finally, -b must be taken into account when analyzing -h matching. Also, we # don't analyze the date here because it is too darn slow. sub Analyze_Header { my $email_header = shift; my $email_body = shift; my $fileHandle = shift; my $pattern = shift; my $doHeaderMatch = shift; my $endline = shift; die unless ref $email_header && ref $email_body; # See if the email fails the status flag restriction my $matchesStatus = 1; if ($opts{'j'}) { foreach my $flag (split //,$opts{'j'}) { $matchesStatus = 0 unless $$email_header =~ /^Status: .*(?i:$flag)/m; } # Easy cases return ($SKIP,0) if !$opts{'v'} && !$matchesStatus; return ($PRINT,1) if $opts{'v'} && !$matchesStatus; # If we know there are no other constraints return ($PRINT,1) if !$opts{'v'} && $matchesStatus && !$opts{'s'} && !defined $opts{'d'} && $pattern eq '.'; return ($SKIP,0) if $opts{'v'} && $matchesStatus && !$opts{'s'} && !defined $opts{'d'} && $pattern eq '.'; } # See if the email header fails the size restriction. my $matchesSize = 1; if ($opts{'s'}) { $matchesSize = 0 if !Is_In_Size($email_header,$email_body,$sizeRestriction,$size1,$size2); # Easy cases return ($SKIP,0) if !$opts{'v'} && !$matchesSize; return ($PRINT,1) if $opts{'v'} && !$matchesSize; # If we know there are no other constraints, or we know their values return ($PRINT,1) if !$opts{'v'} && $matchesSize && $matchesStatus && !defined $opts{'d'} && $pattern eq '.'; return ($SKIP,0) if $opts{'v'} && $matchesSize && $matchesStatus && !defined $opts{'d'} && $pattern eq '.'; } if ($doHeaderMatch) { # See if the header matches the pattern # Avoid perl 5.6 bug which causes spurious warning even though $pattern is # defined. local $^W = 0 if $] >= 5.006 && $] < 5.8; my $matchesHeader = Header_Matches_Pattern($email_header,$pattern,$endline); if ($opts{'h'}) { # Easy cases return ($SKIP,0) if !$opts{'v'} && !$matchesHeader; return ($PRINT,1) if $opts{'v'} && !$matchesHeader; } # If we know there are no other constraints, or we know their values return ($PRINT,1) if !$opts{'v'} && $matchesHeader && $matchesSize && $matchesStatus && !defined $opts{'d'} && !$opts{'b'}; return ($SKIP,0) if $opts{'v'} && $matchesHeader && $matchesSize && $matchesStatus && !defined $opts{'d'} && !$opts{'b'}; return ($CONTINUE,$matchesHeader); } else { return ($CONTINUE,1); } } #------------------------------------------------------------------------------- my $header_pattern = undef; sub Header_Matches_Pattern { my $email_header = ${shift @_}; my $pattern = shift; my $endline = shift; return ($email_header =~ /$pattern/om) || 0 unless $opts{'Y'}; dprint "Searching individual headers."; $email_header =~ s/\n(\s+)/$1/g; unless (defined $header_pattern) { $header_pattern = $opts{'Y'}; for my $special_header_pattern (keys %HEADER_PATTERNS) { $header_pattern =~ s/\Q$special_header_pattern\E/$HEADER_PATTERNS{$special_header_pattern}/g; } # Make the pattern insensitive if we need to $header_pattern = "(?i)$header_pattern" if ($opts{'i'}); } for my $header (split(/$endline/, $email_header)) { if ($header =~ /$header_pattern/) { dprint "Header matched header pattern:\n $header\n"; return 1 if $header =~ /$pattern/om; } } return 0; } #------------------------------------------------------------------------------- sub Convert_Email_To_Mbox_And_Print_It { my $fileName = shift; my $email_header = shift; my $email_body = shift; my $number_files = shift; my $line_number = shift; my $endline = shift; ($email_header,$email_body) = Convert_Email_To_Mbox($email_header,$email_body); Print_Email($fileName,$email_header,$email_body,$number_files,$line_number, $endline); } #------------------------------------------------------------------------------- sub Convert_Email_To_Mbox { my $email_header = shift; my $email_body = shift; dprint "Making email mbox format."; # Check for a Gnus email $$email_header =~ s/^(X-From-Line|X-Draft-From):\s+/From /; return ($email_header,$email_body); } #------------------------------------------------------------------------------- sub Get_Filename { my $fileName = shift; if (defined $fileName) { return "$fileName"; } else { return "(standard input)"; } } #------------------------------------------------------------------------------- sub Print_Email { my $fileName = shift; my $email_header = shift; my $email_body = shift; my $number_files = shift; my $line_number = shift; my $endline = shift; dprint "Printing email."; if ($opts{'n'}) { # Print header-by-header my @headers = $$email_header =~ /^(.*$endline(?:\s.*$endline)*)/gm; foreach my $header (@headers) { # Add the mailfolder to the headers if -m was given. Careful # about line numbers! if ($opts{'m'} && $header eq $endline) { print Get_Filename($fileName).":" if $number_files > 1; print " " x length $line_number, ":X-Mailfolder: ", Get_Filename($fileName), $endline; } # Print only 3-line header if -B if ($opts{'B'} && $header !~ /^(From\s|X-From-Line:|X-Draft-From:|From:|Date:|Subject:|$endline)/i) { $line_number += ($header =~ tr/\n//); } else { my $prefix = ''; $prefix = Get_Filename($fileName).":" if $number_files > 1; $header =~ s/^/$line_number++;$prefix . ($line_number-1) . ':'/mge; print $header; } } # Don't print the body if -H is specified if($opts{'H'}) { $line_number += ($$email_body =~ tr/\n//); return; } while ($$email_body =~ /([^\r\n]*$endline)/g) { my $line = $1; print Get_Filename($fileName).":" if $number_files > 1; print "$line_number:$line"; $line_number++; } } else { # print short headers if -B is specified if ($opts{'B'}) { print Get_Header_Field($email_header,'From ',$endline); print Get_Header_Field($email_header,'Date:',$endline); print Get_Header_Field($email_header,'From:',$endline); print Get_Header_Field($email_header,'Subject:',$endline); print "X-Mailfolder: ".Get_Filename($fileName)."$endline$endline" if $opts{'m'}; } else { chomp $$email_header; print $$email_header; print "X-Mailfolder: ".Get_Filename($fileName).$endline if $opts{'m'}; print $endline; $$email_header .= $endline; } # Don't print the body if -H is specified return if $opts{'H'}; # Print whatever body we've read already. print $$email_body; } } #------------------------------------------------------------------------------- # Checks to see if the date in the header matches the date specification. The # date specification can be $NODATE, meaning that the email doesn't have # a Date: line. sub Email_Matches_Date { my $email_header = shift @_; my $endline = shift; die unless ref $email_header; return 1 unless defined $opts{'d'}; return 0 if $dateRestriction == $NODATE; my $received_header = Get_Header_Field($email_header, 'Received:',$endline); my $date_header = Get_Header_Field($email_header, 'Date:',$endline); my $subject_header = Get_Header_Field($email_header, 'Subject:',$endline); my $from_header = Get_Header_Field($email_header, 'From ',$endline); # Collect different date header values. We'll try each one until # we find a value that parses. my @dateValues = (); push(@dateValues, $1) if $opts{'a'} && defined $received_header && $received_header =~ /.*\;\s*(.*?)$/s; push(@dateValues, $1) if defined $date_header && $date_header =~ /^[^:]*:\s*(.*)$/s; push(@dateValues, $1) if defined $from_header && $from_header =~ /^[^ ]*\s*\S+\s+(.*)$/s; unless (scalar(@dateValues) > 0) { warn "grepmail: Couldn't find a date. Assuming email doesn't match the " . "date constraint:\n"; warn " $from_header\n" if defined $from_header; warn " $subject_header\n" if defined $subject_header; return 0; } foreach my $date (@dateValues) { $date =~ s/$endline//g; } my $emailDate = undef; foreach my $date (@dateValues) { dprint("Trying to parse date: $date"); $emailDate = str2time($date); last if defined($emailDate); } return Is_In_Date($emailDate,$dateRestriction,$date1,$date2) if defined $emailDate; warn "grepmail: Couldn't parse email date(s) [" . join("|", @dateValues) . "]. " . "Assuming message doesn't match the date constraint\n"; warn " $from_header\n" if defined $from_header; warn " $subject_header\n" if defined $subject_header; return 0; } #------------------------------------------------------------------------------- # This function tries to parse a date first with Date::Parse. If Date::Parse # can't parse the date, then the function tries to use Date::Manip to parse # it. Returns the parsed date in unix time format, or undef if it can't be # parsed. sub Parse_Date { my $date = shift; # First try to parse the date with Date::Parse; { my $parsedDate = str2time($date); return $parsedDate if defined $parsedDate; } # Then try Date::Manip, if it is installed if (defined $Date::Manip::VERSION) { my $parsedDate = Date::Manip::UnixDate(Date::Manip::ParseDate($date),'%s'); return $parsedDate if defined $parsedDate; } return undef; } #------------------------------------------------------------------------------- # Figure out what kind of date restriction they want, and what the dates in # question are. An empty date string results in the type of date restriction # being $NODATE. sub Process_Date($) { my $datestring = shift; return ($NODATE,'','') if $datestring eq ''; if ($datestring =~ /^before (.*)/i) { $dateRestriction = $BEFORE; $date1 = Parse_Date($1); $date2 = ''; Report_And_Exit "\"$1\" is not a valid date" unless defined $date1; } elsif ($datestring =~ /^(after|since)\s(.*)/i) { $dateRestriction = $AFTER; $date1 = Parse_Date($2); Report_And_Exit "\"$2\" is not a valid date" unless defined $date1; $date2 = ''; } elsif ($datestring =~ /^between (.+) and (.+)/i) { $dateRestriction = $BETWEEN; $date1 = Parse_Date($1); $date2 = Parse_Date($2); Report_And_Exit "\"$1\" is not a valid date" unless defined $date1; Report_And_Exit "\"$2\" is not a valid date" unless defined $date2; # Swap the dates if the user gave them backwards. if ($date1 > $date2) { my $temp; $temp = $date1; $date1 = $date2; $date2 = $temp; } } else { $dateRestriction = $BETWEEN; ($date1,$date2) = Parse_Date_Span($datestring); Report_And_Exit "\"$datestring\" is an invalid date specification. Use \"$0 --help\" for help" unless defined $date1; } return ($dateRestriction,$date1,$date2); } #------------------------------------------------------------------------------- sub Parse_Date_Span { my $datestring = shift; # @parsed_time == ($ss,$mm,$hh,$day,$month,$year,$zone) my @parsed_time = Date_Parse_strptime($datestring); @parsed_time = Date_Manip_strptime($datestring) if !@parsed_time && defined $Date::Manip::VERSION; # For "jan 2004" if (defined $parsed_time[3] && $parsed_time[3] > 31 && !defined $parsed_time[5]) { $parsed_time[5] = $parsed_time[3] - 1900; $parsed_time[3] = undef; } return (undef,undef) unless grep { defined } @parsed_time; # @current_time == ($ss,$mm,$hh,$day,$month,$year,$zone) my @current_time = ((localtime(time))[0..5],$parsed_time[-1]); # Starting from the largest time unit, set it to the current value as long # as it's undefined. for (my $i = -1; !defined($parsed_time[$i]); $i--) { $parsed_time[$i] = $current_time[$i]; } my @date1 = @parsed_time; my $increment_unit = 1; # Set the low date and the increment unit. Starting from the smallest time # unit, set it to the smallest value as long as it's undefined. unless (defined $date1[0]) { $date1[0] = 0; $increment_unit *= 60; unless (defined $date1[1]) { $date1[1] = 0; $increment_unit *= 60; unless (defined $date1[2]) { $date1[2] = 0; $increment_unit *= 24; unless (defined $date1[3]) { $date1[3] = 1; if (defined $date1[4]) { $increment_unit *= Number_Of_Days_In_Month($date1[4],$date1[5]); } else { $date1[4] = 0; $increment_unit *= Number_Of_Days_In_Year($date1[5]); } } } } } my $date1 = timelocal(@date1); my $date2 = timelocal(@date1)+$increment_unit; return ($date1,$date2); } #------------------------------------------------------------------------------- # http://groups.google.com/groups?selm=8FA9D001darkononenet%40206.112.192.118 # $month: 0..11; $year: CCYY sub Number_Of_Days_In_Month { my ($month, $year) = @_; ( qw(31 0 31 30 31 30 31 31 30 31 30 31) )[$month] || 28 + (($year % 100 && !($year % 4))|| !($year % 400)); } #------------------------------------------------------------------------------- sub Number_Of_Days_In_Year { my $year = @_; 365 + (($year % 100 && !($year % 4))|| !($year % 400)); } #------------------------------------------------------------------------------- sub Date_Parse_strptime { my $datestring = shift; my @parsed_time = strptime($datestring); return () unless @parsed_time; if (defined $parsed_time[3] && $parsed_time[3] > 31 && !defined $parsed_time[5]) { $parsed_time[5] = $parsed_time[3] - 1900; $parsed_time[3] = undef; } # @current_time == ($ss,$mm,$hh,$day,$month,$year,$zone) my @current_time = ((localtime(time))[0..5],$parsed_time[-1]); # Starting from the largest time unit, set it to the current value as long # as it's undefined. for (my $i = -1; !defined($parsed_time[$i]); $i--) { $parsed_time[$i] = $current_time[$i]; } foreach my $item (@parsed_time) { next unless defined $item; $item =~ s/^0+//; $item = 0 if $item eq ''; $item += 0 if $item =~ /^\d+$/; } return @parsed_time; } #------------------------------------------------------------------------------- sub Date_Manip_strptime { my $datestring = shift; my @parsed_time = Date::Manip::UnixDate(Date::Manip::ParseDate($datestring), '%S','%M','%H','%d','%m','%Y','%Z'); return () unless @parsed_time; { my $old_tz = $Date::Manip::Cnf{"TZ"}; my $parsed_time = Date::Manip::ParseDate($datestring); $Date::Manip::Cnf{"TZ"} = 'CST'; my $tz_test_1 = Date::Manip::ParseDate($datestring); $Date::Manip::Cnf{"TZ"} = 'EST'; my $tz_test_2 = Date::Manip::ParseDate($datestring); # Different lines so that CVS doesn't insert the date $Date::Manip::Cnf{"TZ"} = $old_tz; if ($parsed_time eq $tz_test_1 && $parsed_time eq $tz_test_2) { $parsed_time[-1] = undef; } } foreach my $item (@parsed_time) { next unless defined $item; $item =~ s/^0+//; $item = 0 if $item eq ''; $item += 0 if $item =~ /^\d+$/; } $parsed_time[4] -= 1 if defined $parsed_time[4]; $parsed_time[5] -= 1900 if defined $parsed_time[5]; # This is not quite correct, because we can't tell when Date::Manip sets the # time to 0 and when the user specifies it explicitely at 0:00:00. if ($parsed_time[0] == 0 && $parsed_time[1] == 0 && $parsed_time[2] == 0) { $parsed_time[0] = $parsed_time[1] = $parsed_time[2] = undef; } #Until 'Date::Manip::Date_Init("TodayIsMidnight=1");' is released if ($datestring eq 'today' || $datestring eq 'now' || $datestring eq 'yesterday') { $parsed_time[0] = $parsed_time[1] = $parsed_time[2] = undef; } return @parsed_time; } #------------------------------------------------------------------------------- # Figure out what kind of size restriction they want, and what the sizes in # question are. sub Process_Size($) { my $sizestring = shift; if ($sizestring =~ /^\s*(<|<=|>|>=)\s*(\d+)\s*$/i) { if ($1 eq '<') { $sizeRestriction = $LESS_THAN; } elsif ($1 eq '<=') { $sizeRestriction = $LESS_THAN_OR_EQUAL; } elsif ($1 eq '>') { $sizeRestriction = $GREATER_THAN; } elsif ($1 eq '>=') { $sizeRestriction = $GREATER_THAN_OR_EQUAL; } $size1 = $2; $size2 = ''; } elsif ($sizestring =~ /^\s*(\d+)\s*-\s*(\d+)\s*$/i) { $sizeRestriction = $BETWEEN; $size1 = $1; $size2 = $2; # Swap the sizes if the user gave them backwards. if ($size1 > $size2) { my $temp; $temp = $size1; $size1 = $size2; $size2 = $temp; } } elsif ($sizestring =~ /^\s*(\d+)\s*$/i) { $sizeRestriction = $EQUAL; $size1 = $1; $size2 = ''; } else { Report_And_Exit "\"$sizestring\" is an invalid size specification. Use \"$0 --help\" for help"; } return ($sizeRestriction,$size1,$size2); } #------------------------------------------------------------------------------- sub Is_In_Date($$$$) { my $emailDate = shift @_; my $dateRestriction = shift @_; my $date1 = shift @_; my $date2 = shift @_; # Now we do the date checking. return 1 if $dateRestriction == $NONE; return $emailDate < $date1 if $dateRestriction == $BEFORE; return $emailDate > $date1 if $dateRestriction == $AFTER; return $emailDate > $date1 && $emailDate < $date2 if $dateRestriction == $BETWEEN; return 0; } #------------------------------------------------------------------------------- sub Is_In_Size { my $email_header = shift @_; my $email_body = shift @_; my $sizeRestriction = shift @_; my $size1 = shift @_; my $size2 = shift @_; die unless ref $email_header && ref $email_body; my $length = length($$email_header) + length($$email_body); # Now we do the size checking. return 1 if $sizeRestriction == $NONE; return $length < $size1 if $sizeRestriction == $LESS_THAN; return $length <= $size1 if $sizeRestriction == $LESS_THAN_OR_EQUAL; return $length > $size1 if $sizeRestriction == $GREATER_THAN; return $length >= $size1 if $sizeRestriction == $GREATER_THAN_OR_EQUAL; return $length == $size1 if $sizeRestriction == $EQUAL; return $length >= $size1 && $length <= $size2 if $sizeRestriction == $BETWEEN; return 0; } #------------------------------------------------------------------------------- sub usage { <] [-j ] [-s ] [-d ] [-X ] [-Y ] [-e] grepmail [--help|--version] [-abBDFhHilmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] -E grepmail [--help|--version] [-abBDFhHilmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] -f At least one of -s, -d, -u, -e, and -E must be specified, and can appear in any relative order following the other flags. The -e flag is optional if pattern appears immediately before -s or -d. Files can be plain ASCII or ASCII files compressed with gzip, tzip, or bzip2. -E allows for complex pattern matches involving logical operators. If no file is provided, normal or compressed ASCII input is taken from STDIN. -a Use received date instead of sent date for -d matching -b Search must match body -B Print message bodies but with only limited headers -C Specify the location of the cache file -d Specify a required date range (see below) -D Debug mode -e Explicitly name pattern (when searching for strings beginning with "-") -E Specify a complex search expression -f Read patterns from a file -F Force processing of all data as mailboxes -h Search must match header -H Print headers but not bodies of matching emails -i Ignore case in the search expression -j Search must match status (A=answered, R=read, D=deleted, O=old, F=flagged) -l Output the names of files having an email matching the expression -M Do not search non-text mime attachments -m Append "X-Mailfolder: " to all headers to indicate in which folder the match occurred -n Print the line number info (and filename if necessary) for the emails -q Quiet mode -- don't output warnings -r Output the names of the files and the number of emails matching the expression -R Recurse directories -s Specify a size range in bytes (see below) -S Ignore signatures -u Ensure that no duplicate emails are output -v Output emails that don't match the expression -V Display the version number -w Match word boundaries -X Specify a regular expression for the signature separator -Y Specify a header to search (implies -h) --help Print a help message Date constraints require Date::Parse. Date specifications must be of the form of: - a date like "today", "1st thursday in June 1992" (requires Date::Manip), "05/18/93", "12:30 Dec 12th 1880", "8:00pm december tenth", - "before", "after", or "since", followed by a date as defined above, - "between and ", where is defined as above. Size constraints must be of the form of: - 12345: match size of exactly 12345 - <12345, <=12345, >12345, >=12345: match size less than, less than or equal, greater than, or greater than or equal to 12345 - 10000-12345: match size between 10000 and 12345 inclusive EOF } #------------------------------------------------------------------------------- =head1 NAME grepmail - search mailboxes for mail matching a regular expression =head1 SYNOPSIS grepmail [--help|--version] [-abBDFhHilmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] [-e] grepmail [--help|--version] [-abBDFhHilmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] -E grepmail [--help|--version] [-abBDFhHilmrRuvVw] [-C ] [-j ] [-s ] [-d ] [-X ] [-Y ] -f =head1 DESCRIPTION =over 2 I looks for mail messages containing a pattern, and prints the resulting messages on standard out. By default I looks in both header and body for the specified pattern. When redirected to a file, the result is another mailbox, which can, in turn, be handled by standard User Agents, such as I, or even used as input for another instance of I. At least one of B<-E>, B<-e>, B<-d>, B<-s>, or B<-u> must be specified. The pattern is optional if B<-d>, B<-s>, and/or B<-u> is used. The B<-e> flag is optional if there is no file whose name is the pattern. The B<-E> option can be used to specify complex search expressions involving logical operators. (See below.) If a mailbox can not be found, grepmail first searches the directory specified by the MAILDIR environment variable (if one is defined), then searches the $HOME/mail, $HOME/Mail, and $HOME/Mailbox directories. =back =head1 OPTIONS AND ARGUMENTS Many of the options and arguments are analogous to those of grep. =over 2 =item B The pattern to search for in the mail message. May be any Perl regular expression, but should be quoted on the command line to protect against globbing (shell expansion). To search for more than one pattern, use the form "(pattern1|pattern2|...)". Note that complex pattern features such as "(?>...)" require that you use a version of perl which supports them. You can use the pattern "()" to indicate that you do not want to match anything. This is useful if you want to initialize the cache without printing any output. =item B Mailboxes must be traditional, UNIX C mailbox format. The mailboxes may be compressed by gzip, tzip, or bzip2, in which case gunzip, tzip, or bzip2 must be installed on the system. If no mailbox is specified, takes input from stdin, which can be compressed or not. grepmail's behavior is undefined when ASCII and binary data is piped together as input. =item B<-a> Use arrival date instead of sent date. =item B<-b> Asserts that the pattern must match in the body of the email. =item B<-B> Print the body but with only minimal ('From ', 'From:', 'Subject:', 'Date:') headers. This flag can be used with -H, in which case it will print only short headers and no email bodies. =item B<-C> Specifies the location of the cache file. The default is $HOME/.grepmail-cache. =item B<-D> Enable debug mode, which prints diagnostic messages. =item B<-d> Date specifications must be of the form of: - a date like "today", "yesterday", "5/18/93", "5 days ago", "5 weeks ago", - OR "before", "after", or "since", followed by a date as defined above, - OR "between and ", where is defined as above. Simple date expressions will first be parsed by Date::Parse. If this fails, grepmail will attempt to parse the date with Date::Manip, if the module is installed on the system. Use an empty pattern (i.e. B<-d "">) to find emails without a "Date: ..." line in the header. Date specifications without times are interpreted as having a time of midnight of that day (which is the morning), except for "after" and "since" specifications, which are interpreted as midnight of the following day. For example, "between today and tomorrow" is the same as simply "today", and returns emails whose date has the current day. ("now" is interpreted as "today".) The date specification "after July 5th" will return emails whose date is midnight July 6th or later. =item B<-E> Specify a complex search expression using logical operators. The current syntax allows the user to specify search expressions using Perl syntax. Three values can be used: $email (the entire email message), $email_header (just the header), or $email_body (just the body). A search is specified in the form "$email =~ /pattern/", and multiple searches can be combined using "&&" and "||" for "and" and "or". For example, the expression $email_header =~ /^From: .*\@coppit.org/ && $email =~ /grepmail/i will find all emails which originate from coppit.org (you must escape the "@" sign with a backslash), and which contain the keyword "grepmail" anywhere in the message, in any capitalization. B<-E> is incompatible with B<-b>, B<-h>, and B<-e>. B<-i>, B<-M>, B<-S>, and B<-Y> have not yet been implemented. NOTE: The syntax of search expressions may change in the future. In particular, support for size, date, and other constraints may be added. The syntax may also be simplified in order to make expression formation easier to use (and perhaps at the expense of reduced functionality). =item B<-e> Explicitly specify the search pattern. This is useful for specifying patterns that begin with "-", which would otherwise be interpreted as a flag. =item B<-f> Obtain patterns from FILE, one per line. The empty file contains zero patterns, and therefore matches nothing. =item B<-F> Force grepmail to process all files and streams as though they were mailboxes. (i.e. Skip checks for non-mailbox ASCII files or binary files that don't look like they are compressed using known schemes.) =item B<-h> Asserts that the pattern must match in the header of the email. =item B<-H> Print the header but not body of matching emails. =item B<-i> Make the search case-insensitive (by analogy to I). =item B<-j> Asserts that the email "Status:" header must contain the given flags. Order and case are not important, so use I<-j AR> or I<-j ra> to search for emails which have been read and answered. =item B<-l> Output the names of files having an email matching the expression, (by analogy to I). =item B<-M> Causes grepmail to ignore non-text MIME attachments. This removes false positives resulting from binaries encoded as ASCII attachments. =item B<-m> Append "X-Mailfolder: " to all email headers, indicating which folder contained the matched email. =item B<-n> Prefix each line with line number information. If multiple files are specified, the filename will precede the line number. NOTE: When used in conjunction with B<-m>, the X-Mailfolder header has the same line number as the next (blank) line. =item B<-q> Quiet mode. Suppress the output of warning messages about non-mailbox files, directories, etc. =item B<-r> Generate a report of the names of the files containing emails matching the expression, along with a count of the number of matching emails. =item B<-R> Causes grepmail to recurse any directories encountered. =item B<-s> Return emails which match the size (in bytes) specified with this flag. Note that this size includes the length of the header. Size constraints must be of the form of: - 12345: match size of exactly 12345 - <12345, <=12345, >12345, >=12345: match size less than, less than or equal, greater than, or greater than or equal to 12345 - 10000-12345: match size between 10000 and 12345 inclusive =item B<-S> Ignore signatures. The signature consists of everything after a line consisting of "-- ". =item B<-u> Output only unique emails, by analogy to I. Grepmail determines email uniqueness by the Message-ID header. =item B<-v> Invert the sense of the search, by analogy to I. This results in the set of emails printed being the complement of those that would be printed without the B<-v> switch. =item B<-V> Print the version and exit. =item B<-w> Search for only those lines which contain the pattern as part of a word group. That is, the start of the pattern must match the start of a word, and the end of the pattern must match the end of a word. (Note that the start and end need not be for the I word.) If you are familiar with Perl regular expressions, this flag simply puts a "\b" before and after the search pattern. =item B<-X> Specify a regular expression for the signature separator. By default this pattern is '^-- $'. =item B<-Y> Specify a pattern which indicates specific headers to be searched. The search will automatically treat headers which span multiple lines as one long line. This flag implies B<-h>. In the style of procmail, special strings in the pattern will be expanded as follows: =over 2 If the regular expression contains "^TO:" it will be substituted by ^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope|Apparently(-Resent)?)-To): which should match all headers with destination addresses. If the regular expression contains "^FROM_DAEMON:" it will be substituted by (^(Mailing-List:|Precedence:.*(junk|bulk|list)|To: Multiple recipients of |(((Resent-)?(From|Sender)|X-Envelope-From):|>?From )([^>]*[^(.%@a-z0-9])?(Post(ma?(st(e?r)?|n)|office)|(send)?Mail(er)?|daemon|m(mdf|ajordomo)|n?uucp|LIST(SERV|proc)|NETSERV|o(wner|ps)|r(e(quest|sponse)|oot)|b(ounce|bs\.smtp)|echo|mirror|s(erv(ices?|er)|mtp(error)?|ystem)|A(dmin(istrator)?|MMGR|utoanswer))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t ][^<)]*(\(.*\).*)?)? which should catch mails coming from most daemons. If the regular expression contains "^FROM_MAILER:" it will be substituted by (^(((Resent-)?(From|Sender)|X-Envelope-From):|>?From)([^>]*[^(.%@a-z0-9])?(Post(ma(st(er)?|n)|office)|(send)?Mail(er)?|daemon|mmdf|n?uucp|ops|r(esponse|oot)|(bbs\.)?smtp(error)?|s(erv(ices?|er)|ystem)|A(dmin(istrator)?|MMGR))(([^).!:a-z0-9][-_a-z0-9]*)?[%@>\t][^<)]*(\(.*\).*)?)?$([^>]|$)) (a stripped down version of "^FROM_DAEMON:"), which should catch mails coming from most mailer-daemons. =back =item B<--help> Print a help message summarizing the usage. =item B<--> All arguments following I<--> are treated as mail folders. =back =head1 EXAMPLES Count the number of emails. ("." matches every email.) grepmail -r . sent-mail Get all email between 2000 and 3000 bytes about books grepmail books -s 2000-3000 sent-mail Get all email that you mailed yesterday grepmail -d yesterday sent-mail Get all email that you mailed before the first thursday in June 1998 that pertains to research (requires Date::Manip): grepmail research -d "before 1st thursday in June 1992" sent-mail Get all email that you mailed before the first of June 1998 that pertains to research: grepmail research -d "before 6/1/92" sent-mail Get all email you received since 8/20/98 that wasn't about research or your job, ignoring case: grepmail -iv "(research|job)" -d "since 8/20/98" saved-mail Get all email about mime but not about Netscape. Constrain the search to match the body, since most headers contain the text "mime": grepmail -b mime saved-mail | grepmail Netscape -v Print a list of all mailboxes containing a message from Rodney. Constrain the search to the headers, since quoted emails may match the pattern: grepmail -hl "^From.*Rodney" saved-mail* Find all emails with the text "Pilot" in both the header and the body: grepmail -hb "Pilot" saved-mail* Print a count of the number of messages about grepmail in all saved-mail mailboxes: grepmail -br grepmail saved-mail* Remove any duplicates from a mailbox: grepmail -u saved-mail Convert a Gnus mailbox to mbox format: grepmail . gnus-mailbox-dir/* > mbox Search for all emails to or from an address (taking into account wrapped headers and different header names): grepmail -Y '(^TO:|^From:)' my@email.address saved-mail Find all emails from postmasters: grepmail -Y '^FROM_MAILER:' . saved-mail =head1 FILES grepmail will I create temporary files while decompressing compressed archives. The last version to do this was 3.5. While the new design uses more memory, the code is much simpler, and there is less chance that email can be read by malicious third parties. Memory usage is determined by the size of the largest email message in the mailbox. =head1 ENVIRONMENT The MAILDIR environment variable can be used to specify the default mail directory. This directory will be searched if the specified mailbox can not be found directly. The HOME environment variable is also used to find mailboxes if they can not be found directly. It is also used to store grepmail state information such as its cache file. =head1 BUGS AND LIMITATIONS =over 2 =item Patterns containing "$" may cause problems Currently I look for "$" followed by a non-word character and replace it with the line ending for the current file (either "\n" or "\r\n"). This may cause problems with complex patterns specified with -E, but I'm not aware of any. =item Mails without bodies cause problems According to RFC 822, mail messages need not have message bodies. I've found and removed one bug related to this. I'm not sure if there are others. =item Complex single-point dates not parsed correctly If you specify a point date like "September 1, 2004", grepmail creates a date range that includes the entire day of September 1, 2004. If you specify a complex point date such as "today", "1st Monday in July", or "9/1/2004 at 0:00" grepmail may parse the time incorrectly. The reason for this problem is that Date::Manip, as of version 5.42, forces default values for parsed dates and times. This means that grepmail has a hard time determining whether the user supplied certain time/date fields. (e.g. Did Date::Manip provide a default time of 0:00, or did the user specify it?) grepmail tries to work around this problem, but the workaround is inherently incomplete in some rare cases. =item File names that look like flags cause problems. In some special circumstances, grepmail will be confused by files whose names look like flags. In such cases, use the B<-e> flag to specify the search pattern. =back =head1 AUTHOR David Coppit, , http://coppit.org/ =head1 SEE ALSO elm(1), mail(1), grep(1), perl(1), printmail(1), Mail::Internet(3), procmailrc(5). Crocker, D. H., Standard for the Format of Arpa Internet Text Messages, RFC 822. =cut grepmail-5.3033/inc/0000755000076500001200000000000010571626331013327 5ustar coppitadmingrepmail-5.3033/inc/base.pm0000644000076500001200000000773210571626323014611 0ustar coppitadmin#line 1 "inc/base.pm - /System/Library/Perl/5.8.6/base.pm" package base; use strict 'vars'; use vars qw($VERSION); $VERSION = '2.06'; # constant.pm is slow sub SUCCESS () { 1 } sub PUBLIC () { 2**0 } sub PRIVATE () { 2**1 } sub INHERITED () { 2**2 } sub PROTECTED () { 2**3 } my $Fattr = \%fields::attr; sub has_fields { my($base) = shift; my $fglob = ${"$base\::"}{FIELDS}; return( ($fglob && *$fglob{HASH}) ? 1 : 0 ); } sub has_version { my($base) = shift; my $vglob = ${$base.'::'}{VERSION}; return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 ); } sub has_attr { my($proto) = shift; my($class) = ref $proto || $proto; return exists $Fattr->{$class}; } sub get_attr { $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; return $Fattr->{$_[0]}; } if ($] < 5.009) { *get_fields = sub { # Shut up a possible typo warning. () = \%{$_[0].'::FIELDS'}; my $f = \%{$_[0].'::FIELDS'}; # should be centralized in fields? perhaps # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' } # is used here anyway, it doesn't matter. bless $f, 'pseudohash' if (ref($f) ne 'pseudohash'); return $f; } } else { *get_fields = sub { # Shut up a possible typo warning. () = \%{$_[0].'::FIELDS'}; return \%{$_[0].'::FIELDS'}; } } sub import { my $class = shift; return SUCCESS unless @_; # List of base classes from which we will inherit %FIELDS. my $fields_base; my $inheritor = caller(0); foreach my $base (@_) { next if $inheritor->isa($base); if (has_version($base)) { ${$base.'::VERSION'} = '-1, set by base.pm' unless defined ${$base.'::VERSION'}; } else { local $SIG{__DIE__} = 'IGNORE'; eval "require $base"; # Only ignore "Can't locate" errors from our eval require. # Other fatal errors (syntax etc) must be reported. die if $@ && $@ !~ /^Can't locate .*? at \(eval /; unless (%{"$base\::"}) { require Carp; Carp::croak(<[0] = @$battr; if( keys %$dfields ) { warn "$derived is inheriting from $base but already has its own ". "fields!\n". "This will cause problems.\n". "Be sure you use base BEFORE declaring fields\n"; } # Iterate through the base's fields adding all the non-private # ones to the derived class. Hang on to the original attribute # (Public, Private, etc...) and add Inherited. # This is all too complicated to do efficiently with add_fields(). while (my($k,$v) = each %$bfields) { my $fno; if ($fno = $dfields->{$k} and $fno != $v) { require Carp; Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); } if( $battr->[$v] & PRIVATE ) { $dattr->[$v] = PRIVATE | INHERITED; } else { $dattr->[$v] = INHERITED | $battr->[$v]; $dfields->{$k} = $v; } } foreach my $idx (1..$#{$battr}) { next if defined $dattr->[$idx]; $dattr->[$idx] = $battr->[$idx] & INHERITED; } } 1; __END__ #line 227 grepmail-5.3033/inc/ExtUtils/0000755000076500001200000000000010571626331015110 5ustar coppitadmingrepmail-5.3033/inc/ExtUtils/AutoInstall.pm0000644000076500001200000004343010571626324017713 0ustar coppitadmin#line 1 "inc/ExtUtils/AutoInstall.pm - /Library/Perl/5.8.1/ExtUtils/AutoInstall.pm" # $File: //member/autrijus/ExtUtils-AutoInstall/lib/ExtUtils/AutoInstall.pm $ # $Revision: #14 $ $Change: 10538 $ $DateTime: 2004/04/29 17:55:36 $ vim: expandtab shiftwidth=4 package ExtUtils::AutoInstall; $ExtUtils::AutoInstall::VERSION = '0.59'; use strict; use Cwd (); use ExtUtils::MakeMaker (); #line 308 # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my (@Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS); my ($Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly); my ($PostambleActions, $PostambleUsed); _accept_default(!-t STDIN); # see if it's a non-interactive session _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config}], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg (@ARGV, split(/[\s\t]+/, $ENV{PERL_EXTUTILS_AUTOINSTALL} || '')) { if ($arg =~ /^--config=(.*)$/) { $Config = [ split(',', $1) ]; } elsif ($arg =~ /^--installdeps=(.*)$/) { __PACKAGE__->install($Config, @Missing = split(/,/, $1)); exit 0; } elsif ($arg =~ /^--default(?:deps)?$/) { $AcceptDefault = 1; } elsif ($arg =~ /^--check(?:deps)?$/) { $CheckOnly = 1; } elsif ($arg =~ /^--skip(?:deps)?$/) { $SkipInstall = 1; } elsif ($arg =~ /^--test(?:only)?$/) { $TestOnly = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ($prompt, $default) = @_; my $y = ($default =~ /^[Yy]/); print $prompt, ' [', ($y ? 'Y' : 'y'), '/', ($y ? 'n' : 'N'), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version ".$class->VERSION."\n"; print "*** Checking for dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length((sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? keys %{ref($_) eq 'HASH' ? $_ : +{@{$_}}} : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{+{@args}})[0]); while (my ($feature, $modules) = splice(@args, 0, 2)) { my (@required, @tests, @skiptests); my $default = 1; my $conflict = 0; if ($feature =~ m/^-(\w+)$/) { my $option = lc($1); # check for a newer version of myself _update_to($modules, @_) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ($modules =~ /^all$/i) and next if $option eq 'core'; next unless $option eq 'core'; } print "[".($FeatureMap{lc($feature)} || $feature)."]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa($modules, 'HASH'); unshift @$modules, -default => &{shift(@$modules)} if (ref($modules->[0]) eq 'CODE'); # XXX: bugward combatability while (my ($mod, $arg) = splice(@$modules, 0, 2)) { if ($mod =~ m/^-(\w+)$/) { my $option = lc($1); $default = $arg if ($option eq 'default'); $conflict = $arg if ($option eq 'conflict'); @tests = @{$arg} if ($option eq 'tests'); @skiptests = @{$arg} if ($option eq 'skiptests'); next; } printf("- %-${maxlen}s ...", $mod); # XXX: check for conflicts and uninstalls(!) them. if (defined(my $cur = _version_check(_load($mod), $arg ||= 0))) { print "loaded. ($cur".($arg ? " >= $arg" : '').")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { print "missing." . ($arg ? " (would need $arg)" : '') . "\n"; push @required, $mod => $arg; } } next unless @required; my $mandatory = ($feature eq '-core' or $core_all); if (!$SkipInstall and ($CheckOnly or _prompt( qq{==> Auto-install the }. (@required / 2). ($mandatory ? ' mandatory' : ' optional'). qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/)) { push (@Missing, @required); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif (!$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/) { push (@Missing, @required); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } _check_lock(); # check for $UnderCPAN if (@Missing and not ($CheckOnly or $UnderCPAN)) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; } # CPAN.pm is non-reentrant, so check if we're under it and have no CPANPLUS sub _check_lock { return unless @Missing; return if _has_cpanplus(); require CPAN; CPAN::Config->load; my $lock = MM->catfile($CPAN::Config->{cpan_home}, ".lock"); if (-f $lock and open(LOCK, $lock) and ($^O eq 'MSWin32' ? _under_cpan() : == getppid()) and ($CPAN::Config->{prerequisites_policy} || '') ne 'ignore' ) { print << '.'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. . $UnderCPAN = 1; } close LOCK; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = (map { s/^-// if ++$i; $_ } @{+shift}); my (@modules, @installed); while (my ($pkg, $ver) = splice(@_, 0, 2)) { # grep out those already installed if (defined(_version_check(_load($pkg), $ver))) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ($args{do_once} and open(FAILED, '.#autoinstall.failed')) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while (my ($k, $v) = splice(@modules, 0, 2)) { push @newmod, ($k => $v) unless $failed{$k}; } @modules = @newmod; } if (_has_cpanplus()) { _install_cpanplus(\@modules, \@config); } else { _install_cpan(\@modules, \@config); } print "*** $class installation finished.\n"; # see if we have successfully installed them while (my ($pkg, $ver) = splice(@modules, 0, 2)) { if (defined(_version_check(_load($pkg), $ver))) { push @installed, $pkg; } elsif ($args{do_once} and open(FAILED, '>> .#autoinstall.failed')) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{+shift}; my @config = @{+shift}; my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless _can_write($conf->_get_build('base')); # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if (UNIVERSAL::isa($makeflags, 'HASH')) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join(' ', split(' ', $makeflags), 'UNINST=1') if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' }); } $conf->set_conf(makeflags => $makeflags); $conf->set_conf(prereqs => 1); while (my ($key, $val) = splice(@config, 0, 2)) { eval { $conf->set_conf($key, $val) }; } my $modtree = $cp->module_tree; while (my ($pkg, $ver) = splice(@modules, 0, 2)) { print "*** Installing $pkg...\n"; MY::preinstall($pkg, $ver) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ($obj and defined(_version_check($obj->{version}, $ver))) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ]); if ($rv and ($rv->{$obj->{module}} or $rv->{ok})) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall; } return $installed; } sub _install_cpan { my @modules = @{+shift}; my @config = @{+shift}; my $installed = 0; my %args; require CPAN; CPAN::Config->load; return unless _can_write(MM->catfile($CPAN::Config->{cpan_home}, 'sources')); # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join(' ', split(' ', $makeflags), 'UNINST=1') if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' }); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while (my ($opt, $arg) = splice(@config, 0, 2)) { ($args{$opt} = $arg, next) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while (my ($pkg, $ver) = splice(@modules, 0, 2)) { MY::preinstall($pkg, $ver) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand(Module => $pkg); my $success = 0; if ($obj and defined(_version_check($obj->cpan_version, $ver))) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) { delete $INC{$inc}; } $obj->force('install') if $args{force}; my $rv = $obj->install || eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )->{install} }; if ($rv eq 'YES') { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath(Cwd::cwd()); my $cpan = File::Spec->canonpath($CPAN::Config->{cpan_home}); return (index($cwd, $cpan) > -1); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if defined(_version_check(_load($class), $ver)); # no need to upgrade if (_prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install([], $class, $ver); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir ($path, 0755) unless -e $path; require Config; return 1 if -w $path and -w $Config::Config{sitelib}; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if (eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), 'y' ) =~ /^[Yy]/) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join(',', @Missing); my $config = join(',', UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config} ) if $Config; return unless system('sudo', $^X, $0, "--config=$config", "--installdeps=$missing"); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt(qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ($@ ? undef : 0); } # compare two versions, either use Sort::Versions or plain comparison sub _version_check { my ($cur, $min) = @_; return unless defined $cur; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if (ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./) { if ($version::VERSION or defined(_load('version'))) { # use version.pm if it is installed. return ((version->new($cur) >= version->new($min)) ? $cur : undef); } elsif ($Sort::Versions::VERSION or defined(_load('Sort::Versions'))) { # use Sort::Versions as the sorting algorithm for a.b.c versions return ((Sort::Versions::versioncmp($cur, $min) != -1) ? $cur : undef); } warn "Cannot reliably compare non-decimal formatted versions.\n". "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return ($cur >= $min ? $cur : undef); } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{$args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ($args{EXE_FILES}) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{$args{EXE_FILES}} ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join(' ', grep { !exists($DisabledTests{$_}) } map { glob($_) } split(/\s+/, $args{test}{TESTS})); my $missing = join(',', @Missing); my $config = join(',', UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( $missing ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\@\$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from ExtUtils::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return << "."; config :: installdeps \t\@\$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions . } 1; __END__ #line 969 grepmail-5.3033/inc/File/0000755000076500001200000000000010571626331014206 5ustar coppitadmingrepmail-5.3033/inc/File/HomeDir/0000755000076500001200000000000010571626331015535 5ustar coppitadmingrepmail-5.3033/inc/File/HomeDir/Darwin.pm0000644000076500001200000000462310571626323017325 0ustar coppitadmin#line 1 "inc/File/HomeDir/Darwin.pm - /Library/Perl/5.8.6/File/HomeDir/Darwin.pm" package File::HomeDir::Darwin; # Basic implementation for the Dawin family of operating systems. # This includes (most prominently) Mac OS X. use 5.005; use strict; use base 'File::HomeDir::Unix'; use Carp (); use vars qw{$VERSION}; BEGIN { $VERSION = '0.58'; } ##################################################################### # Current User Methods # sub my_home (no change) sub my_desktop { my $class = shift; # On Darwin the desktop should live at ~/Desktop SCOPE: { my $dir = $class->_to_desktop( $class->my_home ); return $dir if $dir; } Carp::croak("Could not locate current user's desktop"); } sub my_documents { my $class = shift; # On Darwin the desktop should live at ~/Documents SCOPE: { my $dir = $class->_to_documents( $class->my_home ); return $dir if $dir; } Carp::croak("Could not locate current user's documents"); } sub my_data { my $class = shift; # On Darwin the desktop should live at ~/Library/Application Support SCOPE: { my $dir = $class->_to_data( $class->my_home ); return $dir if $dir; } Carp::croak("Could not locate current user's application data"); } ##################################################################### # Arbitrary User Methods # sub users_home (no change) sub users_desktop { my $class = shift; # On Darwin the desktop should live at ~/Documents SCOPE: { my $dir = $class->_to_desktop( $class->users_home(@_) ); return $dir if $dir; } Carp::croak("Could not locate user's desktop"); } sub users_documents { my $class = shift; # On Darwin the desktop should live at ~/Documents SCOPE: { my $dir = $class->_to_documents( $class->users_home(@_) ); return $dir if $dir; } Carp::croak("Could not locate user's desktop"); } sub users_data { my $class = shift; # On Darwin the desktop should live at ~/Documents SCOPE: { my $dir = $class->_to_data( $class->users_home(@_) ); return $dir if $dir; } Carp::croak("Could not locate user's desktop"); } ##################################################################### # Support Methods # On Darwin you can find a resource from the home directory consistently. sub _to_documents { File::Spec->catdir( $_[1], 'Documents' ); } sub _to_desktop { File::Spec->catdir( $_[1], 'Desktop' ); } sub _to_data { File::Spec->catdir( $_[1], 'Library', 'Application Support' ); } 1; grepmail-5.3033/inc/File/HomeDir/MacOS9.pm0000644000076500001200000000441110571626323017127 0ustar coppitadmin#line 1 "inc/File/HomeDir/MacOS9.pm - /Library/Perl/5.8.6/File/HomeDir/MacOS9.pm" package File::HomeDir::MacOS9; # Half-assed implementation for the legacy Mac OS9 operating system. # Provided mainly to provide legacy compatibility. May be removed at # a later date. use 5.005; use strict; use Carp (); use vars qw{$VERSION}; BEGIN { $VERSION = '0.58'; } # If prefork is available, set Mac::Files # to be preloaded if needed. eval "use prefork 'Mac::Files'"; ##################################################################### # Current User Methods sub my_home { my $class = shift; # Try for $ENV{HOME} if we have it if ( defined $ENV{HOME} ) { return $ENV{HOME}; } ### DESPERATION SETS IN # We could use the desktop eval { my $home = $class->my_desktop; return $home if $home and -d $home; }; # Desperation on any platform SCOPE: { # On some platforms getpwuid dies if called at all local $SIG{'__DIE__'} = ''; my $home = (getpwuid($<))[7]; return $home if $home and -d $home; } Carp::croak("Could not locate current user's home directory"); } sub my_desktop { my $class = shift; # Find the desktop via Mac::Files local $SIG{'__DIE__'} = ''; require Mac::Files; my $home = Mac::Files::FindFolder( Mac::Files::kOnSystemDisk(), Mac::Files::kDesktopFolderType(), ); return $home if $home and -d $home; Carp::croak("Could not locate current user's desktop"); } sub my_documents { Carp::croak("my_documents is not implemented on Mac OS 9"); } sub my_data { Carp::croak("my_data is not implemented on Mac OS 9"); } ##################################################################### # General User Methods sub users_home { my ($class, $name) = @_; SCOPE: { # On some platforms getpwnam dies if called at all local $SIG{'__DIE__'} = ''; my $home = (getpwnam($name))[7]; return $home if defined $home and -d $home; } Carp::croak("Failed to find home directory for user '$name'"); } sub users_desktop { my ($class, $name) = @_; Carp::croak("users_desktop is not implemented on this platform"); } sub users_documents { my ($class, $name) = @_; Carp::croak("users_documents is not implemented on this platform"); } sub users_data { my ($class, $name) = @_; Carp::croak("users_data is not implemented on this platform"); } 1; grepmail-5.3033/inc/File/HomeDir/Unix.pm0000644000076500001200000000304610571626323017022 0ustar coppitadmin#line 1 "inc/File/HomeDir/Unix.pm - /Library/Perl/5.8.6/File/HomeDir/Unix.pm" package File::HomeDir::Unix; # Unix-specific functionality use 5.005; use strict; use Carp (); use vars qw{$VERSION}; BEGIN { $VERSION = '0.58'; } ##################################################################### # Current User Methods sub my_home { my $class = shift; return $ENV{HOME} if defined $ENV{HOME}; # This is from the original code, but I'm guessing # it means "login directory". return $ENV{LOGDIR} if $ENV{LOGDIR}; ### More-desperate methods # Light desperation on any platform SCOPE: { # On some platforms getpwuid dies if called at all my $home = (getpwuid($<))[7]; return $home if $home and -d $home; } Carp::croak("Could not locate current user's home directory"); } sub my_desktop { Carp::croak("The my_desktop is not implemented on this platform"); } # On unix, we keep both data and documents under the same folder sub my_documents { shift->my_home; } sub my_data { shift->my_home; } ##################################################################### # General User Methods sub users_home { my ($class, $name) = @_; SCOPE: { # On some platforms getpwnam dies if called at all my $home = (getpwnam($name))[7]; return $home if $home and -d $home; } Carp::croak("Failed to find home directory for user '$name'"); } sub users_desktop { my ($class, $name) = @_; Carp::croak("Failed to find desktop for user '$name'"); } sub users_documents { shift->users_home(@_); } sub users_data { shift->users_home(@_); } 1; grepmail-5.3033/inc/File/HomeDir/Windows.pm0000644000076500001200000000617310571626323017535 0ustar coppitadmin#line 1 "inc/File/HomeDir/Windows.pm - /Library/Perl/5.8.6/File/HomeDir/Windows.pm" package File::HomeDir::Windows; # Generalised implementation for the entire Windows family of operating # systems. use 5.005; use strict; use Carp (); use File::Spec (); use vars qw{$VERSION}; BEGIN { $VERSION = '0.58'; } # If prefork is available, set Win32::TieRegistry # to be preloaded if needed. eval "use prefork 'Win32::TieRegistry'"; ##################################################################### # Current User Methods sub my_home { my $class = shift; # Do we have a user profile? if ( $ENV{USERPROFILE} ) { return $ENV{USERPROFILE}; } # Some Windows use something like $ENV{HOME} if ( $ENV{HOMEDRIVE} and $ENV{HOMEPATH} ) { return File::Spec->catpath( $ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '', ); } Carp::croak("Could not locate current user's home directory"); } sub my_desktop { my $class = shift; # The most correct way to find the desktop SCOPE: { my $home = $class->my_win32_folder('Desktop'); return $home if $home and -d $home; } # MSWindows sets WINDIR, MS WinNT sets USERPROFILE. foreach my $e ( 'USERPROFILE', 'WINDIR' ) { next unless $ENV{$e}; my $desktop = File::Spec->catdir($ENV{$e}, 'Desktop'); return $desktop if $desktop and -d $desktop; } # As a last resort, try some hard-wired values foreach my $fixed ( "C:\\windows\\desktop", "C:\\win95\\desktop", # In the original, I can only assume this is Cygwin stuff "C:/win95/desktop", "C:/windows/desktop", ) { return $fixed if $fixed and -d $fixed; } Carp::croak("Failed to find current user's desktop"); } sub my_documents { my $class = shift; # The most correct way to find my documents SCOPE: { my $home = $class->my_win32_folder('Personal'); return $home if $home and -d $home; } Carp::croak("Failed to find current user's documents"); } sub my_data { my $class = shift; # The most correct way to find my documents SCOPE: { my $home = $class->my_win32_folder('Local AppData'); return $home if $home and -d $home; } Carp::croak("Failed to find current user's documents"); } # The explorer shell holds all sorts of folder information. # This method is specific to this platform sub my_win32_folder { my $class = shift; # Find the shell's folder hash local $SIG{'__DIE__'} = ''; require Win32::TieRegistry; my $folders = Win32::TieRegistry->new( 'HKEY_CURRENT_USER/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders', { Delimiter => '/' }, ) or return undef; # Find the specific folder my $folder = $folders->GetValue(shift); return $folder; } ##################################################################### # General User Methods sub users_home { my ($class, $name) = @_; Carp::croak("users_home is not implemented on this platform"); } sub users_documents { my ($class, $name) = @_; Carp::croak("users_documents is not implemented on this platform"); } sub users_data { my ($class, $name) = @_; Carp::croak("users_data is not implemented on this platform"); } sub users_desktop { my ($class, $name) = @_; Carp::croak("users_desktop is not implemented on this platform"); } 1; grepmail-5.3033/inc/File/HomeDir.pm0000644000076500001200000000570510571626323016103 0ustar coppitadmin#line 1 "inc/File/HomeDir.pm - /Library/Perl/5.8.6/File/HomeDir.pm" package File::HomeDir; # See POD at end for docs use 5.005; use strict; use Carp (); use File::Spec (); # Globals use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK $IMPLEMENTED_BY}; BEGIN { $VERSION = '0.58'; # Inherit manually require Exporter; @ISA = ( 'Exporter' ); @EXPORT = ( 'home' ); @EXPORT_OK = qw{ home my_home my_desktop my_documents my_data }; # %~ doesn't need (and won't take) exporting, as it's a magic # symbol name that's always looked for in package 'main'. } # Don't do platform detection at compile-time if ( $^O eq 'MSWin32' ) { $IMPLEMENTED_BY = 'File::HomeDir::Windows'; require File::HomeDir::Windows; } elsif ( $^O eq 'darwin' ) { $IMPLEMENTED_BY = 'File::HomeDir::Darwin'; require File::HomeDir::Darwin; } elsif ( $MacPerl::VERSION || $MacPerl::VERSION ) { $IMPLEMENTED_BY = 'File::HomeDir::MacOS9'; require File::HomeDir::MacOS9; } else { $IMPLEMENTED_BY = 'File::HomeDir::Unix'; require File::HomeDir::Unix; } ##################################################################### # Current User Methods sub my_home { $IMPLEMENTED_BY->my_home; } sub my_desktop { $IMPLEMENTED_BY->my_desktop; } sub my_documents { $IMPLEMENTED_BY->my_documents; } sub my_data { $IMPLEMENTED_BY->my_data; } ##################################################################### # General User Methods # Find the home directory of an arbitrary user sub home (;$) { # Allow to be called as a method if ( $_[0] and $_[0] eq 'File::HomeDir' ) { shift(); } # No params means my home return my_home() unless @_; # Check the param my $name = shift; if ( ! defined $name ) { Carp::croak("Can't use undef as a username"); } if ( ! length $name ) { Carp::croak("Can't use empty-string (\"\") as a username"); } # A dot also means my home ### Is this meant to mean File::Spec->curdir? if ( $name eq '.' ) { return my_home(); } # Now hand off to the implementor $IMPLEMENTED_BY->users_home($name); } ##################################################################### # Tie-Based Interface # Okay, things below this point get scary CLASS: { # Make the class for the %~ tied hash: package File::HomeDir::TIE; # Make the singleton object. # (We don't use the hash for anything, though) ### THEN WHY MAKE IT??? my $SINGLETON = bless {}; sub TIEHASH { $SINGLETON } sub FETCH { # Get our homedir if ( ! defined $_[1] or ! length $_[1] ) { return File::HomeDir::my_home(); } # Get a named user's homedir return File::HomeDir::home($_[1]); } sub STORE { _bad('STORE') } sub EXISTS { _bad('EXISTS') } sub DELETE { _bad('DELETE') } sub CLEAR { _bad('CLEAR') } sub FIRSTKEY { _bad('FIRSTKEY') } sub NEXTKEY { _bad('NEXTKEY') } sub _bad ($) { Carp::croak("You can't $_[0] with the %~ hash") } } # Do the actual tie of the global %~ variable tie %~, 'File::HomeDir::TIE'; 1; __END__ #line 372 grepmail-5.3033/inc/File/Spec/0000755000076500001200000000000010571626331015100 5ustar coppitadmingrepmail-5.3033/inc/File/Spec/Unix.pm0000644000076500001200000001724510571626323016373 0ustar coppitadmin#line 1 "inc/File/Spec/Unix.pm - /System/Library/Perl/5.8.6/darwin-thread-multi-2level/File/Spec/Unix.pm" package File::Spec::Unix; use strict; use vars qw($VERSION); $VERSION = '1.5'; #line 41 sub canonpath { my ($self,$path) = @_; # Handle POSIX-style node names beginning with double slash (qnx, nto) # Handle network path names beginning with double slash (cygwin) # (POSIX says: "a pathname that begins with two successive slashes # may be interpreted in an implementation-defined manner, although # more than two leading slashes shall be treated as a single slash.") my $node = ''; my $double_slashes_special = $self->isa("File::Spec::Cygwin") || $^O =~ m/^(?:qnx|nto)$/; if ( $double_slashes_special && $path =~ s:^(//[^/]+)(/|\z):/:s ) { $node = $1; } # This used to be # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail # (Mainly because trailing "" directories didn't get stripped). # Why would cygwin avoid collapsing multiple slashes into one? --jhi $path =~ s|/+|/|g; # xx////xx -> xx/xx $path =~ s@(/\.)+(/|\Z(?!\n))@/@g; # xx/././xx -> xx/xx $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx $path =~ s|^/\.\.$|/|; # /.. -> / $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx return "$node$path"; } #line 78 sub catdir { my $self = shift; $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' } #line 91 sub catfile { my $self = shift; my $file = $self->canonpath(pop @_); return $file unless @_; my $dir = $self->catdir(@_); $dir .= "/" unless substr($dir,-1) eq "/"; return $dir.$file; } #line 106 sub curdir () { '.' } #line 114 sub devnull () { '/dev/null' } #line 122 sub rootdir () { '/' } #line 138 my $tmpdir; sub _tmpdir { return $tmpdir if defined $tmpdir; my $self = shift; my @dirlist = @_; { no strict 'refs'; if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 require Scalar::Util; @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; } } foreach (@dirlist) { next unless defined && -d && -w _; $tmpdir = $_; last; } $tmpdir = $self->curdir unless defined $tmpdir; $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); return $tmpdir; } sub tmpdir { return $tmpdir if defined $tmpdir; $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ); } #line 171 sub updir () { '..' } #line 180 sub no_upwards { my $self = shift; return grep(!/^\.{1,2}\Z(?!\n)/s, @_); } #line 192 sub case_tolerant () { 0 } #line 204 sub file_name_is_absolute { my ($self,$file) = @_; return scalar($file =~ m:^/:s); } #line 215 sub path { return () unless exists $ENV{PATH}; my @path = split(':', $ENV{PATH}); foreach (@path) { $_ = '.' if $_ eq '' } return @path; } #line 228 sub join { my $self = shift; return $self->catfile(@_); } #line 253 sub splitpath { my ($self,$path, $nofile) = @_; my ($volume,$directory,$file) = ('','',''); if ( $nofile ) { $directory = $path; } else { $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs; $directory = $1; $file = $2; } return ($volume,$directory,$file); } #line 295 sub splitdir { return split m|/|, $_[1], -1; # Preserve trailing fields } #line 309 sub catpath { my ($self,$volume,$directory,$file) = @_; if ( $directory ne '' && $file ne '' && substr( $directory, -1 ) ne '/' && substr( $file, 0, 1 ) ne '/' ) { $directory .= "/$file" ; } else { $directory .= $file ; } return $directory ; } #line 354 sub abs2rel { my($self,$path,$base) = @_; $base = $self->_cwd() unless defined $base and length $base; ($path, $base) = map $self->canonpath($_), $path, $base; if (grep $self->file_name_is_absolute($_), $path, $base) { ($path, $base) = map $self->rel2abs($_), $path, $base; } else { # save a couple of cwd()s if both paths are relative ($path, $base) = map $self->catdir('/', $_), $path, $base; } my ($path_volume) = $self->splitpath($path, 1); my ($base_volume) = $self->splitpath($base, 1); # Can't relativize across volumes return $path unless $path_volume eq $base_volume; my $path_directories = ($self->splitpath($path, 1))[1]; my $base_directories = ($self->splitpath($base, 1))[1]; # For UNC paths, the user might give a volume like //foo/bar that # strictly speaking has no directory portion. Treat it as if it # had the root directory for that volume. if (!length($base_directories) and $self->file_name_is_absolute($base)) { $base_directories = $self->rootdir; } # Now, remove all leading components that are the same my @pathchunks = $self->splitdir( $path_directories ); my @basechunks = $self->splitdir( $base_directories ); if ($base_directories eq $self->rootdir) { shift @pathchunks; return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); } while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { shift @pathchunks ; shift @basechunks ; } return $self->curdir unless @pathchunks || @basechunks; # $base now contains the directories the resulting relative path # must ascend out of before it can descend to $path_directory. my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); return $self->canonpath( $self->catpath('', $result_dirs, '') ); } sub _same { $_[1] eq $_[2]; } #line 435 sub rel2abs { my ($self,$path,$base ) = @_; # Clean up $path if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { $base = $self->_cwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; } else { $base = $self->canonpath( $base ) ; } # Glom them together $path = $self->catdir( $base, $path ) ; } return $self->canonpath( $path ) ; } #line 473 # Internal routine to File::Spec, no point in making this public since # it is the standard Cwd interface. Most of the platform-specific # File::Spec subclasses use this. sub _cwd { require Cwd; Cwd::cwd(); } # Internal method to reduce xx\..\yy -> yy sub _collapse { my($fs, $path) = @_; my $updir = $fs->updir; my $curdir = $fs->curdir; my($vol, $dirs, $file) = $fs->splitpath($path); my @dirs = $fs->splitdir($dirs); pop @dirs if @dirs && $dirs[-1] eq ''; my @collapsed; foreach my $dir (@dirs) { if( $dir eq $updir and # if we have an updir @collapsed and # and something to collapse length $collapsed[-1] and # and its not the rootdir $collapsed[-1] ne $updir and # nor another updir $collapsed[-1] ne $curdir # nor the curdir ) { # then pop @collapsed; # collapse } else { # else push @collapsed, $dir; # just hang onto it } } return $fs->catpath($vol, $fs->catdir(@collapsed), $file ); } 1; grepmail-5.3033/inc/File/Spec.pm0000644000076500001200000000127610571626323015445 0ustar coppitadmin#line 1 "inc/File/Spec.pm - /System/Library/Perl/5.8.6/darwin-thread-multi-2level/File/Spec.pm" package File::Spec; use strict; use vars qw(@ISA $VERSION); $VERSION = '3.23'; $VERSION = eval $VERSION; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', os2 => 'OS2', VMS => 'VMS', epoc => 'Epoc', NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. cygwin => 'Cygwin'); my $module = $module{$^O} || 'Unix'; require "File/Spec/$module.pm"; @ISA = ("File::Spec::$module"); 1; __END__ #line 337 grepmail-5.3033/inc/Module/0000755000076500001200000000000010571626331014554 5ustar coppitadmingrepmail-5.3033/inc/Module/Install/0000755000076500001200000000000010571626331016162 5ustar coppitadmingrepmail-5.3033/inc/Module/Install/AutoInstall.pm0000644000076500001200000000231310571626325020761 0ustar coppitadmin#line 1 "inc/Module/Install/AutoInstall.pm - /Library/Perl/5.8.6/Module/Install/AutoInstall.pm" package Module::Install::AutoInstall; use Module::Install::Base; @ISA = qw(Module::Install::Base); sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; while ( @core and @_ > 1 and $_[0] =~ /^-\w+$/ ) { push @core, splice(@_, 0, 2); } # We'll need ExtUtils::AutoInstall $self->include('ExtUtils::AutoInstall'); require ExtUtils::AutoInstall; ExtUtils::AutoInstall->import( (@core ? (-core => \@core) : ()), @_, $self->features ); $self->makemaker_args( ExtUtils::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . ExtUtils::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install; ExtUtils::AutoInstall::do_install(); } 1; grepmail-5.3033/inc/Module/Install/Base.pm0000644000076500001200000000150310571626322017371 0ustar coppitadmin#line 1 "inc/Module/Install/Base.pm - /Library/Perl/5.8.6/Module/Install/Base.pm" package Module::Install::Base; #line 28 sub new { my ($class, %args) = @_; foreach my $method (qw(call load)) { *{"$class\::$method"} = sub { +shift->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless(\%args, $class); } #line 46 sub AUTOLOAD { my $self = shift; goto &{$self->_top->autoload}; } #line 57 sub _top { $_[0]->{_top} } #line 68 sub admin { my $self = shift; $self->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { my $self = shift; $self->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} 1; __END__ #line 112 grepmail-5.3033/inc/Module/Install/Can.pm0000644000076500001200000000163610571626326017233 0ustar coppitadmin#line 1 "inc/Module/Install/Can.pm - /Library/Perl/5.8.6/Module/Install/Can.pm" package Module::Install::Can; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.01'; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } 1; grepmail-5.3033/inc/Module/Install/CustomInstallationPath.pm0000644000076500001200000000234110571626322023171 0ustar coppitadmin#line 1 "inc/Module/Install/CustomInstallationPath.pm - /Library/Perl/5.8.1/Module/Install/CustomInstallationPath.pm" package Module::Install::CustomInstallationPath; use strict; use File::HomeDir; use Config; use vars qw( @ISA $VERSION ); use Module::Install::Base; @ISA = qw( Module::Install::Base ); $VERSION = '0.10.3'; # --------------------------------------------------------------------------- sub Check_Custom_Installation { my $self = shift; # Module::Install says it requires perl 5.004 $self->requires( perl => '5.004' ); $self->include_deps('File::HomeDir',0); return if (grep {/^PREFIX=/} @ARGV) || (grep {/^INSTALLDIRS=/} @ARGV); my $install_location = $self->prompt( "Would you like to install this package into a location other than the\n" . "default Perl location (i.e. change the PREFIX)?" => 'n'); if ($install_location eq 'y') { my $home = home(); die "Your home directory could not be determined. Aborting." unless defined $home; print "\n","-"x78,"\n\n"; my $prefix = $self->prompt( "What PREFIX should I use?\n=>" => $home); push @ARGV,"PREFIX=$prefix"; } } 1; # --------------------------------------------------------------------------- #line 106 grepmail-5.3033/inc/Module/Install/Fetch.pm0000644000076500001200000000460610571626326017563 0ustar coppitadmin#line 1 "inc/Module/Install/Fetch.pm - /Library/Perl/5.8.6/Module/Install/Fetch.pm" package Module::Install::Fetch; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.01'; sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ($scheme eq 'http' and !eval { require LWP::Simple; 1 }) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, << "."); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit . foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; grepmail-5.3033/inc/Module/Install/Include.pm0000644000076500001200000000062410571626322020105 0ustar coppitadmin#line 1 "inc/Module/Install/Include.pm - /Library/Perl/5.8.6/Module/Install/Include.pm" package Module::Install::Include; use Module::Install::Base; @ISA = qw(Module::Install::Base); sub include { +shift->admin->include(@_) }; sub include_deps { +shift->admin->include_deps(@_) }; sub auto_include { +shift->admin->auto_include(@_) }; sub auto_include_deps { +shift->admin->auto_include_deps(@_) }; 1; grepmail-5.3033/inc/Module/Install/Makefile.pm0000644000076500001200000000721710571626323020245 0ustar coppitadmin#line 1 "inc/Module/Install/Makefile.pm - /Library/Perl/5.8.6/Module/Install/Makefile.pm" package Module::Install::Makefile; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.01'; use strict 'vars'; use vars '$VERSION'; use ExtUtils::MakeMaker (); sub Makefile { $_[0] } sub prompt { shift; goto &ExtUtils::MakeMaker::prompt; } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(" ", grep length, $clean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [shift]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $args->{NAME} =~ s/-/::/g; if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 ) { $args->{SIGN} = 1 if $self->sign; } delete $args->{SIGN} unless $self->is_admin; # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->build_requires, $self->requires) ); # merge both kinds of requires into prereq_pm my $dir = ($args->{DIR} ||= []); if ($self->bundles) { push @$dir, map "$_->[1]", @{$self->bundles}; delete $prereq->{$_->[0]} for @{$self->bundles}; } if (my $perl_version = $self->perl_version) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, ". "but we need version >= $perl_version"; } my %args = map {($_ => $args->{$_})} grep {defined($args->{$_})} keys %$args; if ($self->admin->preop) { $args{dist} = $self->admin->preop; } ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile(); } sub fix_up_makefile { my $self = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); open MAKEFILE, '< Makefile' or die $!; my $makefile = do { local $/; }; close MAKEFILE; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 -Iinc/m; $makefile =~ s/^(PERL = .*)/$1 -Iinc/m; open MAKEFILE, '> Makefile' or die $!; print MAKEFILE "$preamble$makefile$postamble"; close MAKEFILE; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 273 grepmail-5.3033/inc/Module/Install/Metadata.pm0000644000076500001200000001151210571626322020240 0ustar coppitadmin#line 1 "inc/Module/Install/Metadata.pm - /Library/Perl/5.8.6/Module/Install/Metadata.pm" package Module::Install::Metadata; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.04'; use strict 'vars'; use vars qw($VERSION); sub Meta { shift } my @scalar_keys = qw( name module_name version abstract author license distribution_type sign perl_version ); my @tuple_keys = qw(build_requires requires recommends bundles); foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{'values'}{$key} unless @_; $self->{'values'}{$key} = shift; return $self; }; } foreach my $key (@tuple_keys) { *$key = sub { my $self = shift; return $self->{'values'}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ($module eq 'perl') { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [$module, $version]; push @{$self->{'values'}{$key}}, $rv; push @rv, $rv; } return @rv; }; } sub features { my $self = shift; while (my ($name, $mods) = splice(@_, 0, 2)) { my $count = 0; push @{$self->{'values'}{'features'}}, ($name => [ map { (++$count % 2 and ref($_) and ($count += $#$_)) ? @$_ : $_ } @$mods ] ); } return @{$self->{'values'}{'features'}}; } sub no_index { my $self = shift; my $type = shift; push @{$self->{'values'}{'no_index'}{$type}}, @_ if $type; return $self->{'values'}{'no_index'}; } sub _dump { my $self = shift; my $package = ref($self->_top); my $version = $self->_top->VERSION; my %values = %{$self->{'values'}}; delete $values{sign}; if (my $perl_version = delete $values{perl_version}) { # Always canonical to three-dot version $perl_version =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e if $perl_version >= 5.006; $values{requires} = [ [perl => $perl_version], @{$values{requires}||[]}, ]; } warn "No license specified, setting license = 'unknown'\n" unless $values{license}; $values{license} ||= 'unknown'; $values{distribution_type} ||= 'module'; $values{name} ||= do { my $name = $values{module_name}; $name =~ s/::/-/g; $name; } if $values{module_name}; if ($values{name} =~ /::/) { my $name = $values{name}; $name =~ s/::/-/g; die "Error in name(): '$values{name}' should be '$name'!\n"; } my $dump = ''; foreach my $key (@scalar_keys) { $dump .= "$key: $values{$key}\n" if exists $values{$key}; } foreach my $key (@tuple_keys) { next unless exists $values{$key}; $dump .= "$key:\n"; foreach (@{$values{$key}}) { $dump .= " $_->[0]: $_->[1]\n"; } } if (my $no_index = $values{no_index}) { push @{$no_index->{'directory'}}, 'inc'; require YAML; local $YAML::UseHeader = 0; $dump .= YAML::Dump({ no_index => $no_index}); } else { $dump .= << "META"; no_index: directory: - inc META } $dump .= "generated_by: $package version $version\n"; return $dump; } sub read { my $self = shift; $self->include_deps( 'YAML', 0 ); require YAML; my $data = YAML::LoadFile( 'META.yml' ); # Call methods explicitly in case user has already set some values. while ( my ($key, $value) = each %$data ) { next unless $self->can( $key ); if (ref $value eq 'HASH') { while (my ($module, $version) = each %$value) { $self->$key( $module => $version ); } } else { $self->$key( $value ); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; META_NOT_OURS: { local *FH; if (open FH, "META.yml") { while () { last META_NOT_OURS if /^generated_by: Module::Install\b/; } return $self if -s FH; } } warn "Writing META.yml\n"; open META, "> META.yml" or warn "Cannot write to META.yml: $!"; print META $self->_dump; close META; return $self; } sub version_from { my ($self, $version_from) = @_; require ExtUtils::MM_Unix; $self->version(ExtUtils::MM_Unix->parse_version($version_from)); } sub abstract_from { my ($self, $abstract_from) = @_; require ExtUtils::MM_Unix; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix') ->parse_abstract($abstract_from) ); } 1; grepmail-5.3033/inc/Module/Install/PRIVATE/0000755000076500001200000000000010571626331017274 5ustar coppitadmingrepmail-5.3033/inc/Module/Install/PRIVATE/Update_Test_Version.pm0000644000076500001200000000247310571626326023572 0ustar coppitadmin#line 1 "inc/Module/Install/PRIVATE/Update_Test_Version.pm - lib/Module/Install/PRIVATE/Update_Test_Version.pm" package Module::Install::PRIVATE::Update_Test_Version; use strict; use vars qw( @ISA $VERSION ); use Module::Install::Base; @ISA = qw( Module::Install::Base ); $VERSION = sprintf "%d.%02d%02d", q/0.10.0/ =~ /(\d+)/g; # --------------------------------------------------------------------------- sub Update_Test_Version { my $self = shift; my $file_with_version = shift; my $test_case_file = shift; open SOURCE, $file_with_version or die "Couldn't open grepmail file: $!"; my $found = 0; while (my $line = ) { if ($line =~ /^\$VERSION = (.*q\/(.*?)\/.*);/) { $found = 1; my $version = eval $1; open TEST_CASE, $test_case_file or die "Couldn't open test case: $!"; local $/ = undef; my $test_case_code = ; $test_case_code =~ s/^grepmail .*$/grepmail $version/m; close TEST_CASE; unlink $test_case_file; open TEST_CASE, ">$test_case_file" or die "Couldn't open test case for updating: $!"; binmode TEST_CASE; print TEST_CASE $test_case_code; close TEST_CASE; last; } } die "Couldn't find version line in $file_with_version" unless $found; close SOURCE; } 1; grepmail-5.3033/inc/Module/Install/Scripts.pm0000644000076500001200000000244310571626324020154 0ustar coppitadmin#line 1 "inc/Module/Install/Scripts.pm - /Library/Perl/5.8.6/Module/Install/Scripts.pm" package Module::Install::Scripts; use Module::Install::Base; @ISA = qw(Module::Install::Base); $VERSION = '0.02'; use strict; use File::Basename (); sub prompt_script { my ($self, $script_file) = @_; my ($prompt, $abstract, $default); foreach my $line ( $self->_read_script($script_file) ) { last unless $line =~ /^#/; $prompt = $1 if $line =~ /^#\s*prompt:\s+(.*)/; $default = $1 if $line =~ /^#\s*default:\s+(.*)/; $abstract = $1 if $line =~ /^#\s*abstract:\s+(.*)/; } unless (defined $prompt) { my $script_name = File::Basename::basename($script_file); $prompt = "Do you want to install '$script_name'"; $prompt .= " ($abstract)" if defined $abstract; $prompt .= '?'; } return unless $self->prompt($prompt, ($default || 'n')) =~ /^[Yy]/; $self->install_script($script_file); } sub install_script { my $self = shift; my $args = $self->makemaker_args; my $exe_files = $args->{EXE_FILES} ||= []; push @$exe_files, @_; } sub _read_script { my ($self, $script_file) = @_; local *SCRIPT; open SCRIPT, $script_file or die "Can't open '$script_file' for input: $!\n"; return