###########################################################################
#
# EMAILPlug.pm - a plugin for parsing email files
#
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the
# University of Waikato, New Zealand.
#
# Copyright (C) 1999-2001 New Zealand Digital Library Project
#
# 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., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################
# EMAILPlug
#
# by Gordon Paynter (gwp@cs.waikato.ac.nz)
#
# Email plug reads email files. These are named with a simple
# number (i.e. as they appear in maildir folders) or with the
# extension .mbx (for mbox mail file format)
#
# Document text:
# The document text consists of all the text
# after the first blank line in the document.
#
# Metadata (not Dublin Core!):
# $Headers All the header content
# $Subject Subject: header
# $To To: header
# $From From: header
# $FromName Name of sender (where available)
# $FromAddr E-mail address of sender
# $DateText Date: header
# $Date Date: header in GSDL format (eg: 19990924)
#
#
# John McPherson - June/July 2001
# added (basic) MIME support and quoted-printable and base64 decodings.
# Minor fixes for names that are actually email addresses (ie <...> was lost)
#
# See: * RFC 822 - ARPA Internet Text Messages
# * RFC 2045 - Multipurpose Internet Mail Extensions (MIME) -part1
# * RFC 2046 - MIME (part 2) Media Types (and multipart messages)
# * RFC 2047 - MIME (part 3) Message Header Extensions
# * RFC 1806 - Content Dispositions (ie inline/attachment)
package EMAILPlug;
use SplitPlug;
use unicode;
use sorttools;
use util;
# EMAILPlug is a sub-class of SplitPlug.
sub BEGIN {
@ISA = ('SplitPlug');
}
# Create a new EMAILPlug object with which to parse a file.
# Accomplished by creating a new BasPlug and using bless to
# turn it into an EMAILPlug.
sub new {
my ($class) = @_;
my $self = new BasPlug ("EMAILPlug", @_);
# this might not actually be true at read-time, but after processing
# it should all be utf8.
$self->{'input_encoding'}="utf8";
return bless $self, $class;
}
sub get_default_process_exp {
my $self = shift (@_);
# mbx/email for mailbox file format, \d+ for maildir (each message is
# in a separate file, with a unique number for filename)
return q@([\\/]\d+|\.(mbx|email))$@;
}
# This plugin splits the mbox mail files at lines starting with From tags).
sub text_into_html {
my ($text) = @_;
# Convert problem characters into HTML symbols
$text =~ s/&/&/go;
$text =~ s/</go;
$text =~ s/>/>/go;
$text =~ s/\"/"/go;
# convert email addresses and URIs into links
# don't markup email addresses for now
# $text =~ s/([\w\d\.\-]+@[\w\d\.\-]+)/$1<\/a>/g;
# assume hostnames are \.\w\- only, then might have a trailing '/.*'
# assume URI doesn't finish with a '.'
$text =~ s@((http|ftp|https)://[\w\-]+(\.[\w\-]+)*/?((&|\.)?[\w\?\=\-_/~]+)*)@$1<\/a>@g;
# Clean up whitespace and convert \n charaters to
$text =~ s/ +/ /go;
$text =~ s/\s*$//o;
$text =~ s/^\s*//o;
$text =~ s/\n/\n /go;
return $text;
}
#Process a MIME message.
# the textref we are given DOES NOT include the header.
sub text_from_mime_message {
my ($mimetype,$mimeinfo,$text,$outhandle)=(@_);
# Check for multiparts - $mimeinfo will be a boundary
if ($mimetype =~ /multipart/) {
$boundary="";
if ($mimeinfo =~ m@boundary=(\"[^\"]+\"|[^\s]+)\s*$@im) {
$boundary=$1;
if ($boundary =~ m@^\"@) {
$boundary =~ s@^\"@@; $boundary =~ s@\"$@@;
}
} else {
print $outhandle "EMAILPlug: (warning) couldn't parse MIME boundary\n";
}
# parts start with "--$boundary"
# message ends with "--$boundary--"
# RFC says boundary is <70 chars, [A-Za-z'()+_,-./:=?], so escape any
# that perl might want to interpolate. Also allows spaces...
$boundary=~s/\\/\\\\/g;
$boundary=~s/([\?\+\.\(\)\:\/\'])/\\$1/g;
my @message_parts = split("\r?\n\-\-$boundary", "\n$text");
# remove first "part" and last "part" (final --)
shift @message_parts;
my $last=pop @message_parts;
# if our boundaries are a bit dodgy and we only found 1 part...
if (!defined($last)) {$last="";}
# make sure it is only -- and whitespace
if ($last !~ /^\-\-\s*$/ms) {
print $outhandle "EMAILPlug: (warning) last part of MIME message isn't empty\n";
}
foreach my $message_part (@message_parts) {
# remove the leading newline left from split.
$message_part=~s/^\r?\n//;
}
if ($mimetype eq "multipart/alternative") {
# check for an HTML version first, then TEXT, otherwise use first.
my $part_text="";
foreach my $message_part (@message_parts) {
if ($message_part =~ m@\s*content\-type:\s*text/html@mis)
{
# Use the HTML version
$part_text=text_from_part($message_part);
$mimetype="text/html";
last;
}
}
if ($part_text eq "") { # try getting a text part instead
foreach my $message_part (@message_parts) {
if ($message_part =~ m@^content\-type:\s*text/plain@mis)
{
# Use the plain version
$part_text=text_from_part($message_part);
if ($part_text =~/[^\s]/) {
$part_text=" \n";
$text.=$rfc822_formatted_body;
# end of message/rfc822
} elsif ($part_content_type =~ /multipart/) {
# recurse again
$tmptext=text_from_mime_message($part_content_type,
$part_content_info,
$part_body,
$outhandle);
$text.=$tmptext;
} elsif ($text eq "") {
# we can't do anything with this part, but if it's the first
# part then make sure it is mentioned..
$text.="\n
tags (and multiple carriage
# returns with
or
/go;
$text =~ s/
\s*
/".$part_text."
";
}
$mimetype="text/plain";
last;
}
}
}
if ($part_text eq "") { # use first part
$part_text=text_from_part(shift @message_parts);
}
if ($part_text eq "") { # we couldn't get anything!!!
# or it was an empty message...
# do nothing...
print $outhandle "EMAILPlug: no text - empty body?\n";
} else {
$text=$part_text;
}
} elsif ($mimetype =~ m@multipart/(mixed|digest|related)@) {
$text="";
foreach my $message_part (@message_parts) {
my $part_header=$message_part;
my $part_body;
if ($message_part=~ /^\s*\n/) {
# no header... use defaults
$part_body=$message_part;
$part_header="Content-type: text/plain; charset=us-ascii";
} elsif ($part_header=~s/\r?\n\r?\n(.*)$//sg) {
$part_body=$1;
} else {
# something's gone wrong...
$part_header="";
$part_body=$message_part;
}
$part_header =~ s/\r?\n[\t\ ]+/ /gs; #unfold
my $part_content_type="";
my $part_content_info="";
if ($mimetype eq "multipart/digest") {
# default type - RTFRFC!!
$part_content_type="message/rfc822";
}
if ($part_header =~ m@^content\-type:\s*([\w+/\-]+)\s*\;?\s*(.*?)\s*@mi) {
$part_content_type=$1; $part_content_type =~ tr/A-Z/a-z/;
$part_content_info=$2;
}
my $filename="";
if ($part_header =~ m@name=\"?([\w\.\-\\/]+)\"?@mis) {
$filename=$1;
}
# disposition - either inline or attachment.
# NOT CURRENTLY USED - we display all text types instead...
# $part_header =~ /^content\-disposition:\s*([\w+])/mis;
# add <
<<attachment>>>";
# add part info header
$text.="
Type: $part_content_type
\n";
if ($filename ne "") {
$text.="Filename: $filename\n";
}
$text.="
<<attachment>>>";
# add part info header
$text.="
Type: $part_content_type
\n";
if ($filename ne "") {
$text.="Filename: $filename\n";
}
$text.="
\n$text\n\n"; } # convert to unicode # first get our character encoding name in the right form. $charset=~tr/A-Z/a-z/; $charset=~s/\-/_/g; if ($charset ne "us_ascii" && $charset ne "ascii") { $charset=~s/gb2312/gb/; # assumes EUC-KR, not ISO-2022 !? $charset=~s/ks_c_5601_1987/korean/; my @unicode_array=&unicode::convert2unicode($charset,\$text); my $utf8_text=&unicode::unicode2utf8(@unicode_array); $text=$utf8_text; } return $text; } # decode quoted-printable text sub qp_decode { my $text=shift; my @lines=split('\n', $text); # if a line ends with "=\s*", it is a soft line break, otherwise # keep in any newline characters. foreach my $line (@lines) { if ($line =~ s/=\s*$//) {} else {$line.="\n";} if ($line =~ /=[0-9A-Fa-f]{2}/) { # it contains an escaped char my @hexcode_segments=split('=',$line); shift @hexcode_segments; my @hexcodes; foreach my $hexcode (@hexcode_segments) { $hexcode =~ s/^(..).*$/$1/; # only need first 2 chars chomp($hexcode); # just in case... my $char=chr (hex "0x$hexcode"); $line =~ s/=$hexcode/$char/g; } } } $text= join('', @lines); return $text; } # decode base64 text. This is fairly slow (since it's interpreted perl rather # than compiled XS stuff like in the ::MIME modules, but this is more portable # for us at least). # see rfc2045 for description, but basically, bits 7 and 8 are set to zero; # 4 bytes of encoded text become 3 bytes of binary - remove 2 highest bits # from each encoded byte. sub base64_decode { my $enc_text = shift; # A=>0, B=>1, ..., '+'=>62, '/'=>63 # also '=' is used for padding at the end, but we remove it anyway. my $mimechars="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; # map each MIME char into it's value, for more efficient lookup. my %index; map { $index{$_} = index ($mimechars, $_) } (split ('', $mimechars)); # remove all non-base64 chars. eval to get variable in transliteration... # also remove '=' - we'll assume (!!) that there are no errors in the encoding eval "\$enc_text =~ tr|$mimechars||cd"; my $decoded=""; while (length ($enc_text)>3) { my $fourchars=substr($enc_text,0,4,""); my @chars=(split '',$fourchars); $decoded.=chr( $index{$chars[0]} << 2 | $index{$chars[1]} >> 4); $decoded.=chr( ($index{$chars[1]} & 15) << 4 | $index{$chars[2]} >> 2); $decoded.=chr( ($index{$chars[2]} & 3 ) << 6 | $index{$chars[3]}); } # if there are any input chars left, there are either # 2 encoded bytes (-> 1 raw byte) left or 3 encoded (-> 2 raw) bytes left. my @chars=(split '',$enc_text); if (length($enc_text)) { $decoded.=chr($index{$chars[0]} << 2 | (int $index{$chars[1]} >> 4)); } if (length($enc_text)==3) { $decoded.=chr( ($index{$chars[1]} & 15) << 4 | $index{$chars[2]} >> 2); } return $decoded; } # Perl packages have to return true if they are run. 1;