#!/usr/bin/perl -w # # Copyright 2004 Ketil Froyn # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # About this script: # # I have used this script together with an Exchange 2000 .stm file # to extract the raw mails from it, and write the mails to a # Maildir. I made spot checks, and lots of my mails looked fine, # and a few weird ones were extracted as well (ranging in the 10s # when I extracted tens of thousands of mails). # # This program does not seem to be able to extract any attachments # at all. # # Your mileage may vary. This script is provided without any # warranty of any kind. # # Usage: # cat priv1.stm | stmextract.pl Maildir # use strict; my $maildir=shift || "Maildir"; unless (-d $maildir) { unless (mkdir($maildir)) { die "Unable to create dir $maildir: $!"; } } unless (-d "$maildir/tmp" ) { unless (mkdir("$maildir/tmp")) { die "Unable to create dir $maildir/tmp: $!"; } } unless (-d "$maildir/new" ) { unless (mkdir("$maildir/new")) { die "Unable to create dir $maildir/new: $!"; } } unless (-d "$maildir/cur" ) { unless (mkdir("$maildir/cur")) { die "Unable to create dir $maildir/cur: $!"; } } my $tmpdir="$maildir/tmp"; my $newdir="$maildir/new"; my $i=0; my $hostname=`hostname`; chomp $hostname; while () { s/\r//g; s/\n//g; # Look for something that resembles the beginning of a mail if (/((?:received|return-path): from.*)$/i) { $_=$1; $i++; my $fn=time().".".$$.".".$i.".".$hostname; open F,">$tmpdir/$fn" or die "Can't open $tmpdir/$fn: $!"; # accept blank lines and lines with normal chars on them while ($_ eq "" || $_ =~ /[a-z0-9 -_]/i) { # the mail is done if we find lots of weird characters last if /[^a-zA-Z0-9\/ _-]{16}/; print F $_, "\n" || die "Can't print to $tmpdir/$fn: $!"; $_ = <>; s/\r//g; s/\n//g; } print STDERR "debug: line did not match: [$_]\n"; close F; rename("$tmpdir/$fn","$newdir/$fn") or die "Can't move $fn from $tmpdir to $newdir: $!"; print "$fn\n"; } }