source: gsdl/branches/2.80-fixed/perllib/plugins/EMAILPlug.pm@ 16345

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