1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2011 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/;
61 use File::Temp qw/tempdir/;
65 RT::EmailParser - helper functions for parsing parts from incoming
80 Returns a new RT::EmailParser object
86 my $class = ref($proto) || $proto;
88 bless ($self, $class);
93 =head2 SmartParseMIMEEntityFromScalar Message => SCALAR_REF [, Decode => BOOL, Exact => BOOL ] }
95 Parse a message stored in a scalar from scalar_ref.
99 sub SmartParseMIMEEntityFromScalar {
101 my %args = ( Message => undef, Decode => 1, Exact => 0, @_ );
104 my ( $fh, $temp_file );
107 # on NFS and NTFS, it is possible that tempfile() conflicts
108 # with other processes, causing a race condition. we try to
109 # accommodate this by pausing and retrying.
111 if ( $fh, $temp_file ) =
112 eval { File::Temp::tempfile( undef, UNLINK => 0 ) };
120 print $fh $args{'Message'};
122 if ( -f $temp_file ) {
124 # We have to trust the temp file's name -- untaint it
125 $temp_file =~ /(.*)/;
126 my $entity = $self->ParseMIMEEntityFromFile( $1, $args{'Decode'}, $args{'Exact'} );
133 $self->RescueOutlook;
135 #If for some reason we weren't able to parse the message using a temp file
136 # try it with a scalar
137 if ( $@ || !$self->Entity ) {
138 return $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'}, $args{'Exact'} );
144 =head2 ParseMIMEEntityFromSTDIN
146 Parse a message from standard input
150 sub ParseMIMEEntityFromSTDIN {
152 return $self->ParseMIMEEntityFromFileHandle(\*STDIN, @_);
155 =head2 ParseMIMEEntityFromScalar $message
157 Takes either a scalar or a reference to a scalar which contains a stringified MIME message.
160 Returns true if it wins.
161 Returns false if it loses.
165 sub ParseMIMEEntityFromScalar {
167 return $self->_ParseMIMEEntity( shift, 'parse_data', @_ );
170 =head2 ParseMIMEEntityFromFilehandle *FH
172 Parses a mime entity from a filehandle passed in as an argument
176 sub ParseMIMEEntityFromFileHandle {
178 return $self->_ParseMIMEEntity( shift, 'parse', @_ );
181 =head2 ParseMIMEEntityFromFile
183 Parses a mime entity from a filename passed in as an argument
187 sub ParseMIMEEntityFromFile {
189 return $self->_ParseMIMEEntity( shift, 'parse_open', @_ );
193 sub _ParseMIMEEntity {
197 my $postprocess = (@_ ? shift : 1);
200 # Create a new parser object:
201 my $parser = MIME::Parser->new();
202 $self->_SetupMIMEParser($parser);
203 $parser->decode_bodies(0) if $exact;
205 # TODO: XXX 3.0 we really need to wrap this in an eval { }
206 unless ( $self->{'entity'} = $parser->$method($message) ) {
207 $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages");
208 # Try again, this time without extracting nested messages
209 $parser->extract_nested_messages(0);
210 unless ( $self->{'entity'} = $parser->$method($message) ) {
211 $RT::Logger->crit("couldn't parse MIME stream");
216 $self->_PostProcessNewEntity if $postprocess;
218 return $self->{'entity'};
223 return unless $self->{'entity'};
225 my @parts = $self->{'entity'}->parts_DFS;
226 $self->_DecodeBody($_) foreach @parts;
233 my $old = $entity->bodyhandle or return;
234 return unless $old->is_encoded;
236 require MIME::Decoder;
237 my $encoding = $entity->head->mime_encoding;
238 my $decoder = new MIME::Decoder $encoding;
239 unless ( $decoder ) {
240 $RT::Logger->error("Couldn't find decoder for '$encoding', switching to binary");
246 # XXX: use InCore for now, but later must switch to files
247 my $new = new MIME::Body::InCore;
251 my $source = $old->open('r') or die "couldn't open body: $!";
252 my $destination = $new->open('w') or die "couldn't open body: $!";
255 eval { $decoder->decode($source, $destination) };
256 $RT::Logger->error($@) if $@;
258 $source->close or die "can't close: $!";
259 $destination->close or die "can't close: $!";
261 $entity->bodyhandle( $new );
264 =head2 _PostProcessNewEntity
266 cleans up and postprocesses a newly parsed MIME Entity
270 sub _PostProcessNewEntity {
273 #Now we've got a parsed mime object.
275 # Unfold headers that are have embedded newlines
276 # Better do this before conversion or it will break
277 # with multiline encoded Subject (RFC2047) (fsck.com #5594)
280 # try to convert text parts into utf-8 charset
281 RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
284 =head2 ParseCcAddressesFromHead HASHREF
286 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
287 Returns a list of all email addresses in the To and Cc
288 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
289 email address and anything that the RT->Config->Get('RTAddressRegexp') matches.
293 sub ParseCcAddressesFromHead {
297 CurrentUser => undef,
303 my @ToObjs = Email::Address->parse( $self->Head->get('To') );
304 my @CcObjs = Email::Address->parse( $self->Head->get('Cc') );
306 foreach my $AddrObj ( @ToObjs, @CcObjs ) {
307 my $Address = $AddrObj->address;
308 my $user = RT::User->new($RT::SystemUser);
309 $Address = $user->CanonicalizeEmailAddress($Address);
310 next if lc $args{'CurrentUser'}->EmailAddress eq lc $Address;
311 next if $self->IsRTAddress($Address);
313 push ( @Addresses, $Address );
319 =head2 IsRTaddress ADDRESS
321 Takes a single parameter, an email address.
322 Returns true if that address matches the C<RTAddressRegexp> config option.
323 Returns false, otherwise.
332 if ( my $address_re = RT->Config->Get('RTAddressRegexp') ) {
333 return $address =~ /$address_re/i ? 1 : undef;
336 # we don't warn here, but do in config check
337 if ( my $correspond_address = RT->Config->Get('CorrespondAddress') ) {
338 return 1 if lc $correspond_address eq lc $address;
340 if ( my $comment_address = RT->Config->Get('CommentAddress') ) {
341 return 1 if lc $comment_address eq lc $address;
344 my $queue = RT::Queue->new( $RT::SystemUser );
345 $queue->LoadByCols( CorrespondAddress => $address );
346 return 1 if $queue->id;
348 $queue->LoadByCols( CommentAddress => $address );
349 return 1 if $queue->id;
355 =head2 CullRTAddresses ARRAY
357 Takes a single argument, an array of email addresses.
358 Returns the same array with any IsRTAddress()es weeded out.
363 sub CullRTAddresses {
368 foreach my $addr( @addresses ) {
369 # We use the class instead of the instance
370 # because sloppy code calls this method
372 push (@addrlist, $addr) unless RT::EmailParser->IsRTAddress($addr);
381 # LookupExternalUserInfo is a site-definable method for synchronizing
382 # incoming users with an external data source.
384 # This routine takes a tuple of EmailAddress and FriendlyName
385 # EmailAddress is the user's email address, ususally taken from
386 # an email message's From: header.
387 # FriendlyName is a freeform string, ususally taken from the "comment"
388 # portion of an email message's From: header.
390 # If you define an AutoRejectRequest template, RT will use this
391 # template for the rejection message.
394 =head2 LookupExternalUserInfo
396 LookupExternalUserInfo is a site-definable method for synchronizing
397 incoming users with an external data source.
399 This routine takes a tuple of EmailAddress and FriendlyName
400 EmailAddress is the user's email address, ususally taken from
401 an email message's From: header.
402 FriendlyName is a freeform string, ususally taken from the "comment"
403 portion of an email message's From: header.
405 It returns (FoundInExternalDatabase, ParamHash);
407 FoundInExternalDatabase must be set to 1 before return if the user
408 was found in the external database.
410 ParamHash is a Perl parameter hash which can contain at least the
411 following fields. These fields are used to populate RT's users
412 database when the user is created.
414 EmailAddress is the email address that RT should use for this user.
415 Name is the 'Name' attribute RT should use for this user.
416 'Name' is used for things like access control and user lookups.
417 RealName is what RT should display as the user's name when displaying
422 sub LookupExternalUserInfo {
424 my $EmailAddress = shift;
425 my $RealName = shift;
427 my $FoundInExternalDatabase = 1;
430 #Name is the RT username you want to use for this user.
431 $params{'Name'} = $EmailAddress;
432 $params{'EmailAddress'} = $EmailAddress;
433 $params{'RealName'} = $RealName;
435 # See RT's contributed code for examples.
436 # http://www.fsck.com/pub/rt/contrib/
437 return ($FoundInExternalDatabase, %params);
442 Return the parsed head from this message
448 return $self->Entity->head;
453 Return the parsed Entity from this message
459 return $self->{'entity'};
464 =head2 _SetupMIMEParser $parser
466 A private instance method which sets up a mime parser to do its job
471 ## TODO: Does it make sense storing to disk at all? After all, we
472 ## need to put each msg as an in-core scalar before saving it to
473 ## the database, don't we?
475 ## At the same time, we should make sure that we nuke attachments
476 ## Over max size and return them
478 sub _SetupMIMEParser {
482 # Set up output directory for files; we use $RT::VarPath instead
483 # of File::Spec->tmpdir (e.g., /tmp) beacuse it isn't always
486 if ( -w $RT::VarPath ) {
487 $tmpdir = File::Temp::tempdir( DIR => $RT::VarPath, CLEANUP => 1 );
488 } elsif (-w File::Spec->tmpdir) {
489 $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
491 $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!");
494 #If someone includes a message, extract it
495 $parser->extract_nested_messages(1);
496 $parser->extract_uuencode(1); ### default is false
499 # If we got a writable tmpdir, write to disk
500 push ( @{ $self->{'AttachmentDirs'} ||= [] }, $tmpdir );
501 $parser->output_dir($tmpdir);
502 $parser->filer->ignore_filename(1);
504 # Set up the prefix for files with auto-generated names:
505 $parser->output_prefix("part");
507 # From the MIME::Parser docs:
508 # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope"
509 # Turns out that the default is to recycle tempfiles
510 # Temp files should never be recycled, especially when running under perl taint checking
512 $parser->tmp_recycling(0) if $parser->can('tmp_recycling');
514 # Otherwise, fall back to storing it in memory
515 $parser->output_to_core(1);
516 $parser->tmp_to_core(1);
517 $parser->use_inner_files(1);
522 =head2 ParseEmailAddress string
524 Returns a list of Email::Address objects
525 Works around the bug that Email::Address 1.889 and earlier
526 doesn't handle local-only email addresses (when users pass
527 in just usernames on the RT system in fields that expect
530 We don't handle the case of
531 bob, fred@bestpractical.com
532 because we don't want to fail parsing
533 bob, "Falcone, Fred" <fred@bestpractical.com>
534 The next release of Email::Address will have a new method
535 we can use that removes the bandaid
539 sub ParseEmailAddress {
541 my $address_string = shift;
543 $address_string =~ s/^\s+|\s+$//g;
546 # if it looks like a username / local only email
547 if ($address_string !~ /@/ && $address_string =~ /^\w+$/) {
548 my $user = RT::User->new( $RT::SystemUser );
549 my ($id, $msg) = $user->Load($address_string);
551 push @addresses, Email::Address->new($user->Name,$user->EmailAddress);
553 $RT::Logger->error("Unable to parse an email address from $address_string: $msg");
556 @addresses = Email::Address->parse($address_string);
565 Outlook 2007/2010 have a bug when you write an email with the html format.
566 it will send a 'multipart/alternative' with both 'text/plain' and 'text/html'
567 in it. it's cool to have a 'text/plain' part, but the problem is the part is
568 not so right: all the "\n" in your main message will become "\n\n" :/
570 this method will fix this bug, i.e. replaces "\n\n" to "\n".
571 return 1 if it does find the problem in the entity and get it fixed.
578 my $mime = $self->Entity();
581 my $mailer = $mime->head->get('X-Mailer');
582 # 12.0 is outlook 2007, 14.0 is 2010
583 if ( $mailer && $mailer =~ /Microsoft(?:.*?)Outlook 1[2-4]\./ ) {
585 if ( $mime->head->get('Content-Type') =~ m{multipart/mixed} ) {
586 my $first = $mime->parts(0);
587 if ( $first->head->get('Content-Type') =~ m{multipart/alternative} )
589 my $inner_first = $first->parts(0);
590 if ( $inner_first->head->get('Content-Type') =~ m{text/plain} )
592 $text_part = $inner_first;
596 elsif ( $mime->head->get('Content-Type') =~ m{multipart/alternative} ) {
597 my $first = $mime->parts(0);
598 if ( $first->head->get('Content-Type') =~ m{text/plain} ) {
605 # use the unencoded string
606 my $content = $text_part->bodyhandle->as_string;
607 if ( $content =~ s/\n\n/\n/g ) {
608 # only write only if we did change the content
609 if ( my $io = $text_part->open("w") ) {
610 $io->print($content);
615 $RT::Logger->error("can't write to body");
626 File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1)
627 if $self->{'AttachmentDirs'};
632 RT::Base->_ImportOverlays();