1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2007 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., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/copyleft/gpl.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 }}}
48 package RT::EmailParser;
51 use base qw/RT::Base/;
58 use File::Temp qw/tempdir/;
62 RT::EmailParser - helper functions for parsing parts from incoming
73 ok(require RT::EmailParser);
82 Returns a new RT::EmailParser object
88 my $class = ref($proto) || $proto;
90 bless ($self, $class);
95 # {{{ sub SmartParseMIMEEntityFromScalar
97 =head2 SmartParseMIMEEntityFromScalar { Message => SCALAR_REF, Decode => BOOL }
99 Parse a message stored in a scalar from scalar_ref
103 sub SmartParseMIMEEntityFromScalar {
105 my %args = ( Message => undef, Decode => 1, @_ );
107 my ( $fh, $temp_file );
112 # on NFS and NTFS, it is possible that tempfile() conflicts
113 # with other processes, causing a race condition. we try to
114 # accommodate this by pausing and retrying.
116 if ( $fh, $temp_file ) =
117 eval { File::Temp::tempfile( undef, UNLINK => 0 ) };
125 print $fh $args{'Message'};
127 if ( -f $temp_file ) {
129 # We have to trust the temp file's name -- untaint it
130 $temp_file =~ /(.*)/;
131 $self->ParseMIMEEntityFromFile( $1, $args{'Decode'} );
137 #If for some reason we weren't able to parse the message using a temp file
138 # try it with a scalar
139 if ( $@ || !$self->Entity ) {
140 $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'} );
147 # {{{ sub ParseMIMEEntityFromSTDIN
149 =head2 ParseMIMEEntityFromSTDIN
151 Parse a message from standard input
155 sub ParseMIMEEntityFromSTDIN {
157 my $postprocess = (@_ ? shift : 1);
158 return $self->ParseMIMEEntityFromFileHandle(\*STDIN, $postprocess);
163 # {{{ ParseMIMEEntityFromScalar
165 =head2 ParseMIMEEntityFromScalar $message
167 Takes either a scalar or a reference to a scalr which contains a stringified MIME message.
170 Returns true if it wins.
171 Returns false if it loses.
175 sub ParseMIMEEntityFromScalar {
178 my $postprocess = (@_ ? shift : 1);
179 $self->_ParseMIMEEntity($message,'parse_data', $postprocess);
184 # {{{ ParseMIMEEntityFromFilehandle *FH
186 =head2 ParseMIMEEntityFromFilehandle *FH
188 Parses a mime entity from a filehandle passed in as an argument
192 sub ParseMIMEEntityFromFileHandle {
194 my $filehandle = shift;
195 my $postprocess = (@_ ? shift : 1);
196 $self->_ParseMIMEEntity($filehandle,'parse', $postprocess);
201 # {{{ ParseMIMEEntityFromFile
203 =head2 ParseMIMEEntityFromFile
205 Parses a mime entity from a filename passed in as an argument
209 sub ParseMIMEEntityFromFile {
212 my $postprocess = (@_ ? shift : 1);
213 $self->_ParseMIMEEntity($file,'parse_open',$postprocess);
218 # {{{ _ParseMIMEEntity
219 sub _ParseMIMEEntity {
223 my $postprocess = shift;
224 # Create a new parser object:
226 my $parser = MIME::Parser->new();
227 $self->_SetupMIMEParser($parser);
230 # TODO: XXX 3.0 we really need to wrap this in an eval { }
231 unless ( $self->{'entity'} = $parser->$method($message) ) {
232 $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages");
233 # Try again, this time without extracting nested messages
234 $parser->extract_nested_messages(0);
235 unless ( $self->{'entity'} = $parser->$method($message) ) {
236 $RT::Logger->crit("couldn't parse MIME stream");
241 $self->_PostProcessNewEntity() ;
248 # {{{ _PostProcessNewEntity
250 =head2 _PostProcessNewEntity
252 cleans up and postprocesses a newly parsed MIME Entity
256 sub _PostProcessNewEntity {
259 #Now we've got a parsed mime object.
261 # Unfold headers that are have embedded newlines
262 # Better do this before conversion or it will break
263 # with multiline encoded Subject (RFC2047) (fsck.com #5594)
268 # try to convert text parts into utf-8 charset
269 RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
278 # {{{ sub ParseTicketId
282 $RT::Logger->warnings("RT::EmailParser->ParseTicketId deprecated. You should be using RT::Interface::Email at (". join(":",caller).")");
284 require RT::Interface::Email;
285 RT::Interface::Email::ParseTicketId(@_);
292 # {{{ ParseCcAddressesFromHead
294 =head2 ParseCcAddressesFromHead HASHREF
296 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
297 Returns a list of all email addresses in the To and Cc
298 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
299 email address and anything that the $RTAddressRegexp matches.
303 sub ParseCcAddressesFromHead {
309 CurrentUser => undef,
315 my @ToObjs = Mail::Address->parse( $self->Head->get('To') );
316 my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') );
318 foreach my $AddrObj ( @ToObjs, @CcObjs ) {
319 my $Address = $AddrObj->address;
320 my $user = RT::User->new($RT::SystemUser);
321 $Address = $user->CanonicalizeEmailAddress($Address);
322 next if ( lc $args{'CurrentUser'}->EmailAddress eq lc $Address );
323 next if ( lc $args{'QueueObj'}->CorrespondAddress eq lc $Address );
324 next if ( lc $args{'QueueObj'}->CommentAddress eq lc $Address );
325 next if ( $self->IsRTAddress($Address) );
327 push ( @Addresses, $Address );
334 # {{{ ParseSenderAdddressFromHead
336 =head2 ParseSenderAddressFromHead
338 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
339 of the From (evaluated in order of Reply-To:, From:, Sender)
343 sub ParseSenderAddressFromHead {
346 #Figure out who's sending this message.
347 my $From = $self->Head->get('Reply-To')
348 || $self->Head->get('From')
349 || $self->Head->get('Sender');
350 return ( $self->ParseAddressFromHeader($From) );
355 # {{{ ParseErrorsToAdddressFromHead
357 =head2 ParseErrorsToAddressFromHead
359 Takes a MIME::Header object. Return a single value : user@host
360 of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender)
364 sub ParseErrorsToAddressFromHead {
367 #Figure out who's sending this message.
369 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
371 # If there's a header of that name
372 my $headerobj = $self->Head->get($header);
374 my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj);
376 # If it's got actual useful content...
377 return ($addr) if ($addr);
384 # {{{ ParseAddressFromHeader
386 =head2 ParseAddressFromHeader ADDRESS
388 Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name
392 sub ParseAddressFromHeader {
396 # Perl 5.8.0 breaks when doing regex matches on utf8
397 Encode::_utf8_off($Addr) if $] == 5.008;
398 my @Addresses = Mail::Address->parse($Addr);
400 my $AddrObj = $Addresses[0];
402 unless ( ref($AddrObj) ) {
403 return ( undef, undef );
406 my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
408 #Lets take the from and load a user object.
409 my $Address = $AddrObj->address;
411 return ( $Address, $Name );
418 =head2 IsRTaddress ADDRESS
420 Takes a single parameter, an email address.
421 Returns true if that address matches the $RTAddressRegexp.
422 Returns false, otherwise.
426 is(RT::EmailParser::IsRTAddress("","rt\@example.com"),1, "Regexp matched rt address" );
427 is(RT::EmailParser::IsRTAddress("","frt\@example.com"),undef, "Regexp didn't match non-rt address" );
437 # Example: the following rule would tell RT not to Cc
438 # "tickets@noc.example.com"
439 if ( defined($RT::RTAddressRegexp) &&
440 $address =~ /$RT::RTAddressRegexp/i ) {
450 # {{{ CullRTAddresses
452 =head2 CullRTAddresses ARRAY
454 Takes a single argument, an array of email addresses.
455 Returns the same array with any IsRTAddress()es weeded out.
459 @before = ("rt\@example.com", "frt\@example.com");
460 @after = ("frt\@example.com");
461 ok(eq_array(RT::EmailParser::CullRTAddresses("",@before),@after), "CullRTAddresses only culls RT addresses");
467 sub CullRTAddresses {
472 foreach my $addr( @addresses ) {
473 # We use the class instead of the instance
474 # because sloppy code calls this method
476 push (@addrlist, $addr) unless RT::EmailParser->IsRTAddress($addr);
484 # {{{ LookupExternalUserInfo
487 # LookupExternalUserInfo is a site-definable method for synchronizing
488 # incoming users with an external data source.
490 # This routine takes a tuple of EmailAddress and FriendlyName
491 # EmailAddress is the user's email address, ususally taken from
492 # an email message's From: header.
493 # FriendlyName is a freeform string, ususally taken from the "comment"
494 # portion of an email message's From: header.
496 # If you define an AutoRejectRequest template, RT will use this
497 # template for the rejection message.
500 =head2 LookupExternalUserInfo
502 LookupExternalUserInfo is a site-definable method for synchronizing
503 incoming users with an external data source.
505 This routine takes a tuple of EmailAddress and FriendlyName
506 EmailAddress is the user's email address, ususally taken from
507 an email message's From: header.
508 FriendlyName is a freeform string, ususally taken from the "comment"
509 portion of an email message's From: header.
511 It returns (FoundInExternalDatabase, ParamHash);
513 FoundInExternalDatabase must be set to 1 before return if the user
514 was found in the external database.
516 ParamHash is a Perl parameter hash which can contain at least the
517 following fields. These fields are used to populate RT's users
518 database when the user is created.
520 EmailAddress is the email address that RT should use for this user.
521 Name is the 'Name' attribute RT should use for this user.
522 'Name' is used for things like access control and user lookups.
523 RealName is what RT should display as the user's name when displaying
528 sub LookupExternalUserInfo {
530 my $EmailAddress = shift;
531 my $RealName = shift;
533 my $FoundInExternalDatabase = 1;
536 #Name is the RT username you want to use for this user.
537 $params{'Name'} = $EmailAddress;
538 $params{'EmailAddress'} = $EmailAddress;
539 $params{'RealName'} = $RealName;
541 # See RT's contributed code for examples.
542 # http://www.fsck.com/pub/rt/contrib/
543 return ($FoundInExternalDatabase, %params);
548 # {{{ Accessor methods for parsed email messages
552 Return the parsed head from this message
558 return $self->Entity->head;
563 Return the parsed Entity from this message
569 return $self->{'entity'};
574 # {{{ _SetupMIMEParser
576 =head2 _SetupMIMEParser $parser
578 A private instance method which sets up a mime parser to do its job
583 ## TODO: Does it make sense storing to disk at all? After all, we
584 ## need to put each msg as an in-core scalar before saving it to
585 ## the database, don't we?
587 ## At the same time, we should make sure that we nuke attachments
588 ## Over max size and return them
590 sub _SetupMIMEParser {
594 # Set up output directory for files:
596 my $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
597 push ( @{ $self->{'AttachmentDirs'} }, $tmpdir );
598 $parser->output_dir($tmpdir);
599 $parser->filer->ignore_filename(1);
601 #If someone includes a message, extract it
602 $parser->extract_nested_messages(1);
604 $parser->extract_uuencode(1); ### default is false
606 # Set up the prefix for files with auto-generated names:
607 $parser->output_prefix("part");
609 # do _not_ store each msg as in-core scalar;
611 $parser->output_to_core(0);
613 # From the MIME::Parser docs:
614 # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope"
615 # Turns out that the default is to recycle tempfiles
616 # Temp files should never be recycled, especially when running under perl taint checking
618 $parser->tmp_recycling(0) if $parser->can('tmp_recycling');
626 File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1);
631 eval "require RT::EmailParser_Vendor";
632 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Vendor.pm});
633 eval "require RT::EmailParser_Local";
634 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Local.pm});