1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 # General Public License for more details.
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
30 # CONTRIBUTION SUBMISSION POLICY:
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
47 # END BPS TAGGED BLOCK }}}
49 package RT::EmailParser;
52 use base qw/RT::Base/;
62 use File::Temp qw/tempdir/;
66 RT::EmailParser - helper functions for parsing parts from incoming
81 Returns a new RT::EmailParser object
87 my $class = ref($proto) || $proto;
89 bless ($self, $class);
94 =head2 SmartParseMIMEEntityFromScalar Message => SCALAR_REF [, Decode => BOOL, Exact => BOOL ] }
96 Parse a message stored in a scalar from scalar_ref.
100 sub SmartParseMIMEEntityFromScalar {
102 my %args = ( Message => undef, Decode => 1, Exact => 0, @_ );
105 my ( $fh, $temp_file );
108 # on NFS and NTFS, it is possible that tempfile() conflicts
109 # with other processes, causing a race condition. we try to
110 # accommodate this by pausing and retrying.
112 if ( $fh, $temp_file ) =
113 eval { File::Temp::tempfile( undef, UNLINK => 0 ) };
121 print $fh $args{'Message'};
123 if ( -f $temp_file ) {
125 # We have to trust the temp file's name -- untaint it
126 $temp_file =~ /(.*)/;
127 my $entity = $self->ParseMIMEEntityFromFile( $1, $args{'Decode'}, $args{'Exact'} );
134 $self->RescueOutlook;
136 #If for some reason we weren't able to parse the message using a temp file
137 # try it with a scalar
138 if ( $@ || !$self->Entity ) {
139 return $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'}, $args{'Exact'} );
145 =head2 ParseMIMEEntityFromSTDIN
147 Parse a message from standard input
151 sub ParseMIMEEntityFromSTDIN {
153 return $self->ParseMIMEEntityFromFileHandle(\*STDIN, @_);
156 =head2 ParseMIMEEntityFromScalar $message
158 Takes either a scalar or a reference to a scalar which contains a stringified MIME message.
161 Returns true if it wins.
162 Returns false if it loses.
166 sub ParseMIMEEntityFromScalar {
168 return $self->_ParseMIMEEntity( shift, 'parse_data', @_ );
171 =head2 ParseMIMEEntityFromFilehandle *FH
173 Parses a mime entity from a filehandle passed in as an argument
177 sub ParseMIMEEntityFromFileHandle {
179 return $self->_ParseMIMEEntity( shift, 'parse', @_ );
182 =head2 ParseMIMEEntityFromFile
184 Parses a mime entity from a filename passed in as an argument
188 sub ParseMIMEEntityFromFile {
190 return $self->_ParseMIMEEntity( shift, 'parse_open', @_ );
194 sub _ParseMIMEEntity {
198 my $postprocess = (@_ ? shift : 1);
201 # Create a new parser object:
202 my $parser = MIME::Parser->new();
203 $self->_SetupMIMEParser($parser);
204 $parser->decode_bodies(0) if $exact;
206 # TODO: XXX 3.0 we really need to wrap this in an eval { }
207 unless ( $self->{'entity'} = $parser->$method($message) ) {
208 $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages");
209 # Try again, this time without extracting nested messages
210 $parser->extract_nested_messages(0);
211 unless ( $self->{'entity'} = $parser->$method($message) ) {
212 $RT::Logger->crit("couldn't parse MIME stream");
217 $self->_PostProcessNewEntity if $postprocess;
219 return $self->{'entity'};
224 return unless $self->{'entity'};
226 my @parts = $self->{'entity'}->parts_DFS;
227 $self->_DecodeBody($_) foreach @parts;
234 my $old = $entity->bodyhandle or return;
235 return unless $old->is_encoded;
237 require MIME::Decoder;
238 my $encoding = $entity->head->mime_encoding;
239 my $decoder = MIME::Decoder->new($encoding);
240 unless ( $decoder ) {
241 $RT::Logger->error("Couldn't find decoder for '$encoding', switching to binary");
247 # XXX: use InCore for now, but later must switch to files
248 my $new = MIME::Body::InCore->new();
252 my $source = $old->open('r') or die "couldn't open body: $!";
253 my $destination = $new->open('w') or die "couldn't open body: $!";
256 eval { $decoder->decode($source, $destination) };
257 $RT::Logger->error($@) if $@;
259 $source->close or die "can't close: $!";
260 $destination->close or die "can't close: $!";
262 $entity->bodyhandle( $new );
265 =head2 _PostProcessNewEntity
267 cleans up and postprocesses a newly parsed MIME Entity
271 sub _PostProcessNewEntity {
274 #Now we've got a parsed mime object.
276 # Unfold headers that are have embedded newlines
277 # Better do this before conversion or it will break
278 # with multiline encoded Subject (RFC2047) (fsck.com #5594)
281 # try to convert text parts into utf-8 charset
282 RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
285 =head2 ParseCcAddressesFromHead HASHREF
287 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
288 Returns a list of all email addresses in the To and Cc
289 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
290 email address and anything that the RT->Config->Get('RTAddressRegexp') matches.
294 sub ParseCcAddressesFromHead {
298 CurrentUser => undef,
304 my @ToObjs = Email::Address->parse( $self->Head->get('To') );
305 my @CcObjs = Email::Address->parse( $self->Head->get('Cc') );
307 foreach my $AddrObj ( @ToObjs, @CcObjs ) {
308 my $Address = $AddrObj->address;
309 my $user = RT::User->new(RT->SystemUser);
310 $Address = $user->CanonicalizeEmailAddress($Address);
311 next if lc $args{'CurrentUser'}->EmailAddress eq lc $Address;
312 next if $self->IsRTAddress($Address);
314 push ( @Addresses, $Address );
320 =head2 IsRTaddress ADDRESS
322 Takes a single parameter, an email address.
323 Returns true if that address matches the C<RTAddressRegexp> config option.
324 Returns false, otherwise.
333 if ( my $address_re = RT->Config->Get('RTAddressRegexp') ) {
334 return $address =~ /$address_re/i ? 1 : undef;
337 # we don't warn here, but do in config check
338 if ( my $correspond_address = RT->Config->Get('CorrespondAddress') ) {
339 return 1 if lc $correspond_address eq lc $address;
341 if ( my $comment_address = RT->Config->Get('CommentAddress') ) {
342 return 1 if lc $comment_address eq lc $address;
345 my $queue = RT::Queue->new( RT->SystemUser );
346 $queue->LoadByCols( CorrespondAddress => $address );
347 return 1 if $queue->id;
349 $queue->LoadByCols( CommentAddress => $address );
350 return 1 if $queue->id;
356 =head2 CullRTAddresses ARRAY
358 Takes a single argument, an array of email addresses.
359 Returns the same array with any IsRTAddress()es weeded out.
364 sub CullRTAddresses {
366 my @addresses = (@_);
368 return grep { !$self->IsRTAddress($_) } @addresses;
375 # LookupExternalUserInfo is a site-definable method for synchronizing
376 # incoming users with an external data source.
378 # This routine takes a tuple of EmailAddress and FriendlyName
379 # EmailAddress is the user's email address, ususally taken from
380 # an email message's From: header.
381 # FriendlyName is a freeform string, ususally taken from the "comment"
382 # portion of an email message's From: header.
384 # If you define an AutoRejectRequest template, RT will use this
385 # template for the rejection message.
388 =head2 LookupExternalUserInfo
390 LookupExternalUserInfo is a site-definable method for synchronizing
391 incoming users with an external data source.
393 This routine takes a tuple of EmailAddress and FriendlyName
394 EmailAddress is the user's email address, ususally taken from
395 an email message's From: header.
396 FriendlyName is a freeform string, ususally taken from the "comment"
397 portion of an email message's From: header.
399 It returns (FoundInExternalDatabase, ParamHash);
401 FoundInExternalDatabase must be set to 1 before return if the user
402 was found in the external database.
404 ParamHash is a Perl parameter hash which can contain at least the
405 following fields. These fields are used to populate RT's users
406 database when the user is created.
408 EmailAddress is the email address that RT should use for this user.
409 Name is the 'Name' attribute RT should use for this user.
410 'Name' is used for things like access control and user lookups.
411 RealName is what RT should display as the user's name when displaying
416 sub LookupExternalUserInfo {
418 my $EmailAddress = shift;
419 my $RealName = shift;
421 my $FoundInExternalDatabase = 1;
424 #Name is the RT username you want to use for this user.
425 $params{'Name'} = $EmailAddress;
426 $params{'EmailAddress'} = $EmailAddress;
427 $params{'RealName'} = $RealName;
429 return ($FoundInExternalDatabase, %params);
434 Return the parsed head from this message
440 return $self->Entity->head;
445 Return the parsed Entity from this message
451 return $self->{'entity'};
456 =head2 _SetupMIMEParser $parser
458 A private instance method which sets up a mime parser to do its job
463 ## TODO: Does it make sense storing to disk at all? After all, we
464 ## need to put each msg as an in-core scalar before saving it to
465 ## the database, don't we?
467 ## At the same time, we should make sure that we nuke attachments
468 ## Over max size and return them
470 sub _SetupMIMEParser {
474 # Set up output directory for files; we use $RT::VarPath instead
475 # of File::Spec->tmpdir (e.g., /tmp) beacuse it isn't always
478 if ( -w $RT::VarPath ) {
479 $tmpdir = File::Temp::tempdir( DIR => $RT::VarPath, CLEANUP => 1 );
480 } elsif (-w File::Spec->tmpdir) {
481 $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
483 $RT::Logger->crit("Neither the RT var directory ($RT::VarPath) nor the system tmpdir (@{[File::Spec->tmpdir]}) are writable; falling back to in-memory parsing!");
486 #If someone includes a message, extract it
487 $parser->extract_nested_messages(1);
488 $parser->extract_uuencode(1); ### default is false
491 # If we got a writable tmpdir, write to disk
492 push ( @{ $self->{'AttachmentDirs'} ||= [] }, $tmpdir );
493 $parser->output_dir($tmpdir);
494 $parser->filer->ignore_filename(1);
496 # Set up the prefix for files with auto-generated names:
497 $parser->output_prefix("part");
499 # From the MIME::Parser docs:
500 # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope"
501 # Turns out that the default is to recycle tempfiles
502 # Temp files should never be recycled, especially when running under perl taint checking
504 $parser->tmp_recycling(0) if $parser->can('tmp_recycling');
506 # Otherwise, fall back to storing it in memory
507 $parser->output_to_core(1);
508 $parser->tmp_to_core(1);
509 $parser->use_inner_files(1);
514 =head2 ParseEmailAddress string
516 Returns a list of Email::Address objects
517 Works around the bug that Email::Address 1.889 and earlier
518 doesn't handle local-only email addresses (when users pass
519 in just usernames on the RT system in fields that expect
522 We don't handle the case of
523 bob, fred@bestpractical.com
524 because we don't want to fail parsing
525 bob, "Falcone, Fred" <fred@bestpractical.com>
526 The next release of Email::Address will have a new method
527 we can use that removes the bandaid
531 sub ParseEmailAddress {
533 my $address_string = shift;
535 $address_string =~ s/^\s+|\s+$//g;
538 # if it looks like a username / local only email
539 if ($address_string !~ /@/ && $address_string =~ /^\w+$/) {
540 my $user = RT::User->new( RT->SystemUser );
541 my ($id, $msg) = $user->Load($address_string);
543 push @addresses, Email::Address->new($user->Name,$user->EmailAddress);
545 $RT::Logger->error("Unable to parse an email address from $address_string: $msg");
548 @addresses = Email::Address->parse($address_string);
557 Outlook 2007/2010 have a bug when you write an email with the html format.
558 it will send a 'multipart/alternative' with both 'text/plain' and 'text/html'
559 in it. it's cool to have a 'text/plain' part, but the problem is the part is
560 not so right: all the "\n" in your main message will become "\n\n" :/
562 this method will fix this bug, i.e. replaces "\n\n" to "\n".
563 return 1 if it does find the problem in the entity and get it fixed.
570 my $mime = $self->Entity();
573 my $mailer = $mime->head->get('X-Mailer');
574 # 12.0 is outlook 2007, 14.0 is 2010
575 if ( $mailer && $mailer =~ /Microsoft(?:.*?)Outlook 1[2-4]\./ ) {
577 if ( $mime->head->get('Content-Type') =~ m{multipart/mixed} ) {
578 my $first = $mime->parts(0);
579 if ( $first && $first->head->get('Content-Type') =~ m{multipart/alternative} )
581 my $inner_first = $first->parts(0);
582 if ( $inner_first && $inner_first->head->get('Content-Type') =~ m{text/plain} )
584 $text_part = $inner_first;
588 elsif ( $mime->head->get('Content-Type') =~ m{multipart/alternative} ) {
589 my $first = $mime->parts(0);
590 if ( $first && $first->head->get('Content-Type') =~ m{text/plain} ) {
597 # use the unencoded string
598 my $content = $text_part->bodyhandle->as_string;
599 if ( $content =~ s/\n\n/\n/g ) {
600 # only write only if we did change the content
601 if ( my $io = $text_part->open("w") ) {
602 $io->print($content);
607 $RT::Logger->error("can't write to body");
618 File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1)
619 if $self->{'AttachmentDirs'};
624 RT::Base->_ImportOverlays();