1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2017 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::Interface::Email;
60 use Text::ParseWords qw/shellwords/;
61 use RT::Util 'safe_run_child';
66 use vars qw ( @EXPORT_OK);
68 # your exported package globals go here,
69 # as well as any optionally exported functions
73 &CheckForSuspiciousSender
74 &CheckForAutoGenerated
77 &ParseCcAddressesFromHead
78 &ParseSenderAddressFromHead
79 &ParseErrorsToAddressFromHead
80 &ParseAddressFromHeader
87 RT::Interface::Email - helper functions for parsing email sent to RT
91 use lib "!!RT_LIB_PATH!!";
92 use lib "!!RT_ETC_PATH!!";
94 use RT::Interface::Email qw(Gateway CreateUser);
103 =head2 CheckForLoops HEAD
105 Takes a HEAD object of L<MIME::Head> class and returns true if the
106 message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
107 field of the head for test.
114 # If this instance of RT sent it our, we don't want to take it in
115 my $RTLoop = Encode::decode( "UTF-8", $head->get("X-RT-Loop-Prevention") || "" );
116 chomp ($RTLoop); # remove that newline
117 if ( $RTLoop eq RT->Config->Get('rtname') ) {
121 # TODO: We might not trap the case where RT instance A sends a mail
122 # to RT instance B which sends a mail to ...
126 =head2 CheckForSuspiciousSender HEAD
128 Takes a HEAD object of L<MIME::Head> class and returns true if sender
129 is suspicious. Suspicious means mailer daemon.
131 See also L</ParseSenderAddressFromHead>.
135 sub CheckForSuspiciousSender {
138 #if it's from a postmaster or mailer daemon, it's likely a bounce.
140 #TODO: better algorithms needed here - there is no standards for
141 #bounces, so it's very difficult to separate them from anything
142 #else. At the other hand, the Return-To address is only ment to be
143 #used as an error channel, we might want to put up a separate
144 #Return-To address which is treated differently.
146 #TODO: search through the whole email and find the right Ticket ID.
148 my ( $From, $junk ) = ParseSenderAddressFromHead($head);
150 # If unparseable (non-ASCII), $From can come back undef
151 return undef if not defined $From;
153 if ( ( $From =~ /^mailer-daemon\@/i )
154 or ( $From =~ /^postmaster\@/i )
164 =head2 CheckForAutoGenerated HEAD
166 Takes a HEAD object of L<MIME::Head> class and returns true if message is
167 autogenerated. Checks C<Precedence>, C<Auto-Submitted>, and
168 C<X-FC-Machinegenerated> fields of the head in tests.
172 sub CheckForAutoGenerated {
175 if (grep { /^(bulk|junk)/i } $head->get_all("Precedence")) {
179 # Per RFC3834, any Auto-Submitted header which is not "no" means
180 # it is auto-generated.
181 my $AutoSubmitted = $head->get("Auto-Submitted") || "";
182 if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
186 # First Class mailer uses this as a clue.
187 my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
188 if ( $FCJunk =~ /^true/i ) {
199 my $ReturnPath = $head->get("Return-path") || "";
200 return ( $ReturnPath =~ /<>/ );
204 =head2 MailError PARAM HASH
206 Sends an error message. Takes a param hash:
210 =item From - sender's address, by default is 'CorrespondAddress';
212 =item To - recipient, by default is 'OwnerEmail';
214 =item Bcc - optional Bcc recipients;
216 =item Subject - subject of the message, default is 'There has been an error';
218 =item Explanation - main content of the error, default value is 'Unexplained error';
220 =item MIMEObj - optional MIME entity that's attached to the error mail, as well we
221 add 'In-Reply-To' field to the error that points to this message.
223 =item Attach - optional text that attached to the error as 'message/rfc822' part.
225 =item LogLevel - log level under which we should write the subject and
226 explanation message into the log, by default we log it as critical.
234 To => RT->Config->Get('OwnerEmail'),
236 From => RT->Config->Get('CorrespondAddress'),
237 Subject => 'There has been an error',
238 Explanation => 'Unexplained error',
246 level => $args{'LogLevel'},
247 message => "$args{Subject}: $args{'Explanation'}",
248 ) if $args{'LogLevel'};
250 # the colons are necessary to make ->build include non-standard headers
252 Type => "multipart/mixed",
253 From => Encode::encode( "UTF-8", $args{'From'} ),
254 Bcc => Encode::encode( "UTF-8", $args{'Bcc'} ),
255 To => Encode::encode( "UTF-8", $args{'To'} ),
256 Subject => EncodeToMIME( String => $args{'Subject'} ),
257 'X-RT-Loop-Prevention:' => Encode::encode( "UTF-8", RT->Config->Get('rtname') ),
260 # only set precedence if the sysadmin wants us to
261 if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
262 $entity_args{'Precedence:'} =
263 Encode::encode( "UTF-8", RT->Config->Get('DefaultErrorMailPrecedence') );
266 my $entity = MIME::Entity->build(%entity_args);
267 SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
270 Type => "text/plain",
272 Data => Encode::encode( "UTF-8", $args{'Explanation'} . "\n" ),
275 if ( $args{'MIMEObj'} ) {
276 $args{'MIMEObj'}->sync_headers;
277 $entity->add_part( $args{'MIMEObj'} );
280 if ( $args{'Attach'} ) {
281 $entity->attach( Data => Encode::encode( "UTF-8", $args{'Attach'} ), Type => 'message/rfc822' );
285 SendEmail( Entity => $entity, Bounce => 1 );
289 =head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
291 Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
292 RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
293 true value, the message will be marked as an autogenerated error, if
294 possible. Sets Date field of the head to now if it's not set.
296 If the C<X-RT-Squelch> header is set to any true value, the mail will
297 not be sent. One use is to let extensions easily cancel outgoing mail.
299 Ticket and Transaction arguments are optional. If Transaction is
300 specified and Ticket is not then ticket of the transaction is
301 used, but only if the transaction belongs to a ticket.
303 Returns 1 on success, 0 on error or -1 if message has no recipients
304 and hasn't been sent.
306 =head3 Signing and Encrypting
308 This function as well signs and/or encrypts the message according to
309 headers of a transaction's attachment or properties of a ticket's queue.
310 To get full access to the configuration Ticket and/or Transaction
311 arguments must be provided, but you can force behaviour using Sign
312 and/or Encrypt arguments.
314 The following precedence of arguments are used to figure out if
315 the message should be encrypted and/or signed:
317 * if Sign or Encrypt argument is defined then its value is used
319 * else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
320 header field then it's value is used
322 * else properties of a queue of the Ticket are used.
326 sub WillSignEncrypt {
328 my $attachment = delete $args{Attachment};
329 my $ticket = delete $args{Ticket};
331 if ( not RT->Config->Get('Crypt')->{'Enable'} ) {
332 $args{Sign} = $args{Encrypt} = 0;
333 return wantarray ? %args : 0;
336 for my $argument ( qw(Sign Encrypt) ) {
337 next if defined $args{ $argument };
339 if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) {
340 $args{$argument} = $attachment->GetHeader("X-RT-$argument");
341 } elsif ( $ticket and $argument eq "Encrypt" ) {
342 $args{Encrypt} = $ticket->QueueObj->Encrypt();
343 } elsif ( $ticket and $argument eq "Sign" ) {
344 # Note that $queue->Sign is UI-only, and that all
345 # UI-generated messages explicitly set the X-RT-Crypt header
346 # to 0 or 1; thus this path is only taken for messages
347 # generated _not_ via the web UI.
348 $args{Sign} = $ticket->QueueObj->SignAuto();
352 return wantarray ? %args : ($args{Sign} || $args{Encrypt});
355 sub _OutgoingMailFrom {
356 my $TicketObj = shift;
358 my $MailFrom = RT->Config->Get('SetOutgoingMailFrom');
359 my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef;
360 my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {};
363 my $Queue = $TicketObj->QueueObj;
364 my $QueueAddressOverride = $Overrides->{$Queue->id}
365 || $Overrides->{$Queue->Name};
367 if ($QueueAddressOverride) {
368 $OutgoingMailAddress = $QueueAddressOverride;
370 $OutgoingMailAddress ||= $Queue->CorrespondAddress
371 || RT->Config->Get('CorrespondAddress');
374 elsif ($Overrides->{'Default'}) {
375 $OutgoingMailAddress = $Overrides->{'Default'};
378 return $OutgoingMailAddress;
386 Transaction => undef,
390 my $TicketObj = $args{'Ticket'};
391 my $TransactionObj = $args{'Transaction'};
393 unless ( $args{'Entity'} ) {
394 $RT::Logger->crit( "Could not send mail without 'Entity' object" );
398 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
401 # If we don't have any recipients to send to, don't send a message;
402 unless ( $args{'Entity'}->head->get('To')
403 || $args{'Entity'}->head->get('Cc')
404 || $args{'Entity'}->head->get('Bcc') )
406 $RT::Logger->info( $msgid . " No recipients found. Not sending." );
410 if ($args{'Entity'}->head->get('X-RT-Squelch')) {
411 $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
415 if (my $precedence = RT->Config->Get('DefaultMailPrecedence')
416 and !$args{'Entity'}->head->get("Precedence")
419 my $Overrides = RT->Config->Get('OverrideMailPrecedence') || {};
420 my $Queue = $TicketObj->QueueObj;
422 $precedence = $Overrides->{$Queue->id}
423 if exists $Overrides->{$Queue->id};
424 $precedence = $Overrides->{$Queue->Name}
425 if exists $Overrides->{$Queue->Name};
428 $args{'Entity'}->head->replace( 'Precedence', Encode::encode("UTF-8",$precedence) )
432 if ( $TransactionObj && !$TicketObj
433 && $TransactionObj->ObjectType eq 'RT::Ticket' )
435 $TicketObj = $TransactionObj->Object;
438 my $head = $args{'Entity'}->head;
439 unless ( $head->get('Date') ) {
441 my $date = RT::Date->new( RT->SystemUser );
443 $head->replace( 'Date', Encode::encode("UTF-8",$date->RFC2822( Timezone => 'server' ) ) );
445 unless ( $head->get('MIME-Version') ) {
446 # We should never have to set the MIME-Version header
447 $head->replace( 'MIME-Version', '1.0' );
449 unless ( $head->get('Content-Transfer-Encoding') ) {
450 # fsck.com #5959: Since RT sends 8bit mail, we should say so.
451 $head->replace( 'Content-Transfer-Encoding', '8bit' );
454 if ( RT->Config->Get('Crypt')->{'Enable'} ) {
455 %args = WillSignEncrypt(
457 Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef,
458 Ticket => $TicketObj,
460 my $res = SignEncrypt( %args );
461 return $res unless $res > 0;
464 my $mail_command = RT->Config->Get('MailCommand');
466 # if it is a sub routine, we just return it;
467 return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
469 if ( $mail_command eq 'sendmailpipe' ) {
470 my $path = RT->Config->Get('SendmailPath');
471 my @args = shellwords(RT->Config->Get('SendmailArguments'));
472 push @args, "-t" unless grep {$_ eq "-t"} @args;
474 # SetOutgoingMailFrom and bounces conflict, since they both want -f
475 if ( $args{'Bounce'} ) {
476 push @args, shellwords(RT->Config->Get('SendmailBounceArguments'));
477 } elsif ( RT->Config->Get('SetOutgoingMailFrom') ) {
478 my $OutgoingMailAddress = _OutgoingMailFrom($TicketObj);
480 push @args, "-f", $OutgoingMailAddress
481 if $OutgoingMailAddress;
485 if ( $TransactionObj and
486 my $prefix = RT->Config->Get('VERPPrefix') and
487 my $domain = RT->Config->Get('VERPDomain') )
489 my $from = $TransactionObj->CreatorObj->EmailAddress;
492 push @args, "-f", "$prefix$from\@$domain";
496 # don't ignore CHLD signal to get proper exit code
497 local $SIG{'CHLD'} = 'DEFAULT';
499 # if something wrong with $mail->print we will get PIPE signal, handle it
500 local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
504 my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args )
505 or die "couldn't execute program: $!";
507 $args{'Entity'}->print($mail);
508 close $mail or die "close pipe failed: $!";
512 # sendmail exit statuses mostly errors with data not software
513 # TODO: status parsing: core dump, exit on signal or EX_*
514 my $msg = "$msgid: `$path @args` exited with code ". ($?>>8);
515 $msg = ", interrupted by signal ". ($?&127) if $?&127;
516 $RT::Logger->error( $msg );
521 $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ );
523 _RecordSendEmailFailure( $TicketObj );
527 } elsif ( $mail_command eq 'mbox' ) {
528 my $now = RT::Date->new(RT->SystemUser);
533 my $when = $now->ISO( Timezone => "server" );
535 $logfile = "$RT::VarPath/$when.mbox";
536 $RT::Logger->info("Storing outgoing emails in $logfile");
540 unless (open($fh, ">>", $logfile)) {
541 $RT::Logger->crit( "Can't open mbox file $logfile: $!" );
544 my $content = $args{Entity}->stringify;
545 $content =~ s/^(>*From )/>$1/mg;
546 my $user = $ENV{USER} || getpwuid($<);
547 print $fh "From $user\@localhost ".localtime()."\n";
548 print $fh $content, "\n";
551 local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
553 my @mailer_args = ($mail_command);
554 if ( $mail_command eq 'sendmail' ) {
555 $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
556 push @mailer_args, grep {$_ ne "-t"}
557 split(/\s+/, RT->Config->Get('SendmailArguments'));
558 } elsif ( $mail_command eq 'testfile' ) {
559 unless ($Mail::Mailer::testfile::config{outfile}) {
560 $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
561 $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}");
564 push @mailer_args, RT->Config->Get('MailParams');
567 unless ( $args{'Entity'}->send( @mailer_args ) ) {
568 $RT::Logger->crit( "$msgid: Could not send mail." );
570 _RecordSendEmailFailure( $TicketObj );
578 =head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
580 Loads a template. Parses it using arguments if it's not empty.
581 Returns a tuple (L<RT::Template> object, error message).
583 Note that even if a template object is returned MIMEObj method
584 may return undef for empty templates.
588 sub PrepareEmailUsingTemplate {
595 my $template = RT::Template->new( RT->SystemUser );
596 $template->LoadGlobalTemplate( $args{'Template'} );
597 unless ( $template->id ) {
598 return (undef, "Couldn't load template '". $args{'Template'} ."'");
600 return $template if $template->IsEmpty;
602 my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
603 return (undef, $msg) unless $status;
608 =head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
610 Sends email using a template, takes name of template, arguments for it and recipients.
614 sub SendEmailUsingTemplate {
621 From => RT->Config->Get('CorrespondAddress'),
627 my ($template, $msg) = PrepareEmailUsingTemplate( %args );
628 return (0, $msg) unless $template;
630 my $mail = $template->MIMEObj;
632 $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
636 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ $_ } ) )
637 foreach grep defined $args{$_}, qw(To Cc Bcc From);
639 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ExtraHeaders}{$_} ) )
640 foreach keys %{ $args{ExtraHeaders} };
642 SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
644 return SendEmail( Entity => $mail );
647 =head2 GetForwardFrom Ticket => undef, Transaction => undef
649 Resolve the From field to use in forward mail
654 my %args = ( Ticket => undef, Transaction => undef, @_ );
655 my $txn = $args{Transaction};
656 my $ticket = $args{Ticket} || $txn->Object;
658 if ( RT->Config->Get('ForwardFromUser') ) {
659 return ( $txn || $ticket )->CurrentUser->EmailAddress;
662 return $ticket->QueueObj->CorrespondAddress
663 || RT->Config->Get('CorrespondAddress');
667 =head2 GetForwardAttachments Ticket => undef, Transaction => undef
669 Resolve the Attachments to forward
673 sub GetForwardAttachments {
674 my %args = ( Ticket => undef, Transaction => undef, @_ );
675 my $txn = $args{Transaction};
676 my $ticket = $args{Ticket} || $txn->Object;
678 my $attachments = RT::Attachments->new( $ticket->CurrentUser );
680 $attachments->Limit( FIELD => 'TransactionId', VALUE => $txn->id );
683 $attachments->LimitByTicket( $ticket->id );
685 ALIAS => $attachments->TransactionAlias,
688 VALUE => [ qw(Create Correspond) ],
695 =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
697 Signs and encrypts message using L<RT::Crypt>, but as well handle errors
700 If a recipient has no key or has other problems with it, then the
701 unction sends a error to him using 'Error: public key' template.
702 Also, notifies RT's owner using template 'Error to RT owner: public key'
703 to inform that there are problems with users' keys. Then we filter
704 all bad recipients and retry.
706 Returns 1 on success, 0 on error and -1 if all recipients are bad and
707 had been filtered out.
718 return 1 unless $args{'Sign'} || $args{'Encrypt'};
720 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
723 $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
724 $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
726 my %res = RT::Crypt->SignEncrypt( %args );
727 return 1 unless $res{'exit_code'};
729 my @status = RT::Crypt->ParseStatus(
730 Protocol => $res{'Protocol'}, Status => $res{'status'},
734 foreach my $line ( @status ) {
735 # if the passphrase fails, either you have a bad passphrase
736 # or gpg-agent has died. That should get caught in Create and
737 # Update, but at least throw an error here
738 if (($line->{'Operation'}||'') eq 'PassphraseCheck'
739 && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
740 $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
743 next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
744 next if $line->{'Status'} eq 'DONE';
745 $RT::Logger->error( $line->{'Message'} );
746 push @bad_recipients, $line;
748 return 0 unless @bad_recipients;
750 $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
751 foreach @bad_recipients;
753 foreach my $recipient ( @bad_recipients ) {
754 my $status = SendEmailUsingTemplate(
755 To => $recipient->{'AddressObj'}->address,
756 Template => 'Error: public key',
759 TicketObj => $args{'Ticket'},
760 TransactionObj => $args{'Transaction'},
764 $RT::Logger->error("Couldn't send 'Error: public key'");
768 my $status = SendEmailUsingTemplate(
769 To => RT->Config->Get('OwnerEmail'),
770 Template => 'Error to RT owner: public key',
772 BadRecipients => \@bad_recipients,
773 TicketObj => $args{'Ticket'},
774 TransactionObj => $args{'Transaction'},
778 $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
781 DeleteRecipientsFromHead(
782 $args{'Entity'}->head,
783 map $_->{'AddressObj'}->address, @bad_recipients
786 unless ( $args{'Entity'}->head->get('To')
787 || $args{'Entity'}->head->get('Cc')
788 || $args{'Entity'}->head->get('Bcc') )
790 $RT::Logger->debug("$msgid No recipients that have public key, not sending");
794 # redo without broken recipients
795 %res = RT::Crypt->SignEncrypt( %args );
796 return 0 if $res{'exit_code'};
805 Takes a hash with a String and a Charset. Returns the string encoded
806 according to RFC2047, using B (base64 based) encoding.
808 String must be a perl string, octets are returned.
810 If Charset is not provided then $EmailOutputEncoding config option
811 is used, or "latin-1" if that is not set.
821 my $value = $args{'String'};
822 return $value unless $value; # 0 is perfect ascii
823 my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
826 # using RFC2047 notation, sec 2.
827 # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
829 # An 'encoded-word' may not be more than 75 characters long
831 # MIME encoding increases 4/3*(number of bytes), and always in multiples
832 # of 4. Thus we have to find the best available value of bytes available
835 # First we get the integer max which max*4/3 would fit on space.
836 # Then we find the greater multiple of 3 lower or equal than $max.
838 ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
842 $max = int( $max / 3 ) * 3;
849 $RT::Logger->crit("Can't encode! Charset or encoding too big.");
853 return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s;
857 my ( $tmp, @chunks ) = ( '', () );
858 while ( length $value ) {
859 my $char = substr( $value, 0, 1, '' );
860 my $octets = Encode::encode( $charset, $char );
861 if ( length($tmp) + length($octets) > $max ) {
867 push @chunks, $tmp if length $tmp;
869 # encode an join chuncks
871 map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
877 my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
879 my $NewUser = RT::User->new( RT->SystemUser );
881 my ( $Val, $Message ) = $NewUser->Create(
882 Name => ( $Username || $Address ),
883 EmailAddress => $Address,
887 Comments => 'Autocreated on ticket submission',
892 # Deal with the race condition of two account creations at once
894 $NewUser->LoadByName($Username);
897 unless ( $NewUser->Id ) {
898 $NewUser->LoadByEmail($Address);
901 unless ( $NewUser->Id ) {
904 Subject => "User could not be created",
906 "User creation failed in mailgateway: $Message",
913 #Load the new user object
914 my $CurrentUser = RT::CurrentUser->new;
915 $CurrentUser->LoadByEmail( $Address );
917 unless ( $CurrentUser->id ) {
918 $RT::Logger->warning(
919 "Couldn't load user '$Address'." . "giving up" );
922 Subject => "User could not be loaded",
924 "User '$Address' could not be loaded in the mail gateway",
935 =head2 ParseCcAddressesFromHead HASH
937 Takes a hash containing QueueObj, Head and CurrentUser objects.
938 Returns a list of all email addresses in the To and Cc
939 headers b<except> the current Queue's email addresses, the CurrentUser's
940 email address and anything that the configuration sub RT::IsRTAddress matches.
944 sub ParseCcAddressesFromHead {
948 CurrentUser => undef,
952 my $current_address = lc $args{'CurrentUser'}->EmailAddress;
953 my $user = $args{'CurrentUser'}->UserObj;
956 grep { $_ ne $current_address
957 && !RT::EmailParser->IsRTAddress( $_ )
958 && !IgnoreCcAddress( $_ )
960 map lc $user->CanonicalizeEmailAddress( $_->address ),
961 map RT::EmailParser->CleanupAddresses( Email::Address->parse(
962 Encode::decode( "UTF-8", $args{'Head'}->get( $_ ) ) ) ),
966 =head2 IgnoreCcAddress ADDRESS
968 Returns true if ADDRESS matches the $IgnoreCcRegexp config variable.
972 sub IgnoreCcAddress {
974 if ( my $address_re = RT->Config->Get('IgnoreCcRegexp') ) {
975 return 1 if $address =~ /$address_re/i;
980 =head2 ParseSenderAddressFromHead HEAD
982 Takes a MIME::Header object. Returns (user@host, friendly name, errors)
983 where the first two values are the From (evaluated in order of
984 Reply-To:, From:, Sender).
986 A list of error messages may be returned even when a Sender value is
987 found, since it could be a parse error for another (checked earlier)
988 sender field. In this case, the errors aren't fatal, but may be useful
989 to investigate the parse failure.
993 sub ParseSenderAddressFromHead {
995 my @sender_headers = ('Reply-To', 'From', 'Sender');
996 my @errors; # Accumulate any errors
998 #Figure out who's sending this message.
999 foreach my $header ( @sender_headers ) {
1000 my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next;
1001 my ($addr, $name) = ParseAddressFromHeader( $addr_line );
1002 # only return if the address is not empty
1003 return ($addr, $name, @errors) if $addr;
1006 push @errors, "$header: $addr_line";
1009 return (undef, undef, @errors);
1012 =head2 ParseErrorsToAddressFromHead HEAD
1014 Takes a MIME::Header object. Return a single value : user@host
1015 of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
1020 sub ParseErrorsToAddressFromHead {
1023 #Figure out who's sending this message.
1025 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
1027 # If there's a header of that name
1028 my $headerobj = Encode::decode( "UTF-8", $head->get($header) );
1030 my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
1032 # If it's got actual useful content...
1033 return ($addr) if ($addr);
1040 =head2 ParseAddressFromHeader ADDRESS
1042 Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
1046 sub ParseAddressFromHeader {
1049 # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
1050 $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
1051 my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
1053 my ($AddrObj) = grep ref $_, @Addresses;
1054 unless ( $AddrObj ) {
1055 return ( undef, undef );
1058 return ( $AddrObj->address, $AddrObj->phrase );
1061 =head2 DeleteRecipientsFromHead HEAD RECIPIENTS
1063 Gets a head object and list of addresses.
1064 Deletes addresses from To, Cc or Bcc fields.
1068 sub DeleteRecipientsFromHead {
1070 my %skip = map { lc $_ => 1 } @_;
1072 foreach my $field ( qw(To Cc Bcc) ) {
1073 $head->replace( $field => Encode::encode( "UTF-8",
1074 join ', ', map $_->format, grep !$skip{ lc $_->address },
1075 Email::Address->parse( Encode::decode( "UTF-8", $head->get( $field ) ) ) )
1084 ScripAction => undef,
1087 my $org = RT->Config->Get('Organization');
1088 my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
1089 my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
1090 my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
1092 return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
1093 . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
1103 return unless $args{'Message'} && $args{'InReplyTo'};
1105 my $get_header = sub {
1107 if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
1108 @res = map {Encode::decode("UTF-8", $_)} $args{'InReplyTo'}->head->get( shift );
1110 @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
1112 return grep length, map { split /\s+/m, $_ } grep defined, @res;
1115 my @id = $get_header->('Message-ID');
1116 #XXX: custom header should begin with X- otherwise is violation of the standard
1117 my @rtid = $get_header->('RT-Message-ID');
1118 my @references = $get_header->('References');
1119 unless ( @references ) {
1120 @references = $get_header->('In-Reply-To');
1122 push @references, @id, @rtid;
1123 if ( $args{'Ticket'} ) {
1124 my $pseudo_ref = PseudoReference( $args{'Ticket'} );
1125 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1127 splice @references, 4, -6
1128 if @references > 10;
1130 my $mail = $args{'Message'};
1131 $mail->head->replace( 'In-Reply-To' => Encode::encode( "UTF-8", join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
1132 $mail->head->replace( 'References' => Encode::encode( "UTF-8", join ' ', @references) );
1135 sub PseudoReference {
1137 return '<RT-Ticket-'. $ticket->id .'@'. RT->Config->Get('Organization') .'>';
1140 =head2 ExtractTicketId
1142 Passed a MIME::Entity. Returns a ticket id or undef to signal 'new ticket'.
1144 This is a great entry point if you need to customize how ticket ids are
1145 handled for your site. RT-Extension-RepliesToResolved demonstrates one
1146 possible use for this extension.
1148 If the Subject of this ticket is modified, it will be reloaded by the
1149 mail gateway code before Ticket creation.
1153 sub ExtractTicketId {
1156 my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') || '' );
1158 return ParseTicketId( $subject );
1161 =head2 ParseTicketId
1163 Takes a string and searches for [subjecttag #id]
1165 Returns the id if a match is found. Otherwise returns undef.
1170 my $Subject = shift;
1172 my $rtname = RT->Config->Get('rtname');
1173 my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
1175 # We use @captures and pull out the last capture value to guard against
1176 # someone using (...) instead of (?:...) in $EmailSubjectTagRegex.
1178 if ( my @captures = $Subject =~ /\[$test_name\s+\#(\d+)\s*\]/i ) {
1179 $id = $captures[-1];
1181 foreach my $tag ( RT->System->SubjectTag ) {
1182 next unless my @captures = $Subject =~ /\[\Q$tag\E\s+\#(\d+)\s*\]/i;
1183 $id = $captures[-1];
1187 return undef unless $id;
1189 $RT::Logger->debug("Found a ticket ID. It's $id");
1194 my $subject = shift;
1196 unless ( ref $ticket ) {
1197 my $tmp = RT::Ticket->new( RT->SystemUser );
1198 $tmp->Load( $ticket );
1201 my $id = $ticket->id;
1202 my $queue_tag = $ticket->QueueObj->SubjectTag;
1204 my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
1205 unless ( $tag_re ) {
1206 my $tag = $queue_tag || RT->Config->Get('rtname');
1207 $tag_re = qr/\Q$tag\E/;
1208 } elsif ( $queue_tag ) {
1209 $tag_re = qr/$tag_re|\Q$queue_tag\E/;
1211 return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
1213 $subject =~ s/(\r\n|\n|\s)/ /g;
1215 return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
1219 =head2 Gateway ARGSREF
1229 This performs all the "guts" of the mail rt-mailgate program, and is
1230 designed to be called from the web interface with a message, user
1233 Can also take an optional 'ticket' parameter; this ticket id overrides
1234 any ticket id found in the subject.
1240 (status code, message, optional ticket object)
1242 status code is a numeric value.
1244 for temporary failures, the status code should be -75
1246 for permanent failures which are handled by RT, the status code
1249 for succces, the status code should be 1
1256 my @mail_plugins = @_;
1259 foreach my $plugin (@mail_plugins) {
1260 if ( ref($plugin) eq "CODE" ) {
1262 } elsif ( !ref $plugin ) {
1263 my $Class = $plugin;
1264 $Class = "RT::Interface::Email::" . $Class
1265 unless $Class =~ /^RT::/;
1267 do { $RT::Logger->error("Couldn't load $Class: $@"); next };
1270 unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
1271 $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
1276 $RT::Logger->crit( "$plugin - is not class name or code reference");
1283 my $argsref = shift;
1285 action => 'correspond',
1295 # Validate the action
1296 my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
1300 "Invalid 'action' parameter "
1308 my $parser = RT::EmailParser->new();
1309 $parser->SmartParseMIMEEntityFromScalar(
1310 Message => $args{'message'},
1315 my $Message = $parser->Entity();
1318 Subject => "RT Bounce: Unparseable message",
1319 Explanation => "RT couldn't process the message below",
1320 Attach => $args{'message'}
1324 "Failed to parse this message. Something is likely badly wrong with the message"
1328 my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
1329 push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
1330 @mail_plugins = _LoadPlugins( @mail_plugins );
1332 #Set up a queue object
1333 my $SystemQueueObj = RT::Queue->new( RT->SystemUser );
1334 $SystemQueueObj->Load( $args{'queue'} );
1337 foreach my $class( grep !ref, @mail_plugins ) {
1338 # check if we should apply filter before decoding
1341 *{ $class . "::ApplyBeforeDecode" }{CODE};
1343 next unless defined $check_cb;
1344 next unless $check_cb->(
1345 Message => $Message,
1346 RawMessageRef => \$args{'message'},
1347 Queue => $SystemQueueObj,
1348 Actions => \@actions,
1351 $skip_plugin{ $class }++;
1355 *{ $class . "::GetCurrentUser" }{CODE};
1357 my ($status, $msg) = $Code->(
1358 Message => $Message,
1359 RawMessageRef => \$args{'message'},
1360 Queue => $SystemQueueObj,
1361 Actions => \@actions,
1363 next if $status > 0;
1365 if ( $status == -2 ) {
1366 return (1, $msg, undef);
1367 } elsif ( $status == -1 ) {
1368 return (0, $msg, undef);
1371 @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
1372 $parser->_DecodeBodies;
1373 $parser->RescueOutlook;
1374 $parser->_PostProcessNewEntity;
1376 my $head = $Message->head;
1377 my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
1378 my $Sender = (ParseSenderAddressFromHead( $head ))[0];
1379 my $From = Encode::decode( "UTF-8", $head->get("From") );
1380 chomp $From if defined $From;
1382 my $MessageId = Encode::decode( "UTF-8", $head->get('Message-ID') )
1383 || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1385 #Pull apart the subject line
1386 my $Subject = Encode::decode( "UTF-8", $head->get('Subject') || '');
1389 # Lets check for mail loops of various sorts.
1390 my ($should_store_machine_generated_message, $IsALoop, $result);
1391 ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
1392 _HandleMachineGeneratedMail(
1393 Message => $Message,
1394 ErrorsTo => $ErrorsTo,
1395 Subject => $Subject,
1396 MessageId => $MessageId
1399 # Do not pass loop messages to MailPlugins, to make sure the loop
1400 # is broken, unless $RT::StoreLoops is set.
1401 if ($IsALoop && !$should_store_machine_generated_message) {
1402 return ( 0, $result, undef );
1406 $args{'ticket'} ||= ExtractTicketId( $Message );
1408 # ExtractTicketId may have been overridden, and edited the Subject
1409 my $NewSubject = Encode::decode( "UTF-8", $Message->head->get('Subject') );
1412 $SystemTicket = RT::Ticket->new( RT->SystemUser );
1413 $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
1414 if ( $SystemTicket->id ) {
1415 $Right = 'ReplyToTicket';
1417 $Right = 'CreateTicket';
1420 # We can safely have no queue of we have a known-good ticket
1421 unless ( $SystemTicket->id || $SystemQueueObj->id ) {
1422 return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
1425 my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
1426 MailPlugins => \@mail_plugins,
1427 Actions => \@actions,
1428 Message => $Message,
1429 RawMessageRef => \$args{message},
1430 SystemTicket => $SystemTicket,
1431 SystemQueue => $SystemQueueObj,
1434 # If authentication fails and no new user was created, get out.
1435 if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
1437 # If the plugins refused to create one, they lose.
1438 unless ( $AuthStat == -1 ) {
1439 _NoAuthorizedUserFound(
1441 Message => $Message,
1442 Requestor => $ErrorsTo,
1443 Queue => $args{'queue'}
1447 return ( 0, "Could not load a valid user", undef );
1450 # If we got a user, but they don't have the right to say things
1451 if ( $AuthStat == 0 ) {
1454 Subject => "Permission Denied",
1456 "You do not have permission to communicate with RT",
1461 ($CurrentUser->EmailAddress || $CurrentUser->Name)
1462 . " ($Sender) tried to submit a message to "
1464 . " without permission.",
1470 unless ($should_store_machine_generated_message) {
1471 return ( 0, $result, undef );
1474 $head->replace('X-RT-Interface' => 'Email');
1476 # if plugin's updated SystemTicket then update arguments
1477 $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
1479 my $Ticket = RT::Ticket->new($CurrentUser);
1481 if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
1485 my @Requestors = ( $CurrentUser->id );
1487 if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
1488 @Cc = ParseCcAddressesFromHead(
1490 CurrentUser => $CurrentUser,
1491 QueueObj => $SystemQueueObj
1495 my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1496 Queue => $SystemQueueObj->Id,
1497 Subject => $NewSubject,
1498 Requestor => \@Requestors,
1505 Subject => "Ticket creation failed: $Subject",
1506 Explanation => $ErrStr,
1509 return ( 0, "Ticket creation From: $From failed: $ErrStr", $Ticket );
1512 # strip comments&corresponds from the actions we don't need
1513 # to record them if we've created the ticket just now
1514 @actions = grep !/^(comment|correspond)$/, @actions;
1515 $args{'ticket'} = $id;
1517 } elsif ( $args{'ticket'} ) {
1519 $Ticket->Load( $args{'ticket'} );
1520 unless ( $Ticket->Id ) {
1521 my $error = "Could not find a ticket with id " . $args{'ticket'};
1524 Subject => "Message not recorded: $Subject",
1525 Explanation => $error,
1529 return ( 0, $error );
1531 $args{'ticket'} = $Ticket->id;
1533 return ( 1, "Success", $Ticket );
1538 my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
1539 foreach my $action (@actions) {
1541 # If the action is comment, add a comment.
1542 if ( $action =~ /^(?:comment|correspond)$/i ) {
1543 my $method = ucfirst lc $action;
1544 my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
1547 #Warn the sender that we couldn't actually submit the comment.
1550 Subject => "Message not recorded ($method): $Subject",
1551 Explanation => $msg,
1554 return ( 0, "Message From: $From not recorded: $msg", $Ticket );
1556 } elsif ($unsafe_actions) {
1557 my ( $status, $msg ) = _RunUnsafeAction(
1559 ErrorsTo => $ErrorsTo,
1560 Message => $Message,
1562 CurrentUser => $CurrentUser,
1564 return ($status, $msg, $Ticket) unless $status == 1;
1567 return ( 1, "Success", $Ticket );
1570 =head2 GetAuthenticationLevel
1572 # Authentication Level
1573 # -1 - Get out. this user has been explicitly declined
1574 # 0 - User may not do anything (Not used at the moment)
1576 # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
1580 sub GetAuthenticationLevel {
1585 RawMessageRef => undef,
1586 SystemTicket => undef,
1587 SystemQueue => undef,
1591 my ( $CurrentUser, $AuthStat, $error );
1593 # Initalize AuthStat so comparisons work correctly
1594 $AuthStat = -9999999;
1596 # if plugin returns AuthStat -2 we skip action
1597 # NOTE: this is experimental API and it would be changed
1598 my %skip_action = ();
1600 # Since this needs loading, no matter what
1601 foreach (@{ $args{MailPlugins} }) {
1602 my ($Code, $NewAuthStat);
1603 if ( ref($_) eq "CODE" ) {
1607 $Code = *{ $_ . "::GetCurrentUser" }{CODE};
1610 foreach my $action (@{ $args{Actions} }) {
1611 ( $CurrentUser, $NewAuthStat ) = $Code->(
1612 Message => $args{Message},
1613 RawMessageRef => $args{RawMessageRef},
1614 CurrentUser => $CurrentUser,
1615 AuthLevel => $AuthStat,
1617 Ticket => $args{SystemTicket},
1618 Queue => $args{SystemQueue},
1621 # You get the highest level of authentication you were assigned, unless you get the magic -1
1622 # If a module returns a "-1" then we discard the ticket, so.
1623 $AuthStat = $NewAuthStat
1624 if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
1626 last if $AuthStat == -1;
1627 $skip_action{$action}++ if $AuthStat == -2;
1630 # strip actions we should skip
1631 @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
1633 last unless @{$args{Actions}};
1635 last if $AuthStat == -1;
1638 return $AuthStat if !wantarray;
1640 return ($AuthStat, $CurrentUser, $error);
1643 sub _RunUnsafeAction {
1649 CurrentUser => undef,
1653 my $From = Encode::decode( "UTF-8", $args{Message}->head->get("From") );
1655 if ( $args{'Action'} =~ /^take$/i ) {
1656 my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
1659 To => $args{'ErrorsTo'},
1660 Subject => "Ticket not taken",
1661 Explanation => $msg,
1662 MIMEObj => $args{'Message'}
1664 return ( 0, "Ticket not taken, by email From: $From" );
1666 } elsif ( $args{'Action'} =~ /^resolve$/i ) {
1667 my $new_status = $args{'Ticket'}->FirstInactiveStatus;
1669 my ( $status, $msg ) = $args{'Ticket'}->SetStatus($new_status);
1672 #Warn the sender that we couldn't actually submit the comment.
1674 To => $args{'ErrorsTo'},
1675 Subject => "Ticket not resolved",
1676 Explanation => $msg,
1677 MIMEObj => $args{'Message'}
1679 return ( 0, "Ticket not resolved, by email From: $From" );
1683 return ( 0, "Not supported unsafe action $args{'Action'}, by email From: $From", $args{'Ticket'} );
1685 return ( 1, "Success" );
1688 =head2 _NoAuthorizedUserFound
1690 Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1694 sub _NoAuthorizedUserFound {
1703 # Notify the RT Admin of the failure.
1705 To => RT->Config->Get('OwnerEmail'),
1706 Subject => "Could not load a valid user",
1707 Explanation => <<EOT,
1708 RT could not load a valid user, and RT's configuration does not allow
1709 for the creation of a new user for this email (@{[$args{Requestor}]}).
1711 You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1712 queue @{[$args{'Queue'}]}.
1715 MIMEObj => $args{'Message'},
1719 # Also notify the requestor that his request has been dropped.
1720 if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
1722 To => $args{'Requestor'},
1723 Subject => "Could not load a valid user",
1724 Explanation => <<EOT,
1725 RT could not load a valid user, and RT's configuration does not allow
1726 for the creation of a new user for your email.
1729 MIMEObj => $args{'Message'},
1735 =head2 _HandleMachineGeneratedMail
1742 Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1743 Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
1744 "This message appears to be a loop (boolean)" );
1748 sub _HandleMachineGeneratedMail {
1749 my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
1750 my $head = $args{'Message'}->head;
1751 my $ErrorsTo = $args{'ErrorsTo'};
1753 my $IsBounce = CheckForBounce($head);
1755 my $IsAutoGenerated = CheckForAutoGenerated($head);
1757 my $IsSuspiciousSender = CheckForSuspiciousSender($head);
1759 my $IsALoop = CheckForLoops($head);
1761 my $SquelchReplies = 0;
1763 my $owner_mail = RT->Config->Get('OwnerEmail');
1765 #If the message is autogenerated, we need to know, so we can not
1766 # send mail to the sender
1767 if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
1768 $SquelchReplies = 1;
1769 $ErrorsTo = $owner_mail;
1772 # Warn someone if it's a loop, before we drop it on the ground
1774 $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
1776 #Should we mail it to RTOwner?
1777 if ( RT->Config->Get('LoopsToRTOwner') ) {
1780 Subject => "RT Bounce: ".$args{'Subject'},
1781 Explanation => "RT thinks this message may be a bounce",
1782 MIMEObj => $args{Message}
1786 #Do we actually want to store it?
1787 return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
1788 unless RT->Config->Get('StoreLoops');
1791 # Squelch replies if necessary
1792 # Don't let the user stuff the RT-Squelch-Replies-To header.
1793 if ( $head->get('RT-Squelch-Replies-To') ) {
1795 'RT-Relocated-Squelch-Replies-To',
1796 $head->get('RT-Squelch-Replies-To')
1798 $head->delete('RT-Squelch-Replies-To');
1801 if ($SquelchReplies) {
1803 # Squelch replies to the sender, and also leave a clue to
1804 # allow us to squelch ALL outbound messages. This way we
1805 # can punt the logic of "what to do when we get a bounce"
1806 # to the scrip. We might want to notify nobody. Or just
1807 # the RT Owner. Or maybe all Privileged watchers.
1808 my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
1809 $head->replace( 'RT-Squelch-Replies-To', Encode::encode("UTF-8", $Sender ) );
1810 $head->replace( 'RT-DetectedAutoGenerated', 'true' );
1812 return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1815 =head2 IsCorrectAction
1817 Returns a list of valid actions we've found for this message
1821 sub IsCorrectAction {
1823 my @actions = grep $_, split /-/, $action;
1824 return ( 0, '(no value)' ) unless @actions;
1825 foreach ( @actions ) {
1826 return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
1828 return ( 1, @actions );
1831 sub _RecordSendEmailFailure {
1834 $ticket->_NewTransaction(
1835 Type => "SystemError",
1836 Data => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.", #loc
1837 ActivateScrips => 0,
1842 $RT::Logger->error( "Can't record send email failure as ticket is missing" );
1847 =head2 ConvertHTMLToText HTML
1849 Takes HTML characters and converts it to plain text characters.
1850 Appropriate for generating a plain text part from an HTML part of an
1851 email. Returns undef if conversion fails.
1855 sub ConvertHTMLToText {
1856 return _HTMLFormatter()->(@_);
1859 sub _HTMLFormatter {
1861 return $formatter if defined $formatter;
1863 my $wanted = RT->Config->Get("HTMLFormatter");
1867 @order = ($wanted, "core");
1869 @order = ("w3m", "elinks", "links", "html2text", "lynx", "core");
1871 # Always fall back to core, even if it is not listed
1872 for my $prog (@order) {
1873 if ($prog eq "core") {
1874 RT->Logger->debug("Using internal Perl HTML -> text conversion");
1875 require HTML::FormatText::WithLinks::AndTables;
1876 $formatter = \&_HTMLFormatText;
1878 unless (HTML::FormatExternal->require) {
1879 RT->Logger->warn("HTML::FormatExternal is not installed; falling back to internal perl formatter")
1884 my $path = $prog =~ s{(.*/)}{} ? $1 : undef;
1885 my $package = "HTML::FormatText::" . ucfirst($prog);
1886 unless ($package->require) {
1887 RT->Logger->warn("$prog is not a valid formatter provided by HTML::FormatExternal")
1893 local $ENV{PATH} = $path;
1894 local $ENV{HOME} = File::Spec->tmpdir();
1895 if (not defined $package->program_version) {
1896 RT->Logger->warn("Could not find or run external '$prog' HTML formatter in $path$prog")
1901 local $ENV{PATH} = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin'
1902 unless defined $ENV{PATH};
1903 local $ENV{HOME} = File::Spec->tmpdir();
1904 if (not defined $package->program_version) {
1905 RT->Logger->warn("Could not find or run external '$prog' HTML formatter in \$PATH ($ENV{PATH}) -- you may need to install it or provide the full path")
1911 RT->Logger->debug("Using $prog for HTML -> text conversion");
1914 my $text = RT::Util::safe_run_child {
1915 local $ENV{PATH} = $path || $ENV{PATH}
1916 || '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin';
1917 local $ENV{HOME} = File::Spec->tmpdir();
1918 $package->format_string(
1919 Encode::encode( "UTF-8", $html ),
1920 input_charset => "UTF-8",
1921 output_charset => "UTF-8",
1922 leftmargin => 0, rightmargin => 78
1925 $text = Encode::decode( "UTF-8", $text );
1929 RT->Config->Set( HTMLFormatter => $prog );
1935 sub _HTMLFormatText {
1940 $text = HTML::FormatText::WithLinks::AndTables->convert(
1946 after_link => ' (%l)',
1948 skip_linked_urls => 1,
1954 $RT::Logger->error("Failed to downgrade HTML to plain text: $@") if $@;
1959 RT::Base->_ImportOverlays();