###########################################################################
#
# 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)
#
# $Title made up of Subject, Date and Sender (for default formatting)
#
#
# 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)
# mozilla and IE will save individual mbx format files with a ".eml" ext.
return q@([\\/]\d+|\.(mbx|email|eml))$@;
}
# 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/&/&/g;
$text =~ s/</g;
$text =~ s/>/>/g;
$text =~ s/\"/"/g;
# convert email addresses and URIs into links
# don't markup email addresses for now
# $text =~ s/([\w\d\.\-]+@[\w\d\.\-]+)/$1<\/a>/g;
# try to munge email addresses a little bit...
$text =~ s/@/@/;
# 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/ +/ /g;
$text =~ s/\s*$//g;
$text =~ s/^\s*//g;
$text =~ s/\n/\n /gi;
return $text;
}
#Process a MIME message.
# the textref we are given DOES NOT include the header.
sub text_from_mime_message {
my $self = shift(@_);
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= $self->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= $self->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= $self->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
From: " . text_into_html($raw{'From'});
$Title .= "
Date: " . text_into_html($raw{'DateText'});
$Title =~ s/\[/[/g; $Title =~ s/\]/]/g;
$doc_obj->add_utf8_metadata ($cursection, "Title", $Title);
# Add text to document object
if ($mimetype eq "text/plain") {
$$textref = &text_into_html($$textref);
}
$$textref = "No message" unless ($$textref =~ /\w/);
$doc_obj->add_utf8_text($cursection, $$textref);
return 1;
}
# Convert a text string into HTML.
#
# The HTML is going to be inserted into a GML file, so
# we have to be careful not to use symbols like ">",
# which ocurs frequently in email messages (and use
# > instead.
#
# This function also turns links and email addresses into hyperlinks,
# and replaces carriage returns with
tags (and multiple carriage
# returns with
or
/g;
$text =~ s/
\s*
/".$part_text."
";
}
$mimetype="text/plain";
last;
}
}
}
if ($part_text eq "") { # use first part
$part_text= $self->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.=" | " . $brief_header . "\n" . $msg_text . " |
\n$text\n\n"; } # convert to unicode $self->convert2unicode($charset, \$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*$//) {$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; } sub convert2unicode { my $self = shift(@_); my ($charset, $textref) = @_; # first get our character encoding name in the right form. $charset = "iso_8859_1" unless defined $charset; $charset=~tr/A-Z/a-z/; $charset=~s/\-/_/g; $charset=~s/gb2312/gb/; # assumes EUC-KR, not ISO-2022 !? $charset=~s/ks_c_5601_1987/korean/; if ($charset eq "utf_8") { # nothing to do! return; } # It appears that we can't always trust ascii text so we'll treat it # as iso-8859-1 (letting characters above 0x80 through without # converting them to utf-8 will result in invalid XML documents # which can't be parsed at build time). $charset = "iso_8859_1" if ($charset eq "us_ascii" || $charset eq "ascii"); if ($charset eq "iso_8859_1") { # test if the mailer lied, and it has win1252 chars in it... # 1252 has characters between 0x80 and 0x9f, 8859-1 doesn't if ($$textref =~ m/[\x80-\x9f]/) { my $outhandle = $self->{'outhandle'}; print $outhandle "EMAILPlug: Headers claim ISO charset but MS "; print $outhandle "codepage 1252 detected.\n"; $charset = "windows_1252"; } } $$textref=&unicode::unicode2utf8(&unicode::convert2unicode($charset,$textref)); } # Perl packages have to return true if they are run. 1;