1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
6 # <jesse@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., 675 Mass Ave, Cambridge, MA 02139, USA.
28 # CONTRIBUTION SUBMISSION POLICY:
30 # (The following paragraph is not intended to limit the rights granted
31 # to you to modify and distribute this software under the terms of
32 # the GNU General Public License and is only of importance to you if
33 # you choose to contribute your changes and enhancements to the
34 # community by submitting them to Best Practical Solutions, LLC.)
36 # By intentionally submitting any modifications, corrections or
37 # derivatives to this work, or any other work intended for use with
38 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
39 # you are the copyright holder for those contributions and you grant
40 # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
41 # royalty-free, perpetual, license to use, copy, create derivative
42 # works based on those contributions, and sublicense and distribute
43 # those contributions and any derivatives thereof.
45 # END BPS TAGGED BLOCK }}}
46 package RT::EmailParser;
49 use base qw/RT::Base/;
56 use File::Temp qw/tempdir/;
60 RT::EmailParser - helper functions for parsing parts from incoming
71 ok(require RT::EmailParser);
80 Returns a new RT::EmailParser object
86 my $class = ref($proto) || $proto;
88 bless ($self, $class);
93 # {{{ sub SmartParseMIMEEntityFromScalar
95 =head2 SmartParseMIMEEntityFromScalar { Message => SCALAR_REF, Decode => BOOL }
97 Parse a message stored in a scalar from scalar_ref
101 sub SmartParseMIMEEntityFromScalar {
103 my %args = ( Message => undef, Decode => 1, @_ );
105 my ( $fh, $temp_file );
110 # on NFS and NTFS, it is possible that tempfile() conflicts
111 # with other processes, causing a race condition. we try to
112 # accommodate this by pausing and retrying.
114 if ( $fh, $temp_file ) =
115 eval { File::Temp::tempfile( undef, UNLINK => 0 ) };
123 print $fh $args{'Message'};
125 if ( -f $temp_file ) {
127 # We have to trust the temp file's name -- untaint it
128 $temp_file =~ /(.*)/;
129 $self->ParseMIMEEntityFromFile( $1, $args{'Decode'} );
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 $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'} );
145 # {{{ sub ParseMIMEEntityFromSTDIN
147 =head2 ParseMIMEEntityFromSTDIN
149 Parse a message from standard input
153 sub ParseMIMEEntityFromSTDIN {
155 my $postprocess = (@_ ? shift : 1);
156 return $self->ParseMIMEEntityFromFileHandle(\*STDIN, $postprocess);
161 # {{{ ParseMIMEEntityFromScalar
163 =head2 ParseMIMEEntityFromScalar $message
165 Takes either a scalar or a reference to a scalr which contains a stringified MIME message.
168 Returns true if it wins.
169 Returns false if it loses.
173 sub ParseMIMEEntityFromScalar {
176 my $postprocess = (@_ ? shift : 1);
177 $self->_ParseMIMEEntity($message,'parse_data', $postprocess);
182 # {{{ ParseMIMEEntityFromFilehandle *FH
184 =head2 ParseMIMEEntityFromFilehandle *FH
186 Parses a mime entity from a filehandle passed in as an argument
190 sub ParseMIMEEntityFromFileHandle {
192 my $filehandle = shift;
193 my $postprocess = (@_ ? shift : 1);
194 $self->_ParseMIMEEntity($filehandle,'parse', $postprocess);
199 # {{{ ParseMIMEEntityFromFile
201 =head2 ParseMIMEEntityFromFile
203 Parses a mime entity from a filename passed in as an argument
207 sub ParseMIMEEntityFromFile {
210 my $postprocess = (@_ ? shift : 1);
211 $self->_ParseMIMEEntity($file,'parse_open',$postprocess);
216 # {{{ _ParseMIMEEntity
217 sub _ParseMIMEEntity {
221 my $postprocess = shift;
222 # Create a new parser object:
224 my $parser = MIME::Parser->new();
225 $self->_SetupMIMEParser($parser);
228 # TODO: XXX 3.0 we really need to wrap this in an eval { }
229 unless ( $self->{'entity'} = $parser->$method($message) ) {
230 $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages");
231 # Try again, this time without extracting nested messages
232 $parser->extract_nested_messages(0);
233 unless ( $self->{'entity'} = $parser->$method($message) ) {
234 $RT::Logger->crit("couldn't parse MIME stream");
239 $self->_PostProcessNewEntity() ;
246 # {{{ _PostProcessNewEntity
248 =head2 _PostProcessNewEntity
250 cleans up and postprocesses a newly parsed MIME Entity
254 sub _PostProcessNewEntity {
257 #Now we've got a parsed mime object.
259 # Unfold headers that are have embedded newlines
260 # Better do this before conversion or it will break
261 # with multiline encoded Subject (RFC2047) (fsck.com #5594)
266 # try to convert text parts into utf-8 charset
267 RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
276 # {{{ sub ParseTicketId
280 $RT::Logger->warnings("RT::EmailParser->ParseTicketId deprecated. You should be using RT::Interface::Email at (". join(":",caller).")");
282 require RT::Interface::Email;
283 RT::Interface::Email::ParseTicketId(@_);
290 # {{{ ParseCcAddressesFromHead
292 =head2 ParseCcAddressesFromHead HASHREF
294 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
295 Returns a list of all email addresses in the To and Cc
296 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
297 email address and anything that the $RTAddressRegexp matches.
301 sub ParseCcAddressesFromHead {
307 CurrentUser => undef,
313 my @ToObjs = Mail::Address->parse( $self->Head->get('To') );
314 my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') );
316 foreach my $AddrObj ( @ToObjs, @CcObjs ) {
317 my $Address = $AddrObj->address;
318 my $user = RT::User->new($RT::SystemUser);
319 $Address = $user->CanonicalizeEmailAddress($Address);
320 next if ( lc $args{'CurrentUser'}->EmailAddress eq lc $Address );
321 next if ( lc $args{'QueueObj'}->CorrespondAddress eq lc $Address );
322 next if ( lc $args{'QueueObj'}->CommentAddress eq lc $Address );
323 next if ( $self->IsRTAddress($Address) );
325 push ( @Addresses, $Address );
332 # {{{ ParseSenderAdddressFromHead
334 =head2 ParseSenderAddressFromHead
336 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
337 of the From (evaluated in order of Reply-To:, From:, Sender)
341 sub ParseSenderAddressFromHead {
344 #Figure out who's sending this message.
345 my $From = $self->Head->get('Reply-To')
346 || $self->Head->get('From')
347 || $self->Head->get('Sender');
348 return ( $self->ParseAddressFromHeader($From) );
353 # {{{ ParseErrorsToAdddressFromHead
355 =head2 ParseErrorsToAddressFromHead
357 Takes a MIME::Header object. Return a single value : user@host
358 of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender)
362 sub ParseErrorsToAddressFromHead {
365 #Figure out who's sending this message.
367 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
369 # If there's a header of that name
370 my $headerobj = $self->Head->get($header);
372 my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj);
374 # If it's got actual useful content...
375 return ($addr) if ($addr);
382 # {{{ ParseAddressFromHeader
384 =head2 ParseAddressFromHeader ADDRESS
386 Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name
390 sub ParseAddressFromHeader {
394 # Perl 5.8.0 breaks when doing regex matches on utf8
395 Encode::_utf8_off($Addr) if $] == 5.008;
396 my @Addresses = Mail::Address->parse($Addr);
398 my $AddrObj = $Addresses[0];
400 unless ( ref($AddrObj) ) {
401 return ( undef, undef );
404 my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
406 #Lets take the from and load a user object.
407 my $Address = $AddrObj->address;
409 return ( $Address, $Name );
416 =head2 IsRTaddress ADDRESS
418 Takes a single parameter, an email address.
419 Returns true if that address matches the $RTAddressRegexp.
420 Returns false, otherwise.
424 is(RT::EmailParser::IsRTAddress("","rt\@example.com"),1, "Regexp matched rt address" );
425 is(RT::EmailParser::IsRTAddress("","frt\@example.com"),undef, "Regexp didn't match non-rt address" );
435 # Example: the following rule would tell RT not to Cc
436 # "tickets@noc.example.com"
437 if ( defined($RT::RTAddressRegexp) &&
438 $address =~ /$RT::RTAddressRegexp/i ) {
448 # {{{ CullRTAddresses
450 =head2 CullRTAddresses ARRAY
452 Takes a single argument, an array of email addresses.
453 Returns the same array with any IsRTAddress()es weeded out.
457 @before = ("rt\@example.com", "frt\@example.com");
458 @after = ("frt\@example.com");
459 ok(eq_array(RT::EmailParser::CullRTAddresses("",@before),@after), "CullRTAddresses only culls RT addresses");
465 sub CullRTAddresses {
470 foreach my $addr( @addresses ) {
471 # We use the class instead of the instance
472 # because sloppy code calls this method
474 push (@addrlist, $addr) unless RT::EmailParser->IsRTAddress($addr);
482 # {{{ LookupExternalUserInfo
485 # LookupExternalUserInfo is a site-definable method for synchronizing
486 # incoming users with an external data source.
488 # This routine takes a tuple of EmailAddress and FriendlyName
489 # EmailAddress is the user's email address, ususally taken from
490 # an email message's From: header.
491 # FriendlyName is a freeform string, ususally taken from the "comment"
492 # portion of an email message's From: header.
494 # If you define an AutoRejectRequest template, RT will use this
495 # template for the rejection message.
498 =head2 LookupExternalUserInfo
500 LookupExternalUserInfo is a site-definable method for synchronizing
501 incoming users with an external data source.
503 This routine takes a tuple of EmailAddress and FriendlyName
504 EmailAddress is the user's email address, ususally taken from
505 an email message's From: header.
506 FriendlyName is a freeform string, ususally taken from the "comment"
507 portion of an email message's From: header.
509 It returns (FoundInExternalDatabase, ParamHash);
511 FoundInExternalDatabase must be set to 1 before return if the user
512 was found in the external database.
514 ParamHash is a Perl parameter hash which can contain at least the
515 following fields. These fields are used to populate RT's users
516 database when the user is created.
518 EmailAddress is the email address that RT should use for this user.
519 Name is the 'Name' attribute RT should use for this user.
520 'Name' is used for things like access control and user lookups.
521 RealName is what RT should display as the user's name when displaying
526 sub LookupExternalUserInfo {
528 my $EmailAddress = shift;
529 my $RealName = shift;
531 my $FoundInExternalDatabase = 1;
534 #Name is the RT username you want to use for this user.
535 $params{'Name'} = $EmailAddress;
536 $params{'EmailAddress'} = $EmailAddress;
537 $params{'RealName'} = $RealName;
539 # See RT's contributed code for examples.
540 # http://www.fsck.com/pub/rt/contrib/
541 return ($FoundInExternalDatabase, %params);
546 # {{{ Accessor methods for parsed email messages
550 Return the parsed head from this message
556 return $self->Entity->head;
561 Return the parsed Entity from this message
567 return $self->{'entity'};
572 # {{{ _SetupMIMEParser
574 =head2 _SetupMIMEParser $parser
576 A private instance method which sets up a mime parser to do its job
581 ## TODO: Does it make sense storing to disk at all? After all, we
582 ## need to put each msg as an in-core scalar before saving it to
583 ## the database, don't we?
585 ## At the same time, we should make sure that we nuke attachments
586 ## Over max size and return them
588 sub _SetupMIMEParser {
592 # Set up output directory for files:
594 my $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
595 push ( @{ $self->{'AttachmentDirs'} }, $tmpdir );
596 $parser->output_dir($tmpdir);
597 $parser->filer->ignore_filename(1);
599 #If someone includes a message, extract it
600 $parser->extract_nested_messages(1);
602 $parser->extract_uuencode(1); ### default is false
604 # Set up the prefix for files with auto-generated names:
605 $parser->output_prefix("part");
607 # do _not_ store each msg as in-core scalar;
609 $parser->output_to_core(0);
611 # From the MIME::Parser docs:
612 # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope"
613 # Turns out that the default is to recycle tempfiles
614 # Temp files should never be recycled, especially when running under perl taint checking
616 $parser->tmp_recycling(0);
624 File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1);
629 eval "require RT::EmailParser_Vendor";
630 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Vendor.pm});
631 eval "require RT::EmailParser_Local";
632 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Local.pm});