source: gsdl/trunk/perllib/plugins/EmailPlugin.pm@ 16341

Last change on this file since 16341 was 16341, checked in by kjdon, 13 years ago

save attachments in binary mode so they work on windows. Use filename_cat instead of hard coding forward slash in paths. added code for deleting tmp files. decode the filename header value - may be encoded like any other header value

  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 36.6 KB
Line 
1###########################################################################
2#
3# EmailPlugin.pm - a plugin for parsing email files
4#
5# A component of the Greenstone digital library software
6# from the New Zealand Digital Library Project at the
7# University of Waikato, New Zealand.
8#
9# Copyright (C) 1999-2002 New Zealand Digital Library Project
10#
11# This program is free software; you can redistribute it and/or modify
12# it under the terms of the GNU General Public License as published by
13# the Free Software Foundation; either version 2 of the License, or
14# (at your option) any later version.
15#
16# This program is distributed in the hope that it will be useful,
17# but WITHOUT ANY WARRANTY; without even the implied warranty of
18# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19# GNU General Public License for more details.
20#
21# You should have received a copy of the GNU General Public License
22# along with this program; if not, write to the Free Software
23# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
24#
25###########################################################################
26
27
28
29# EmailPlugin
30#
31# by Gordon Paynter (gwp@cs.waikato.ac.nz)
32#
33# Email plug reads email files. These are named with a simple
34# number (i.e. as they appear in maildir folders) or with the
35# extension .mbx (for mbox mail file format)
36#
37# Document text:
38# The document text consists of all the text
39# after the first blank line in the document.
40#
41# Metadata (not Dublin Core!):
42# $Headers All the header content (optional, not stored by default)
43# $Subject Subject: header
44# $To To: header
45# $From From: header
46# $FromName Name of sender (where available)
47# $FromAddr E-mail address of sender
48# $DateText Date: header
49# $Date Date: header in GSDL format (eg: 19990924)
50#
51# $Title made up of Subject, Date and Sender (for default formatting)
52#
53#
54# John McPherson - June/July 2001
55# added (basic) MIME support and quoted-printable and base64 decodings.
56# Minor fixes for names that are actually email addresses (ie <...> was lost)
57#
58# See: * RFC 822 - ARPA Internet Text Messages
59# * RFC 2045 - Multipurpose Internet Mail Extensions (MIME) -part1
60# * RFC 2046 - MIME (part 2) Media Types (and multipart messages)
61# * RFC 2047 - MIME (part 3) Message Header Extensions
62# * RFC 1806 - Content Dispositions (ie inline/attachment)
63
64
65package EmailPlugin;
66
67use strict;
68no strict "refs"; # so we can use a variable as a filehandle for print $out
69
70
71use SplitTextFile;
72use unicode; # gs conv functions
73use gsprintf 'gsprintf'; # translations
74
75use sorttools;
76use util;
77
78sub BEGIN {
79 @EmailPlugin::ISA = ('SplitTextFile');
80}
81
82
83my $arguments =
84 [ { 'name' => "process_exp",
85 'desc' => "{BasePlugin.process_exp}",
86 'type' => "regexp",
87 'reqd' => "no",
88 'deft' => &get_default_process_exp() },
89 { 'name' => "no_attachments",
90 'desc' => "{EmailPlugin.no_attachments}",
91 'type' => "flag",
92 'reqd' => "no" },
93 { 'name' => "headers",
94 'desc' => "{EmailPlugin.headers}",
95 'type' => "flag",
96 'reqd' => "no" },
97 { 'name' => "split_exp",
98 'desc' => "{EmailPlugin.split_exp}",
99 'type' => "regexp",
100 'reqd' => "no",
101 'deft' => &get_default_split_exp() }
102 ];
103
104my $options = { 'name' => "EmailPlugin",
105 'desc' => "{EmailPlugin.desc}",
106 'abstract' => "no",
107 'inherits' => "yes",
108 'args' => $arguments };
109
110sub new {
111 my ($class) = shift (@_);
112 my ($pluginlist,$inputargs,$hashArgOptLists) = @_;
113 push(@$pluginlist, $class);
114
115 push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});
116 push(@{$hashArgOptLists->{"OptList"}},$options);
117
118 my $self = new SplitTextFile($pluginlist, $inputargs, $hashArgOptLists);
119
120 $self->{'assoc_filenames'} = {}; # to save attach names so we don't clobber
121 $self->{'tmp_file_paths'} = (); # list of tmp files to delete after processing is finished
122
123 # this might not actually be true at read-time, but after processing
124 # it should all be utf8.
125 $self->{'input_encoding'}="utf8";
126 return bless $self, $class;
127}
128
129sub get_default_process_exp {
130 my $self = shift (@_);
131 # mbx/email for mailbox file format, \d+ for maildir (each message is
132 # in a separate file, with a unique number for filename)
133 # mozilla and IE will save individual mbx format files with a ".eml" ext.
134 return q@([\\/]\d+|\.(mbx|email|eml))$@;
135}
136
137# This plugin splits the mbox mail files at lines starting with From<sp>
138# It is supposed to be "\n\nFrom ", but this isn't always used.
139# add \d{4} so that the line ends in a year (in case the text has an
140# unescaped "From " at the start of a line).
141sub get_default_split_exp {
142 return q^\nFrom .*\d{4}\n^;
143
144}
145
146
147# do plugin specific processing of doc_obj
148sub process {
149
150 my $self = shift (@_);
151 my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli) = @_;
152 my $outhandle = $self->{'outhandle'};
153
154 # Check that we're dealing with a valid mail file
155 # mbox message files start with "From "
156 # maildir messages usually start with Return-Path and Delivered-To
157 # mh is very similar to maildir
158 my $startoffile=substr($$textref,0,256);
159 if (($startoffile !~ /^(From )/) &&
160 ($startoffile !~ /^(From|To|Envelope.*|Received|Return-Path|Date|Subject|Content\-.*|MIME-Version|Forwarded):/im)) {
161 return undef;
162 }
163
164 my $cursection = $doc_obj->get_top_section();
165
166 #
167 # Parse the document's text and extract metadata
168 #
169
170 # Protect backslashes
171 $$textref =~ s@\\@\\\\@g;
172
173 # Separate header from body of message
174 my $Headers = $$textref;
175 $Headers =~ s/\r?\n\r?\n(.*)$//s;
176 $$textref = $1;
177 $Headers .= "\n";
178
179 # Unfold headers - see rfc822
180 $Headers =~ s/\r?\n[\t\ ]+/ /gs;
181 # Extract basic metadata from header
182 my @headers = ("From", "To", "Subject", "Date");
183 my %raw;
184 foreach my $name (@headers) {
185 $raw{$name} = "No $name value";
186 }
187
188 # Get a default encoding for the header - RFC says should be ascii...
189 my $default_header_encoding="iso_8859_1";
190
191 # We don't know what character set is the user's default...
192 # We could use textcat to guess... for now we'll look at mime content-type
193# if ($Headers =~ /([[:^ascii:]])/) {
194# }
195 if ($Headers =~ /^Content\-type:.*charset=\"?([a-z0-9\-_]+)/mi) {
196 $default_header_encoding=$1;
197 $default_header_encoding =~ s@\-@_@g;
198 $default_header_encoding =~ tr/A-Z/a-z/;
199 }
200
201
202 # Examine each line of the headers
203 my ($line, $name, $value);
204 my @parts;
205 foreach $line (split(/\n/, $Headers)) {
206
207 # Ignore lines with no content or which begin with whitespace
208 next unless ($line =~ /:/);
209 next if ($line =~ /^\s/);
210
211 # Find out what metadata is on this line
212 @parts = split(/:/, $line);
213 $name = shift @parts;
214 # get fieldname in canonical form - first cap, then lower case.
215 $name =~ tr/A-Z/a-z/;
216 # uppercase the first character according to the current locale
217 $name=~s/(.+)/\u$1/;
218 next unless $name;
219 next unless ($raw{$name});
220
221 # Find the value of that metadata
222 $value = join(":", @parts);
223 $value =~ s/^\s+//;
224 $value =~ s/\s+$//;
225 # decode header values, using either =?<charset>?[BQ]?<data>?= (rfc2047) or default_header_encoding
226 $self->decode_header_value($default_header_encoding, \$value);
227
228 # Store the metadata
229 $value =~ s@_@\\_@g; # protect against GS macro language
230 $raw{$name} = $value;
231 }
232
233 # Extract the name and e-mail address from the From metadata
234 my $frommeta = $raw{"From"};
235 my $fromnamemeta;
236 my $fromaddrmeta;
237
238 $frommeta =~ s/\s*$//; # Remove trailing space, if any
239
240 if ($frommeta =~ m/(.+)\s*<(.+)>/) {
241 $fromnamemeta=$1;
242 $fromaddrmeta=$2;
243 } elsif ($frommeta =~ m/(.+@.+)\s+\((.*)\)/) {
244 $fromnamemeta=$2;
245 $fromaddrmeta=$1;
246 }
247 if (!defined($fromaddrmeta)) {
248 $fromaddrmeta=$frommeta;
249 }
250 $fromaddrmeta=~s/<//; $fromaddrmeta=~s/>//;
251 # minor attempt to prevent spam-bots from harvesting addresses...
252 $fromaddrmeta=~s/@/&#64;/;
253
254 $doc_obj->add_utf8_metadata ($cursection, "FromAddr", $fromaddrmeta);
255
256 if (defined($fromnamemeta) && $fromnamemeta) { # must be > 0 long
257 $fromnamemeta =~ s/\"//g; # remove quotes
258 $fromnamemeta =~ s/\s+$//; # remove trailing whitespace
259 }
260 else {
261 $fromnamemeta = $fromaddrmeta;
262 }
263 # if name is an address
264 $fromnamemeta =~ s/<//g; $fromnamemeta =~ s/>//g;
265 $fromnamemeta=~s/@/&#64\;/;
266 $doc_obj->add_utf8_metadata ($cursection, "FromName", $fromnamemeta);
267
268 $raw{"From"}=$frommeta;
269
270 # Process Date information
271 if ($raw{"Date"} !~ /No Date/) {
272 $raw{"DateText"} = $raw{"Date"};
273
274 # Convert the date text to internal date format
275 $value = $raw{"Date"};
276 # proper mbox format: Tue, 07 Jan 2003 17:27:42 +1300
277 my ($day, $month, $year) = $value =~ /(\d?\d)\s([A-Z][a-z][a-z])\s(\d\d\d?\d?)/;
278 if (!defined($day) || !defined($month) || !defined ($year)) {
279 # try monthly archive format: Wed Apr 23 00:26:08 2008
280 ($month,$day, $year) = $value =~ /([A-Z][a-z][a-z])\s\s?(\d?\d)\s\d\d:\d\d:\d\d\s(\d\d\d\d)/;
281 }
282
283 # make some assumptions about the year formatting...
284 # some (old) software thinks 2001 is 101, some think 2001 is 01
285 if ($year < 20) { $year += 2000; } # assume not really 1920...
286 elsif ($year < 150) { $year += 1900; } # assume not really 2150...
287 $raw{"Date"} = &sorttools::format_date($day, $month, $year);
288
289 } else {
290 # We have not extracted a date
291 $raw{"DateText"} = "Unknown.";
292 $raw{"Date"} = "19000000";
293 }
294
295 # Add extracted metadata to document object
296 foreach my $name (keys %raw) {
297 $value = $raw{$name};
298 if ($value) {
299 # assume subject, etc headers have no special HTML meaning.
300 $value = &text_into_html($value);
301 # escape [] so it isn't re-interpreted as metadata
302 $value =~ s/\[/&#91;/g; $value =~ s/\]/&#93;/g;
303 } else {
304 $value = "No $name field";
305 }
306 $doc_obj->add_utf8_metadata ($cursection, $name, $value);
307 }
308
309
310 # extract a message ID from the headers, if there is one, and we'll use
311 # that as the greenstone doc ID. Having a predictable ID means we can
312 # link to other messages, eg from In-Reply-To or References headers...
313 if ($Headers =~ m@^Message-ID:(.+)$@mi) {
314 my $id=escape_msg_id($1);
315 $doc_obj->{'msgid'}=$id;
316 }
317 # link to another message, if this is a reply
318 if ($Headers =~ m@^In-Reply-To:(.+)$@mi) {
319 my $id=escape_msg_id($1);
320 $doc_obj->add_utf8_metadata ($cursection, 'InReplyTo', $id);
321 } elsif ($Headers =~ m@^References:.*\s([^\s]+)$@mi) {
322 # References can have multiple, get the last one
323 my $id=escape_msg_id($1);
324 # not necessarily in-reply-to, but same thread...
325 $doc_obj->add_utf8_metadata ($cursection, 'InReplyTo', $id);
326 }
327
328
329
330 my $mimetype="text/plain";
331 my $mimeinfo="";
332 my $charset = $default_header_encoding;
333 # Do MIME and encoding stuff. Allow \s in mimeinfo in case there is
334 # more than one parameter given to Content-type.
335 # eg: Content-type: text/plain; charset="us-ascii"; format="flowed"
336 if ($Headers =~ m@^content\-type:\s*([\w\.\-/]+)\s*(\;\s*.+)?\s*$@mi)
337 {
338 $mimetype=$1;
339 $mimetype =~ tr/[A-Z]/[a-z]/;
340
341 if ($mimetype eq "text") { # for pre-RFC2045 messages (c. 1996)
342 $mimetype = "text/plain";
343 }
344
345 $mimeinfo=$2;
346 if (!defined $mimeinfo) {
347 $mimeinfo="";
348 } else { # strip leading and trailing stuff
349 $mimeinfo =~ s/^\;\s*//;
350 $mimeinfo =~ s/\s*$//;
351 }
352 if ($mimeinfo =~ /charset=\"([^\"]+)\"/i) {
353 $charset = $1;
354 }
355 }
356
357 my $transfer_encoding="7bit";
358 if ($Headers =~ /^content-transfer-encoding:\s*([^\s]+)\s*$/mi) {
359 $transfer_encoding=$1;
360 }
361
362 if ($mimetype eq "text/html") {
363 $$textref= $self->text_from_part($$textref, $Headers);
364 } elsif ($mimetype ne "text/plain") {
365 $self->{'doc_obj'} = $doc_obj; # in case we need to associate files...
366 $$textref=$self->text_from_mime_message($mimetype,$mimeinfo,$default_header_encoding,$$textref);
367 } else { # mimetype eq text/plain
368
369 if ($transfer_encoding =~ /quoted\-printable/) {
370 $$textref=qp_decode($$textref);
371 } elsif ($transfer_encoding =~ /base64/) {
372 $$textref=base64_decode($$textref);
373 }
374 $self->convert2unicode($charset, $textref);
375
376 $$textref = &text_into_html($$textref);
377 $$textref =~ s@_@\\_@g; # protect against GS macro language
378
379 }
380
381
382 if ($self->{'headers'} && $self->{'headers'} == 1) {
383 # Add "All headers" metadata
384 $Headers = &text_into_html($Headers);
385
386 $Headers = "No headers" unless ($Headers =~ /\w/);
387 $Headers =~ s/@/&#64\;/g;
388 # escape [] so it isn't re-interpreted as metadata
389 $Headers =~ s/\[/&#91;/g; $Headers =~ s/\]/&#93;/g;
390 $self->convert2unicode($charset, \$Headers);
391
392 $Headers =~ s@_@\\_@g; # protect against GS macro language
393 $doc_obj->add_utf8_metadata ($cursection, "Headers", $Headers);
394 }
395
396
397 # Add Title metadata
398 my $Title = text_into_html($raw{'Subject'});
399 $Title .= "<br>From: " . text_into_html($fromnamemeta);
400 $Title .= "<br>Date: " . text_into_html($raw{'DateText'});
401 $Title =~ s/\[/&#91;/g; $Title =~ s/\]/&#93;/g;
402
403 $doc_obj->add_utf8_metadata ($cursection, "Title", $Title);
404
405 # Add FileFormat metadata
406 $doc_obj->add_metadata($cursection, "FileFormat", "EMAIL");
407
408 # Add text to document object
409 $$textref = "No message" unless ($$textref =~ /\w/);
410
411 $doc_obj->add_utf8_text($cursection, $$textref);
412
413 return 1;
414}
415
416# delete any temp files that we have created
417sub clean_up_after_doc_obj_processing {
418 my $self = shift(@_);
419
420 foreach my $tmp_file_path (@{$self->{'tmp_file_paths'}}) {
421 if (-e $tmp_file_path) {
422 &util::rm($tmp_file_path);
423 }
424 }
425
426}
427
428# Convert a text string into HTML.
429#
430# The HTML is going to be inserted into a GML file, so
431# we have to be careful not to use symbols like ">",
432# which ocurs frequently in email messages (and use
433# &gt instead.
434#
435# This function also turns links and email addresses into hyperlinks,
436# and replaces carriage returns with <BR> tags (and multiple carriage
437# returns with <P> tags).
438
439
440sub text_into_html {
441 my ($text) = @_;
442
443 # Convert problem characters into HTML symbols
444 $text =~ s/&/&amp;/g;
445 $text =~ s/</&lt;/g;
446 $text =~ s/>/&gt;/g;
447 $text =~ s/\"/&quot;/g;
448
449 # convert email addresses and URIs into links
450# don't markup email addresses for now
451# $text =~ s/([\w\d\.\-]+@[\w\d\.\-]+)/<a href=\"mailto:$1\">$1<\/a>/g;
452
453 # try to munge email addresses a little bit...
454 $text =~ s/@/&#64;/;
455 # assume hostnames are \.\w\- only, then might have a trailing '/.*'
456 # assume URI doesn't finish with a '.'
457 $text =~ s@((http|ftp|https)://[\w\-]+(\.[\w\-]+)*/?((&amp;|\.|\%[a-f0-9]{2})?[\w\?\=\-_/~]+)*(\#[\w\.\-_]*)?)@<a href=\"$1\">$1<\/a>@gi;
458
459
460 # Clean up whitespace and convert \n charaters to <BR> or <P>
461 $text =~ s/ +/ /g;
462 $text =~ s/\s*$//g;
463 $text =~ s/^\s*//g;
464 $text =~ s/\n/\n<br>/g;
465 $text =~ s/<br>\s*<br>/<p>/gi;
466
467 return $text;
468}
469
470
471
472
473#Process a MIME message.
474# the textref we are given DOES NOT include the header.
475sub text_from_mime_message {
476 my $self = shift(@_);
477 my ($mimetype,$mimeinfo,$default_header_encoding,$text)=(@_);
478 my $outhandle=$self->{'outhandle'};
479 # Check for multiparts - $mimeinfo will be a boundary
480 if ($mimetype =~ /multipart/) {
481 my $boundary="";
482 if ($mimeinfo =~ m@boundary=(\"[^\"]+\"|[^\s]+)\s*$@im) {
483 $boundary=$1;
484 if ($boundary =~ m@^\"@) {
485 $boundary =~ s@^\"@@; $boundary =~ s@\"$@@;
486 }
487 } else {
488 print $outhandle "EmailPlugin: (warning) couldn't parse MIME boundary\n";
489 }
490 # parts start with "--$boundary"
491 # message ends with "--$boundary--"
492 # RFC says boundary is <70 chars, [A-Za-z'()+_,-./:=?], so escape any
493 # that perl might want to interpolate. Also allows spaces...
494 $boundary=~s/\\/\\\\/g;
495 $boundary=~s/([\?\+\.\(\)\:\/\'])/\\$1/g;
496 my @message_parts = split("\r?\n\-\-$boundary", "\n$text");
497 # remove first "part" and last "part" (final --)
498 shift @message_parts;
499 my $last=pop @message_parts;
500 # if our boundaries are a bit dodgy and we only found 1 part...
501 if (!defined($last)) {$last="";}
502 # make sure it is only -- and whitespace
503 if ($last !~ /^\-\-\s*$/ms) {
504 print $outhandle "EmailPlugin: (warning) last part of MIME message isn't empty\n";
505 }
506 foreach my $message_part (@message_parts) {
507 # remove the leading newline left from split.
508 $message_part=~s/^\r?\n//;
509 }
510 if ($mimetype eq "multipart/alternative") {
511 # check for an HTML version first, then TEXT, otherwise use first.
512 my $part_text="";
513 foreach my $message_part (@message_parts) {
514 if ($message_part =~ m@^content\-type:\s*text/html@i)
515 {
516 # Use the HTML version
517 $part_text = $self->text_from_part($message_part);
518 $mimetype="text/html";
519 last;
520 }
521 }
522 if ($part_text eq "") { # try getting a text part instead
523 foreach my $message_part (@message_parts) {
524 if ($message_part =~ m@^content\-type:\s*text/plain@i)
525 {
526 # Use the plain version
527 $part_text = $self->text_from_part($message_part);
528 if ($part_text =~/[^\s]/) {
529 $part_text = text_into_html($part_text);
530 }
531 $mimetype="text/plain";
532 last;
533 }
534 }
535 }
536 if ($part_text eq "") { #use first part (no html/text part found)
537 $part_text = $self->text_from_part(shift @message_parts);
538 $part_text = text_into_html($part_text);
539 }
540 if ($part_text eq "") { # we couldn't get anything!!!
541 # or it was an empty message...
542 # do nothing...
543 gsprintf($outhandle, "{ReadTextFile.empty_file} - empty body?\n");
544 } else {
545 $text = $part_text;
546 }
547 } elsif ($mimetype =~ m@multipart/(mixed|digest|related|signed)@) {
548 $text = "";
549 # signed is for PGP/GPG messages... the last part is a hash
550 if ($mimetype =~ m@multipart/signed@) {
551 pop @message_parts;
552 }
553 my $is_first_part=1;
554 foreach my $message_part (@message_parts) {
555 if ($is_first_part && $text ne "") {$is_first_part=0;}
556
557 if ($mimetype eq "multipart/digest") {
558 # default type - RTFRFC!! Set if not already set
559 $message_part =~ m@^(.*)\n\r?\n@s;
560 my $part_header=$1;
561 if ($part_header !~ m@^content-type@mi) {
562 $message_part="Content-type: message/rfc822\n"
563 . $message_part; # prepend default type
564 }
565 }
566
567 $text .= $self->process_multipart_part($default_header_encoding,
568 $message_part,
569 $is_first_part);
570 } # foreach message part.
571 } else {
572 # we can't handle this multipart type (not mixed or alternative)
573 # the RFC also mentions "parallel".
574 }
575 } # end of ($mimetype =~ multipart)
576 elsif ($mimetype =~ m@message/rfc822@) {
577 my $msg_header = $text;
578 $msg_header =~ s/\r?\n\r?\n(.*)$//s;
579 $text = $1;
580
581 if ($msg_header =~ /^content\-type:\s*([\w\.\-\/]+)\s*\;?\s*(.+?)\s*$/mi)
582 {
583 $mimetype=$1;
584 $mimeinfo=$2;
585 $mimetype =~ tr/[A-Z]/[a-z]/;
586
587 my $msg_text;
588 if ($mimetype =~ m@multipart/@) {
589 $msg_text = $self->text_from_mime_message($mimetype, $mimeinfo,
590 $default_header_encoding,
591 $text);
592 } else {
593 $msg_text=$self->text_from_part($text,$msg_header);
594 }
595
596 my $brief_header=text_into_html(get_brief_headers($msg_header));
597 $text= "\n<b>&lt;&lt;attached message&gt;&gt;</b><br>";
598 $text.= "<table><tr><td width=\"5%\"> </td>\n";
599 $text.="<td>" . $brief_header . "\n</p>" . $msg_text
600 . "</td></tr></table>";
601 }
602 } else {
603 # we don't do any processing of the content.
604 }
605
606 return $text;
607}
608
609
610
611# used for turning a message id into a more friendly string for greenstone
612sub escape_msg_id {
613#msgid
614 my $id=shift;
615 chomp $id; $id =~ s!\s!!g; # remove spaces
616 $id =~ s![<>\[\]]!!g; # remove [ ] < and >
617 $id =~ s![_&]!-!g; # replace symbols that might cause problems
618 $id =~ s!\.!-!g; # . means section to greenstone doc ids!
619 $id =~ s!@!-!g; # replace @ symbol, to avoid spambots
620 return $id;
621}
622
623
624
625sub process_multipart_part {
626 my $self = shift;
627 my $default_header_encoding = shift;
628 my $message_part = shift;
629 my $is_first_part = shift;
630
631 my $return_text="";
632 my $part_header=$message_part;
633 my $part_body;
634 if ($message_part=~ /^\s*\n/) {
635 # no header... use defaults
636 $part_body=$message_part;
637 $part_header="Content-type: text/plain; charset=us-ascii";
638 } elsif ($part_header=~s/\r?\n\r?\n(.*)$//s) {
639 $part_body=$1;
640 } else {
641 # something's gone wrong...
642 $part_header="";
643 $part_body=$message_part;
644 }
645
646 $part_header =~ s/\r?\n[\t\ ]+/ /gs; #unfold
647 my $part_content_type="";
648 my $part_content_info="";
649
650 if ($part_header =~ m@^content\-type:\s*([\w\.\-/]+)\s*(\;.*)?$@mi) {
651 $part_content_type=$1; $part_content_type =~ tr/A-Z/a-z/;
652 $part_content_info=$2;
653 if (!defined($part_content_info)) {
654 $part_content_info="";
655 } else {
656 $part_content_info =~ s/^\;\s*//;
657 $part_content_info =~ s/\s*$//;
658 }
659 }
660 my $filename="";
661 if ($part_header =~ m@name=\"?([^\"\n]+)\"?@mis) {
662 $filename=$1;
663 $filename =~ s@\r?\s*$@@; # remove trailing space, if any
664 # decode the filename
665 $self->decode_header_value($default_header_encoding, \$filename);
666
667 }
668
669 # disposition - either inline or attachment.
670 # NOT CURRENTLY USED - we display all text types instead...
671 # $part_header =~ /^content\-disposition:\s*([\w+])/mis;
672
673 # add <<attachment>> to each part except the first...
674 if (!$is_first_part) {
675 $return_text.="\n<p><hr><strong>&lt;&lt;attachment&gt;&gt;";
676 # add part info header
677 my $header_text = "<br>Type: $part_content_type<br>\n";
678 if ($filename ne "") {
679 $header_text .= "Filename: $filename\n";
680 }
681 $header_text =~ s@_@\\_@g;
682 $return_text .= $header_text . "</strong></p>\n<p>\n";
683 }
684
685 if ($part_content_type =~ m@text/@)
686 {
687 # $message_part includes the mime part headers
688 my $part_text = $self->text_from_part($message_part);
689 if ($part_content_type !~ m@text/(ht|x)ml@) {
690 $part_text = text_into_html($part_text);
691 }
692 if ($part_text eq "") {
693 $part_text = ' ';
694 }
695 $return_text .= $part_text;
696 } elsif ($part_content_type =~ m@message/rfc822@) {
697 # This is a forwarded message
698 my $message_part_headers=$part_body;
699 $message_part_headers=~s/\r?\n\r?\n(.*)$//s;
700 my $message_part_body=$1;
701 $message_part_headers =~ s/\r?\n[\t\ ]+/ /gs; #unfold
702
703 my $rfc822_formatted_body=""; # put result in here
704 if ($message_part_headers =~
705 /^content\-type:\s*([\w\.\-\/]+)\s*(\;.*)?$/ims)
706 {
707 # The message header uses MIME flags
708 my $message_content_type=$1;
709 my $message_content_info=$2;
710 if (!defined($message_content_info)) {
711 $message_content_info="";
712 } else {
713 $message_content_info =~ s/^\;\s*//;
714 $message_content_info =~ s/\s*$//;
715 }
716 $message_content_type =~ tr/A-Z/a-z/;
717 if ($message_content_type =~ /multipart/) {
718 $rfc822_formatted_body=
719 $self->text_from_mime_message($message_content_type,
720 $message_content_info,
721 $default_header_encoding,
722 $message_part_body);
723 } else {
724 $message_part_body=$self->text_from_part($part_body,
725 $message_part_headers);
726 $rfc822_formatted_body=text_into_html($message_part_body);
727 }
728 } else {
729 # message doesn't use MIME flags
730 $rfc822_formatted_body=text_into_html($message_part_body);
731 $rfc822_formatted_body =~ s@_@\\_@g;
732 }
733 # Add the returned text to the output
734 # don't put all the headers...
735# $message_part_headers =~ s/^(X\-.*|received|message\-id|return\-path):.*\n//img;
736 my $brief_headers=get_brief_headers($message_part_headers);
737 $return_text.=text_into_html($brief_headers);
738 $return_text.="</p><p>\n";
739 $return_text.=$rfc822_formatted_body;
740 $return_text.="</p>\n";
741 # end of message/rfc822
742 } elsif ($part_content_type =~ /multipart/) {
743 # recurse again
744
745 my $tmptext= $self->text_from_mime_message($part_content_type,
746 $part_content_info,
747 $default_header_encoding,
748 $part_body);
749 $return_text.=$tmptext;
750 } else {
751 # this part isn't text/* or another message...
752 if ($is_first_part) {
753 # this is the first part of a multipart, or only part!
754 $return_text="\n<p><hr><strong>&lt;&lt;attachment&gt;&gt;";
755 # add part info header
756 my $header_text="<br>Type: $part_content_type<br>\n";
757 $header_text.="Filename: $filename</strong></p>\n<p>\n";
758 $header_text =~ s@_@\\_@g;
759 $return_text.=$header_text;
760 }
761
762 # save attachment by default
763 if (!$self->{'no_attachments'}
764 && $filename ne "") { # this part has a file...
765 my $encoding="8bit";
766 if ($part_header =~
767 /^content-transfer-encoding:\s*(\w+)/mi ) {
768 $encoding=$1; $encoding =~ tr/A-Z/a-z/;
769 }
770 my $tmpdir=&util::filename_cat($ENV{'GSDLHOME'}, "tmp");
771 my $save_filename=$filename;
772
773 # make sure we don't clobber files with same name;
774 # need to keep state between .mbx files
775 my $assoc_files=$self->{'assoc_filenames'};
776 if ($assoc_files->{$filename}) { # it's been set...
777 $assoc_files->{$filename}++;
778 $filename =~ m/(.+)\.(\w+)$/;
779 my ($filestem, $ext)=($1,$2);
780 $save_filename="${filestem}_"
781 . $assoc_files->{$filename} . ".$ext";
782 } else { # first file with this name
783 $assoc_files->{$filename}=1;
784 }
785 my $tmp_filename = &util::filename_cat($tmpdir, $save_filename);
786 open (SAVE, ">$tmp_filename") ||
787 warn "EMAILPlug: Can't save attachment as $tmp_filename: $!";
788 binmode(SAVE); # needed on Windows
789 my $part_text = $message_part;
790 $part_text =~ s/(.*?)\r?\n\r?\n//s; # remove header
791 if ($encoding eq "base64") {
792 print SAVE base64_decode($part_text);
793 } elsif ($encoding eq "quoted-printable") {
794 print SAVE qp_decode($part_text);
795 } else { # 7bit, 8bit, binary, etc...
796 print SAVE $part_text;
797 }
798 close SAVE;
799 my $doc_obj=$self->{'doc_obj'};
800 $doc_obj->associate_file("$tmp_filename",
801 "$save_filename",
802 $part_content_type # mimetype
803 );
804 # add this file to the list of tmp files for deleting later
805 push(@{$self->{'tmp_file_paths'}}, $tmp_filename);
806
807 my $outhandle=$self->{'outhandle'};
808 print $outhandle "EmailPlugin: saving attachment \"$filename\"\n"; #
809
810 # be nice if "download" was a translatable macro :(
811 $return_text .="<a href=\"_httpdocimg_/$save_filename\">download</a>";
812 } # end of save attachment
813 } # end of !text/message part
814
815
816 return $return_text;
817}
818
819
820# Return only the "important" headers from a set of message headers
821sub get_brief_headers {
822 my $msg_header = shift;
823 my $brief_header = "";
824
825 # Order matters!
826 if ($msg_header =~ /^(From:.*)$/im) {$brief_header.="$1\n";}
827 if ($msg_header =~ /^(To:.*)$/im) {$brief_header.="$1\n";}
828 if ($msg_header =~ /^(Cc:.*)$/im) {$brief_header.="$1\n";}
829 if ($msg_header =~ /^(Subject:.*)$/im) {$brief_header.="$1\n";}
830 if ($msg_header =~ /^(Date:.*)$/im) {$brief_header.="$1\n";}
831
832 return $brief_header;
833}
834
835
836# Process a MIME part. Return "" if we can't decode it.
837# should only be called for parts with type "text/*" ?
838# Either pass the entire mime part (including the part's header),
839# or pass the mime part's text and optionally the part's header.
840sub text_from_part {
841 my $self = shift;
842 my $text = shift || '';
843 my $part_header = shift;
844
845
846 my $type="text/plain"; # default, overridden from part header
847 my $charset=undef; # convert2unicode() will guess if necessary
848
849 if (! $part_header) { # no header argument was given. check the body
850 $part_header = $text;
851 # check for empty part header (leading blank line)
852 if ($text =~ /^\s*\r?\n/) {
853 $part_header="Content-type: text/plain; charset=us-ascii";
854 } else {
855 $part_header =~ s/\r?\n\r?\n(.*)$//s;
856 $text=$1; if (!defined($text)) {$text="";}
857 }
858 $part_header =~ s/\r?\n[\t ]+/ /gs; #unfold
859 }
860
861 if ($part_header =~
862 /content\-type:\s*([\w\.\-\/]+).*?charset=\"?([^\;\"\s]+)\"?/is) {
863 $type=$1;
864 $charset=$2;
865 }
866 my $encoding="";
867 if ($part_header =~ /^content\-transfer\-encoding:\s*([^\s]+)/mis) {
868 $encoding=$1; $encoding=~tr/A-Z/a-z/;
869 }
870 # Content-Transfer-Encoding is per-part
871 if ($encoding ne "") {
872 if ($encoding =~ /quoted\-printable/) {
873 $text=qp_decode($text);
874 } elsif ($encoding =~ /base64/) {
875 $text=base64_decode($text);
876 } elsif ($encoding !~ /[78]bit/) { # leave 7/8 bit as is.
877 # rfc2045 also allows binary, which we ignore (for now).
878 my $outhandle=$self->{'outhandle'};
879 print $outhandle "EmailPlugin: unknown transfer encoding: $encoding\n";
880 return "";
881 }
882 }
883
884 if ($type eq "text/html") {
885 # only get stuff between <body> tags, or <html> tags.
886 $text =~ s@^.*<html[^>]*>@@is;
887 $text =~ s@</html>.*$@@is;
888 $text =~ s/^.*?<body[^>]*>//si;
889 $text =~ s/<\/body>.*$//si;
890 }
891 elsif ($type eq "text/xml") {
892 $text=~s/</&lt;/g;$text=~s/>/&gt;/g;
893 $text="<pre>\n$text\n</pre>\n";
894 }
895 # convert to unicode
896 $self->convert2unicode($charset, \$text);
897 $text =~ s@_@\\_@g; # protect against GS macro language
898 return $text;
899}
900
901
902
903
904# decode quoted-printable text
905sub qp_decode {
906 my $text=shift;
907
908 # if a line ends with "=\s*", it is a soft line break, otherwise
909 # keep in any newline characters.
910
911 $text =~ s/=\s*\r?\n//mg;
912 $text =~ s/=([0-9A-Fa-f]{2})/chr (hex "0x$1")/eg;
913 return $text;
914}
915
916# decode base64 text. This is fairly slow (since it's interpreted perl rather
917# than compiled XS stuff like in the ::MIME modules, but this is more portable
918# for us at least).
919# see rfc2045 for description, but basically, bits 7 and 8 are set to zero;
920# 4 bytes of encoded text become 3 bytes of binary - remove 2 highest bits
921# from each encoded byte.
922
923
924sub base64_decode {
925 my $enc_text = shift;
926# A=>0, B=>1, ..., '+'=>62, '/'=>63
927# also '=' is used for padding at the end, but we remove it anyway.
928 my $mimechars="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
929# map each MIME char into it's value, for more efficient lookup.
930 my %index;
931 map { $index{$_} = index ($mimechars, $_) } (split ('', $mimechars));
932# remove all non-base64 chars. eval to get variable in transliteration...
933# also remove '=' - we'll assume (!!) that there are no errors in the encoding
934 eval "\$enc_text =~ tr|$mimechars||cd";
935 my $decoded="";
936 while (length ($enc_text)>3)
937 {
938 my $fourchars=substr($enc_text,0,4,"");
939 my @chars=(split '',$fourchars);
940 $decoded.=chr( $index{$chars[0]} << 2 | $index{$chars[1]} >> 4);
941 $decoded.=chr( ($index{$chars[1]} & 15) << 4 | $index{$chars[2]} >> 2);
942 $decoded.=chr( ($index{$chars[2]} & 3 ) << 6 | $index{$chars[3]});
943 }
944# if there are any input chars left, there are either
945# 2 encoded bytes (-> 1 raw byte) left or 3 encoded (-> 2 raw) bytes left.
946 my @chars=(split '',$enc_text);
947 if (length($enc_text)) {
948 $decoded.=chr($index{$chars[0]} << 2 | (int $index{$chars[1]} >> 4));
949 }
950 if (length($enc_text)==3) {
951 $decoded.=chr( ($index{$chars[1]} & 15) << 4 | $index{$chars[2]} >> 2);
952 }
953 return $decoded;
954}
955
956# returns 0 if valid utf-8, 1 if invalid
957sub is_utf8 {
958 my $self = shift;
959 my $textref = shift;
960
961 $$textref =~ m/^/g; # to set \G
962 my $badbytesfound=0;
963 while ($$textref =~ m!\G.*?([\x80-\xff]+)!sg) {
964 my $highbytes=$1;
965 my $highbyteslength=length($highbytes);
966 # replace any non utf8 complaint bytes
967 $highbytes =~ /^/g; # set pos()
968 while ($highbytes =~
969 m!\G (?: [\xc0-\xdf][\x80-\xbf] | # 2 byte utf-8
970 [\xe0-\xef][\x80-\xbf]{2} | # 3 byte
971 [\xf0-\xf7][\x80-\xbf]{3} | # 4 byte
972 [\xf8-\xfb][\x80-\xbf]{4} | # 5 byte
973 [\xfc-\xfd][\x80-\xbf]{5} # 6 byte
974 )*([\x80-\xff])? !xg
975 ) {
976 my $badbyte=$1;
977 if (!defined $badbyte) {next} # hit end of string
978 return 1;
979 }
980 }
981 return 0;
982}
983
984# words with non ascii characters in header values must be encoded in the
985# following manner =?<charset>?[BQ]?<data>?= (rfc2047)
986
987sub decode_header_value {
988 my $self = shift(@_);
989 my ($default_header_encoding, $textref) = @_;
990
991 if (!$$textref) {
992 # nothing to do!
993 return;
994 }
995 my $value = $$textref;
996 # decode headers if stored using =?<charset>?[BQ]?<data>?= (rfc2047)
997 if ($value =~ /=\?.*\?[BbQq]\?.*\?=/) {
998 my $original_value=$value;
999 my $encoded=$value;
1000 $value="";
1001 # we should ignore spaces between consecutive encoded-texts
1002 $encoded =~ s@\?=\s+=\?@\?==\?@g;
1003 while ($encoded =~ s/(.*?)=\?([^\?]*)\?([bq])\?([^\?]+)\?=//i) {
1004 my ($charset, $encoding, $data)=($2,$3,$4);
1005 my ($decoded_data);
1006 my $leading_chars = "$1";
1007 $self->convert2unicode($default_header_encoding, \$leading_chars);
1008 $value.=$leading_chars;
1009
1010 $data=~s/^\s*//; $data=~s/\s*$//; # strip whitespace from ends
1011 chomp $data;
1012 $encoding =~ tr/BQ/bq/;
1013 if ($encoding eq "q") { # quoted printable
1014 $data =~ s/_/\ /g; # from rfc2047 (sec 4.2.2)
1015 $decoded_data=qp_decode($data);
1016 # qp_decode adds \n, which is default for body text
1017 chomp($decoded_data);
1018 } else { # base 64
1019 $decoded_data=base64_decode($data);
1020 }
1021 $self->convert2unicode($charset, \$decoded_data);
1022 $value .= $decoded_data;
1023 } # end of while loop
1024
1025 # get any trailing characters
1026 $self->convert2unicode($default_header_encoding, \$encoded);
1027 $value.=$encoded;
1028
1029 if ($value =~ /^\s*$/) { # we couldn't extract anything...
1030 $self->convert2unicode($default_header_encoding,
1031 \$original_value);
1032 $value=$original_value;
1033 }
1034 $$textref = $value;
1035 } # end of if =?...?=
1036
1037 # In the absense of other charset information, assume the
1038 # header is the default (usually "iso_8859_1") and convert to unicode.
1039 else {
1040 $self->convert2unicode($default_header_encoding, $textref);
1041 }
1042
1043}
1044
1045
1046
1047sub convert2unicode {
1048 my $self = shift(@_);
1049 my ($charset, $textref) = @_;
1050
1051 if (!$$textref) {
1052 # nothing to do!
1053 return;
1054 }
1055
1056 if (! defined $charset) {
1057 # check if we have valid utf-8
1058 if ($self->is_utf8($textref)) { $charset = "utf8" }
1059
1060 # default to latin
1061 $charset = "iso_8859_1" if ! defined($charset);
1062 }
1063
1064 # first get our character encoding name in the right form.
1065 $charset =~ tr/A-Z/a-z/; # lowercase
1066 $charset =~ s/\-/_/g;
1067 if ($charset =~ /gb_?2312/) { $charset="gb" }
1068 # assumes EUC-KR, not ISO-2022 !?
1069 $charset =~ s/^ks_c_5601_1987/korean/;
1070 if ($charset eq 'utf_8') {$charset='utf8'}
1071
1072 my $outhandle = $self->{'outhandle'};
1073
1074 if ($charset eq "utf8") {
1075 # no conversion needed, but lets check that it's valid utf8
1076 # see utf-8 manpage for valid ranges
1077 $$textref =~ m/^/g; # to set \G
1078 my $badbytesfound=0;
1079 while ($$textref =~ m!\G.*?([\x80-\xff]+)!sg) {
1080 my $highbytes=$1;
1081 my $highbyteslength=length($highbytes);
1082 # replace any non utf8 complaint bytes
1083 $highbytes =~ /^/g; # set pos()
1084 while ($highbytes =~
1085 m!\G (?: [\xc0-\xdf][\x80-\xbf] | # 2 byte utf-8
1086 [\xe0-\xef][\x80-\xbf]{2} | # 3 byte
1087 [\xf0-\xf7][\x80-\xbf]{3} | # 4 byte
1088 [\xf8-\xfb][\x80-\xbf]{4} | # 5 byte
1089 [\xfc-\xfd][\x80-\xbf]{5} # 6 byte
1090 )*([\x80-\xff])? !xg
1091 ) {
1092 my $badbyte=$1;
1093 if (!defined $badbyte) {next} # hit end of string
1094 my $pos=pos($highbytes);
1095 substr($highbytes, $pos-1, 1, "\xc2\x80");
1096 # update the position to continue searching (for \G)
1097 pos($highbytes) = $pos+1; # set to just after the \x80
1098 $badbytesfound=1;
1099 }
1100 if ($badbytesfound==1) {
1101 # claims to be utf8, but it isn't!
1102 print $outhandle "EmailPlugin: Headers claim utf-8 but bad bytes "
1103 . "detected and removed.\n";
1104
1105 my $replength=length($highbytes);
1106 my $textpos=pos($$textref);
1107 # replace bad bytes with good bytes
1108 substr( $$textref, $textpos-$replength,
1109 $replength, $highbytes);
1110 # update the position to continue searching (for \G)
1111 pos($$textref)=$textpos+($replength-$highbyteslength);
1112 }
1113 }
1114 return;
1115 }
1116
1117 # It appears that we can't always trust ascii text so we'll treat it
1118 # as iso-8859-1 (letting characters above 0x80 through without
1119 # converting them to utf-8 will result in invalid XML documents
1120 # which can't be parsed at build time).
1121 $charset = "iso_8859_1" if ($charset eq "us_ascii" || $charset eq "ascii");
1122
1123 if ($charset eq "iso_8859_1") {
1124 # test if the mailer lied, and it has win1252 chars in it...
1125 # 1252 has characters between 0x80 and 0x9f, 8859-1 doesn't
1126 if ($$textref =~ m/[\x80-\x9f]/) {
1127 print $outhandle "EmailPlugin: Headers claim ISO charset but MS ";
1128 print $outhandle "codepage 1252 detected.\n";
1129 $charset = "windows_1252";
1130 }
1131 }
1132 my $utf8_text=&unicode::unicode2utf8(&unicode::convert2unicode($charset,$textref));
1133
1134 if ($utf8_text ne "") {
1135 $$textref=$utf8_text;
1136 } else {
1137 # we didn't get any text... unsupported encoding perhaps? Or it is
1138 # empty anyway. We'll try to continue, assuming 8859-1. We could strip
1139 # characters out here if this causes problems...
1140 my $outhandle=$self->{'outhandle'};
1141 print $outhandle "EmailPlugin: falling back to iso-8859-1\n";
1142 $$textref=&unicode::unicode2utf8(&unicode::convert2unicode("iso_8859_1",$textref));
1143
1144 }
1145}
1146
1147
1148sub set_OID {
1149 my $self = shift (@_);
1150 my ($doc_obj, $id, $segment_number) = @_;
1151
1152 if ( exists $doc_obj->{'msgid'} ) {
1153 $doc_obj->set_OID($doc_obj->{'msgid'});
1154 } else {
1155 $doc_obj->set_OID("$id\_$segment_number");
1156 }
1157}
1158
1159
1160# Perl packages have to return true if they are run.
11611;
Note: See TracBrowser for help on using the repository browser.