rt/lib/RT/Action/SendEmail.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
   6 #                                          <jesse@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  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
  16 # from www.gnu.org.
  17 #
  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.
  22 #
  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.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  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.)
  37 #
  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.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48 # Portions Copyright 2000 Tobias Brox <tobix@cpan.org>
  49
  50 package RT::Action::SendEmail;
  51 require RT::Action::Generic;
  52
  53 use strict;
  54 use vars qw/@ISA/;
  55 @ISA = qw(RT::Action::Generic);
  56
  57 use MIME::Words qw(encode_mimeword);
  58
  59 use RT::EmailParser;
  60 use Mail::Address;
  61 use Date::Format qw(strftime);
  62
  63 =head1 NAME
  64
  65 RT::Action::SendEmail - An Action which users can use to send mail
  66 or can subclassed for more specialized mail sending behavior.
  67 RT::Action::AutoReply is a good example subclass.
  68
  69 =head1 SYNOPSIS
  70
  71   require RT::Action::SendEmail;
  72   @ISA  = qw(RT::Action::SendEmail);
  73
  74
  75 =head1 DESCRIPTION
  76
  77 Basically, you create another module RT::Action::YourAction which ISA
  78 RT::Action::SendEmail.
  79
  80 =begin testing
  81
  82 ok (require RT::Action::SendEmail);
  83
  84 =end testing
  85
  86
  87 =head1 AUTHOR
  88
  89 Jesse Vincent <jesse@bestpractical.com> and Tobias Brox <tobix@cpan.org>
  90
  91 =head1 SEE ALSO
  92
  93 perl(1).
  94
  95 =cut
  96
  97 # {{{ Scrip methods (_Init, Commit, Prepare, IsApplicable)
  98
  99
 100 # {{{ sub Commit
 101
 102 sub Commit {
 103     # DO NOT SHIFT @_ in this subroutine.  It breaks Hook::LexWrap's
 104     # ability to pass @_ to a 'post' routine.
 105     my $self = $_[0];
 106
 107     my ($ret) = $self->SendMessage( $self->TemplateObj->MIMEObj );
 108     if ( $ret > 0 ) {
 109         $self->RecordOutgoingMailTransaction( $self->TemplateObj->MIMEObj )
 110             if ($RT::RecordOutgoingEmail);
 111     }
 112     return (abs $ret);
 113 }
 114
 115 # }}}
 116
 117 # {{{ sub Prepare
 118
 119 sub Prepare {
 120     my $self = shift;
 121
 122     my ( $result, $message ) = $self->TemplateObj->Parse(
 123         Argument       => $self->Argument,
 124         TicketObj      => $self->TicketObj,
 125         TransactionObj => $self->TransactionObj
 126     );
 127     if ( !$result ) {
 128         return (undef);
 129     }
 130
 131     my $MIMEObj = $self->TemplateObj->MIMEObj;
 132
 133     # Header
 134     $self->SetRTSpecialHeaders();
 135
 136     $self->RemoveInappropriateRecipients();
 137
 138     my %seen;
 139     foreach my $type qw(To Cc Bcc) {
 140         @{ $self->{ $type } } =
 141             grep defined && length && !$seen{ lc $_ }++,
 142                 @{ $self->{ $type } };
 143     }
 144
 145     # Go add all the Tos, Ccs and Bccs that we need to to the message to
 146     # make it happy, but only if we actually have values in those arrays.
 147
 148     # TODO: We should be pulling the recipients out of the template and shove them into To, Cc and Bcc
 149
 150     $self->SetHeader( 'To', join ( ', ', @{ $self->{'To'} } ) )
 151       if ( ! $MIMEObj->head->get('To') &&  $self->{'To'} && @{ $self->{'To'} } );
 152     $self->SetHeader( 'Cc', join ( ', ', @{ $self->{'Cc'} } ) )
 153       if ( !$MIMEObj->head->get('Cc') && $self->{'Cc'} && @{ $self->{'Cc'} } );
 154     $self->SetHeader( 'Bcc', join ( ', ', @{ $self->{'Bcc'} } ) )
 155       if ( !$MIMEObj->head->get('Bcc') && $self->{'Bcc'} && @{ $self->{'Bcc'} } );
 156
 157     # PseudoTo  (fake to headers) shouldn't get matched for message recipients.
 158     # If we don't have any 'To' header (but do have other recipients), drop in
 159     # the pseudo-to header.
 160     $self->SetHeader( 'To', join ( ', ', @{ $self->{'PseudoTo'} } ) )
 161       if ( $self->{'PseudoTo'} && ( @{ $self->{'PseudoTo'} } )
 162         and ( !$MIMEObj->head->get('To') ) ) and ( $MIMEObj->head->get('Cc') or $MIMEObj->head->get('Bcc'));
 163
 164     # We should never have to set the MIME-Version header
 165     $self->SetHeader( 'MIME-Version', '1.0' );
 166
 167     # fsck.com #5959: Since RT sends 8bit mail, we should say so.
 168     $self->SetHeader( 'Content-Transfer-Encoding','8bit');
 169
 170     # For security reasons, we only send out textual mails.
 171     my @parts = $MIMEObj;
 172     while (my $part = shift @parts) {
 173         if ($part->is_multipart) {
 174             push @parts, $part->parts;
 175         }
 176         else {
 177             if ( RT::I18N::IsTextualContentType( $part->mime_type ) ) {
 178                 $part->head->mime_attr( "Content-Type" => $part->mime_type )
 179             } else {
 180                 $part->head->mime_attr( "Content-Type" => 'text/plain' );
 181             }
 182             $part->head->mime_attr( "Content-Type.charset" => 'utf-8' );
 183         }
 184     }
 185
 186
 187     RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, $RT::EmailOutputEncoding, 'mime_words_ok' );
 188
 189     # Build up a MIME::Entity that looks like the original message.
 190     $self->AddAttachments() if ( $MIMEObj->head->get('RT-Attach-Message') );
 191
 192     return $result;
 193
 194 }
 195
 196 # }}}
 197
 198 # }}}
 199
 200
 201
 202 =head2 To
 203
 204 Returns an array of Mail::Address objects containing all the To: recipients for this notification
 205
 206 =cut
 207
 208 sub To {
 209     my $self = shift;
 210     return ($self->_AddressesFromHeader('To'));
 211 }
 212
 213 =head2 Cc
 214
 215 Returns an array of Mail::Address objects containing all the Cc: recipients for this notification
 216
 217 =cut
 218
 219 sub Cc {
 220     my $self = shift;
 221     return ($self->_AddressesFromHeader('Cc'));
 222 }
 223
 224 =head2 Bcc
 225
 226 Returns an array of Mail::Address objects containing all the Bcc: recipients for this notification
 227
 228 =cut
 229
 230
 231 sub Bcc {
 232     my $self = shift;
 233     return ($self->_AddressesFromHeader('Bcc'));
 234
 235 }
 236
 237 sub _AddressesFromHeader  {
 238     my $self = shift;
 239     my $field = shift;
 240     my $header = $self->TemplateObj->MIMEObj->head->get($field);
 241     my @addresses = Mail::Address->parse($header);
 242
 243     return (@addresses);
 244 }
 245
 246
 247 # {{{ SendMessage
 248
 249 =head2 SendMessage MIMEObj
 250
 251 sends the message using RT's preferred API.
 252 TODO: Break this out to a separate module
 253
 254 =cut
 255
 256 sub SendMessage {
 257     # DO NOT SHIFT @_ in this subroutine.  It breaks Hook::LexWrap's
 258     # ability to pass @_ to a 'post' routine.
 259     my ( $self, $MIMEObj ) = @_;
 260
 261     my $msgid = $MIMEObj->head->get('Message-ID');
 262     chomp $msgid;
 263
 264     $self->ScripActionObj->{_Message_ID}++;
 265
 266     $RT::Logger->info( $msgid . " #"
 267         . $self->TicketObj->id . "/"
 268         . $self->TransactionObj->id
 269         . " - Scrip "
 270         . $self->ScripObj->id . " "
 271         . $self->ScripObj->Description );
 272
 273     #If we don't have any recipients to send to, don't send a message;
 274     unless ( $MIMEObj->head->get('To')
 275         || $MIMEObj->head->get('Cc')
 276         || $MIMEObj->head->get('Bcc') )
 277     {
 278         $RT::Logger->info( $msgid . " No recipients found. Not sending.\n" );
 279         return (-1);
 280     }
 281
 282     unless ($MIMEObj->head->get('Date')) {
 283         # We coerce localtime into an array since strftime has a flawed prototype that only accepts
 284         # a list
 285       $MIMEObj->head->replace(Date => strftime('%a, %d %b %Y %H:%M:%S %z', @{[localtime()]}));
 286     }
 287
 288     return (0) unless ($self->OutputMIMEObject($MIMEObj));
 289
 290     my $success = $msgid . " sent ";
 291     foreach( qw(To Cc Bcc) ) {
 292         my $recipients = $MIMEObj->head->get($_);
 293         $success .= " $_: ". $recipients if $recipients;
 294     }
 295     $success =~ s/\n//g;
 296
 297     $RT::Logger->info($success);
 298
 299     return (1);
 300 }
 301
 302
 303 =head2 OutputMIMEObject MIME::Entity
 304
 305 Sends C<MIME::Entity> as an email message according to RT's mailer configuration.
 306
 307 =cut
 308
 309
 310
 311 sub OutputMIMEObject {
 312     my $self = shift;
 313     my $MIMEObj = shift;
 314
 315     my $msgid = $MIMEObj->head->get('Message-ID');
 316     chomp $msgid;
 317
 318     my $SendmailArguments = $RT::SendmailArguments;
 319     if (defined $RT::VERPPrefix && defined $RT::VERPDomain) {
 320       my $EnvelopeFrom = $self->TransactionObj->CreatorObj->EmailAddress;
 321       $EnvelopeFrom =~ s/@/=/g;
 322       $EnvelopeFrom =~ s/\s//g;
 323       $SendmailArguments .= " -f ${RT::VERPPrefix}${EnvelopeFrom}\@${RT::VERPDomain}";
 324     }
 325
 326
 327     if ( $RT::MailCommand eq 'sendmailpipe' ) {
 328         eval {
 329             # don't ignore CHLD signal to get proper exit code
 330             local $SIG{'CHLD'} = 'DEFAULT';
 331
 332             my $mail;
 333             unless( open $mail, "|$RT::SendmailPath $SendmailArguments" ) {
 334                 die "Couldn't run $RT::SendmailPath: $!";
 335             }
 336
 337             # if something wrong with $mail->print we will get PIPE signal, handle it
 338             local $SIG{'PIPE'} = sub { die "$RT::SendmailPath closed pipe" };
 339             $MIMEObj->print($mail);
 340
 341             unless ( close $mail ) {
 342                 die "Close failed: $!" if $!; # system error
 343                 # sendmail exit statuses mostly errors with data not software
 344                 # TODO: status parsing: core dump, exit on signal or EX_*
 345                 $RT::Logger->warning( "$RT::SendmailPath exitted with status $?" );
 346             }
 347         };
 348         if ($@) {
 349             $RT::Logger->crit( $msgid . "Could not send mail: " . $@ );
 350             return 0;
 351         }
 352     }
 353     else {
 354         my @mailer_args = ($RT::MailCommand);
 355         my $method = 'send';
 356
 357         local $ENV{MAILADDRESS};
 358
 359         if ( $RT::MailCommand eq 'sendmail' ) {
 360             push @mailer_args, split(/\s+/, $SendmailArguments);
 361         }
 362         elsif ( $RT::MailCommand eq 'smtp' ) {
 363             $ENV{MAILADDRESS} = $RT::SMTPFrom || $MIMEObj->head->get('From');
 364             push @mailer_args, ( Host  => $RT::SMTPServer );
 365             push @mailer_args, ( Debug => $RT::SMTPDebug );
 366             $method = 'smtpsend';
 367         }
 368         else {
 369             push @mailer_args, $RT::MailParams;
 370         }
 371
 372         unless ( $MIMEObj->$method(@mailer_args) ) {
 373             $RT::Logger->crit( $msgid . "Could not send mail." );
 374             return (0);
 375         }
 376     }
 377     return 1;
 378 }
 379
 380 # }}}
 381
 382 # {{{ AddAttachments
 383
 384 =head2 AddAttachments
 385
 386 Takes any attachments to this transaction and attaches them to the message
 387 we're building.
 388
 389 =cut
 390
 391
 392 sub AddAttachments {
 393     my $self = shift;
 394
 395     my $MIMEObj = $self->TemplateObj->MIMEObj;
 396
 397     $MIMEObj->head->delete('RT-Attach-Message');
 398
 399     my $attachments = RT::Attachments->new($RT::SystemUser);
 400     $attachments->Limit(
 401         FIELD => 'TransactionId',
 402         VALUE => $self->TransactionObj->Id
 403     );
 404     $attachments->OrderBy( FIELD => 'id');
 405
 406     my $transaction_content_obj = $self->TransactionObj->ContentObj;
 407
 408     # attach any of this transaction's attachments
 409     while ( my $attach = $attachments->Next ) {
 410
 411         # Don't attach anything blank
 412         next unless ( $attach->ContentLength );
 413
 414 # We want to make sure that we don't include the attachment that's being used as the "Content" of this message.
 415         next
 416           if ( $transaction_content_obj
 417             && $transaction_content_obj->Id == $attach->Id
 418             && $transaction_content_obj->ContentType =~ qr{text/plain}i );
 419         $MIMEObj->make_multipart('mixed');
 420         $MIMEObj->attach(
 421             Type     => $attach->ContentType,
 422             Charset  => $attach->OriginalEncoding,
 423             Data     => $attach->OriginalContent,
 424             Filename => $self->MIMEEncodeString( $attach->Filename,
 425                 $RT::EmailOutputEncoding ),
 426             'RT-Attachment:' => $self->TicketObj->Id."/".$self->TransactionObj->Id."/".$attach->id,
 427             Encoding => '-SUGGEST'
 428         );
 429     }
 430
 431 }
 432
 433 # }}}
 434
 435 # {{{ RecordOutgoingMailTransaction
 436
 437 =head2 RecordOutgoingMailTransaction MIMEObj
 438
 439 Record a transaction in RT with this outgoing message for future record-keeping purposes
 440
 441 =cut
 442
 443
 444
 445 sub RecordOutgoingMailTransaction {
 446     my $self = shift;
 447     my $MIMEObj = shift;
 448
 449
 450     my @parts = $MIMEObj->parts;
 451     my @attachments;
 452     my @keep;
 453     foreach my $part (@parts) {
 454         my $attach = $part->head->get('RT-Attachment');
 455         if ($attach) {
 456             $RT::Logger->debug("We found an attachment. we want to not record it.");
 457             push @attachments, $attach;
 458         } else {
 459             $RT::Logger->debug("We found a part. we want to record it.");
 460             push @keep, $part;
 461         }
 462     }
 463     $MIMEObj->parts(\@keep);
 464     foreach my $attachment (@attachments) {
 465         $MIMEObj->head->add('RT-Attachment', $attachment);
 466     }
 467
 468     RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, 'utf-8', 'mime_words_ok' );
 469
 470     my $transaction = RT::Transaction->new($self->TransactionObj->CurrentUser);
 471
 472     # XXX: TODO -> Record attachments as references to things in the attachments table, maybe.
 473
 474     my $type;
 475     if ($self->TransactionObj->Type eq 'Comment') {
 476         $type = 'CommentEmailRecord';
 477     } else {
 478         $type = 'EmailRecord';
 479     }
 480
 481     my $msgid = $MIMEObj->head->get('Message-ID');
 482     chomp $msgid;
 483
 484     my ( $id, $msg ) = $transaction->Create(
 485         Ticket         => $self->TicketObj->Id,
 486         Type           => $type,
 487         Data           => $msgid,
 488         MIMEObj        => $MIMEObj,
 489         ActivateScrips => 0
 490     );
 491
 492     if( $id ) {
 493         $self->{'OutgoingMailTransaction'} = $id;
 494     } else {
 495         $RT::Logger->warning( "Could not record outgoing message transaction: $msg" );
 496     }
 497     return $id;
 498 }
 499
 500 # }}}
 501 #
 502
 503 # {{{ sub SetRTSpecialHeaders
 504
 505 =head2 SetRTSpecialHeaders
 506
 507 This routine adds all the random headers that RT wants in a mail message
 508 that don't matter much to anybody else.
 509
 510 =cut
 511
 512 sub SetRTSpecialHeaders {
 513     my $self = shift;
 514
 515     $self->SetSubject();
 516     $self->SetSubjectToken();
 517     $self->SetHeaderAsEncoding( 'Subject', $RT::EmailOutputEncoding )
 518       if ($RT::EmailOutputEncoding);
 519     $self->SetReturnAddress();
 520     $self->SetReferencesHeaders();
 521
 522     unless ($self->TemplateObj->MIMEObj->head->get('Message-ID')) {
 523       # Get Message-ID for this txn
 524       my $msgid = "";
 525       $msgid = $self->TransactionObj->Message->First->GetHeader("RT-Message-ID")
 526         || $self->TransactionObj->Message->First->GetHeader("Message-ID")
 527         if $self->TransactionObj->Message && $self->TransactionObj->Message->First;
 528
 529       # If there is one, and we can parse it, then base our Message-ID on it
 530       if ($msgid
 531           and $msgid =~ s/<(rt-.*?-\d+-\d+)\.(\d+)-\d+-\d+\@\Q$RT::Organization\E>$/
 532                          "<$1." . $self->TicketObj->id
 533                           . "-" . $self->ScripObj->id
 534                           . "-" . $self->ScripActionObj->{_Message_ID}
 535                           . "@" . $RT::Organization . ">"/eg
 536           and $2 == $self->TicketObj->id) {
 537         $self->SetHeader( "Message-ID" => $msgid );
 538       } else {
 539         $self->SetHeader( 'Message-ID',
 540             "<rt-"
 541             . $RT::VERSION . "-"
 542             . $$ . "-"
 543             . CORE::time() . "-"
 544             . int(rand(2000)) . '.'
 545             . $self->TicketObj->id . "-"
 546             . $self->ScripObj->id . "-"  # Scrip
 547             . $self->ScripActionObj->{_Message_ID} . "@"  # Email sent
 548             . $RT::Organization
 549             . ">" );
 550       }
 551     }
 552
 553     $self->SetHeader( 'Precedence', "bulk" )
 554       unless ( $self->TemplateObj->MIMEObj->head->get("Precedence") );
 555
 556     $self->SetHeader( 'X-RT-Loop-Prevention', $RT::rtname );
 557     $self->SetHeader( 'RT-Ticket',
 558         $RT::rtname . " #" . $self->TicketObj->id() );
 559     $self->SetHeader( 'Managed-by',
 560         "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
 561
 562     $self->SetHeader( 'RT-Originator',
 563         $self->TransactionObj->CreatorObj->EmailAddress );
 564
 565 }
 566
 567 # }}}
 568
 569
 570 # }}}
 571
 572 # {{{ RemoveInappropriateRecipients
 573
 574 =head2 RemoveInappropriateRecipients
 575
 576 Remove addresses that are RT addresses or that are on this transaction's blacklist
 577
 578 =cut
 579
 580 sub RemoveInappropriateRecipients {
 581     my $self = shift;
 582
 583     my $msgid = $self->TemplateObj->MIMEObj->head->get  ('Message-Id');
 584
 585
 586
 587     my @blacklist;
 588
 589     my @types = qw/To Cc Bcc/;
 590
 591     # Weed out any RT addresses. We really don't want to talk to ourselves!
 592     foreach my $type (@types) {
 593         @{ $self->{$type} } =
 594           RT::EmailParser::CullRTAddresses( "", @{ $self->{$type} } );
 595     }
 596
 597     # If there are no recipients, don't try to send the message.
 598     # If the transaction has content and has the header RT-Squelch-Replies-To
 599
 600     if ( $self->TransactionObj->Attachments->First() ) {
 601         if (
 602             $self->TransactionObj->Attachments->First->GetHeader(
 603                 'RT-DetectedAutoGenerated')
 604           )
 605         {
 606
 607             # What do we want to do with this? It's probably (?) a bounce
 608             # caused by one of the watcher addresses being broken.
 609             # Default ("true") is to redistribute, for historical reasons.
 610
 611             if ( !$RT::RedistributeAutoGeneratedMessages ) {
 612
 613                 # Don't send to any watchers.
 614                 @{ $self->{'To'} }  = ();
 615                 @{ $self->{'Cc'} }  = ();
 616                 @{ $self->{'Bcc'} } = ();
 617
 618                 $RT::Logger->info( $msgid . " The incoming message was autogenerated. Not redistributing this message based on site configuration.\n");
 619             }
 620             elsif ( $RT::RedistributeAutoGeneratedMessages eq 'privileged' ) {
 621
 622                 # Only send to "privileged" watchers.
 623                 #
 624
 625                 foreach my $type (@types) {
 626
 627                     foreach my $addr ( @{ $self->{$type} } ) {
 628                         my $user = RT::User->new($RT::SystemUser);
 629                         $user->LoadByEmail($addr);
 630                         @{ $self->{$type} } =
 631                           grep ( !/^\Q$addr\E$/, @{ $self->{$type} } )
 632                           if ( !$user->Privileged );
 633
 634                     }
 635                 }
 636                 $RT::Logger->info( $msgid . " The incoming message was autogenerated. Not redistributing this message to unprivileged users based on site configuration.\n");
 637
 638             }
 639
 640         }
 641
 642         my $squelch =
 643           $self->TransactionObj->Attachments->First->GetHeader(
 644             'RT-Squelch-Replies-To');
 645
 646         if ($squelch) {
 647             @blacklist = split( /,/, $squelch );
 648         }
 649     }
 650
 651     # Let's grab the SquelchMailTo attribue and push those entries into the @blacklist
 652     my @non_recipients = $self->TicketObj->SquelchMailTo;
 653     foreach my $attribute (@non_recipients) {
 654         push @blacklist, $attribute->Content;
 655     }
 656
 657     # Cycle through the people we're sending to and pull out anyone on the
 658     # system blacklist
 659
 660     foreach my $person_to_yank (@blacklist) {
 661         $person_to_yank =~ s/\s//g;
 662         foreach my $type (@types) {
 663             @{ $self->{$type} } =
 664               grep ( !/^\Q$person_to_yank\E$/, @{ $self->{$type} } );
 665         }
 666     }
 667 }
 668
 669 # }}}
 670 # {{{ sub SetReturnAddress
 671
 672 =head2 SetReturnAddress is_comment => BOOLEAN
 673
 674 Calculate and set From and Reply-To headers based on the is_comment flag.
 675
 676 =cut
 677
 678 sub SetReturnAddress {
 679
 680     my $self = shift;
 681     my %args = (
 682         is_comment => 0,
 683         @_
 684     );
 685
 686     # From and Reply-To
 687     # $args{is_comment} should be set if the comment address is to be used.
 688     my $replyto;
 689
 690     if ( $args{'is_comment'} ) {
 691         $replyto = $self->TicketObj->QueueObj->CommentAddress
 692           || $RT::CommentAddress;
 693     }
 694     else {
 695         $replyto = $self->TicketObj->QueueObj->CorrespondAddress
 696           || $RT::CorrespondAddress;
 697     }
 698
 699     unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
 700         if ($RT::UseFriendlyFromLine) {
 701             my $friendly_name = $self->TransactionObj->CreatorObj->RealName
 702                 || $self->TransactionObj->CreatorObj->Name;
 703             if ( $friendly_name =~ /^"(.*)"$/ ) {    # a quoted string
 704                 $friendly_name = $1;
 705             }
 706
 707             $friendly_name =~ s/"/\\"/g;
 708             $self->SetHeader(
 709                 'From',
 710                 sprintf(
 711                     $RT::FriendlyFromLineFormat,
 712                     $self->MIMEEncodeString( $friendly_name,
 713                         $RT::EmailOutputEncoding ),
 714                     $replyto
 715                 ),
 716             );
 717         }
 718         else {
 719             $self->SetHeader( 'From', $replyto );
 720         }
 721     }
 722
 723     unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
 724         $self->SetHeader( 'Reply-To', "$replyto" );
 725     }
 726
 727 }
 728
 729 # }}}
 730
 731 # {{{ sub SetHeader
 732
 733 =head2 SetHeader FIELD, VALUE
 734
 735 Set the FIELD of the current MIME object into VALUE.
 736
 737 =cut
 738
 739 sub SetHeader {
 740     my $self  = shift;
 741     my $field = shift;
 742     my $val   = shift;
 743
 744     chomp $val;
 745     chomp $field;
 746     $self->TemplateObj->MIMEObj->head->fold_length( $field, 10000 );
 747     $self->TemplateObj->MIMEObj->head->replace( $field,     $val );
 748     return $self->TemplateObj->MIMEObj->head->get($field);
 749 }
 750
 751 # }}}
 752
 753
 754 # {{{ sub SetSubject
 755
 756 =head2 SetSubject
 757
 758 This routine sets the subject. it does not add the rt tag. that gets done elsewhere
 759 If $self->{'Subject'} is already defined, it uses that. otherwise, it tries to get
 760 the transaction's subject.
 761
 762 =cut
 763
 764 sub SetSubject {
 765     my $self = shift;
 766     my $subject;
 767
 768     my $message = $self->TransactionObj->Attachments;
 769     if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
 770         return ();
 771     }
 772     if ( $self->{'Subject'} ) {
 773         $subject = $self->{'Subject'};
 774     }
 775     elsif ( ( $message->First() ) && ( $message->First->Headers ) ) {
 776         my $header = $message->First->Headers();
 777         $header =~ s/\n\s+/ /g;
 778         if ( $header =~ /^Subject: (.*?)$/m ) {
 779             $subject = $1;
 780         }
 781         else {
 782             $subject = $self->TicketObj->Subject();
 783         }
 784
 785     }
 786     else {
 787         $subject = $self->TicketObj->Subject();
 788     }
 789
 790     $subject =~ s/(\r\n|\n|\s)/ /gi;
 791
 792     chomp $subject;
 793     $self->SetHeader( 'Subject', $subject );
 794
 795 }
 796
 797 # }}}
 798
 799 # {{{ sub SetSubjectToken
 800
 801 =head2 SetSubjectToken
 802
 803 This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this.
 804
 805 =cut
 806
 807 sub SetSubjectToken {
 808     my $self = shift;
 809     my $sub  = $self->TemplateObj->MIMEObj->head->get('Subject');
 810     my $id   = $self->TicketObj->id;
 811
 812     my $token_re = $RT::EmailSubjectTagRegex;
 813     $token_re = qr/\Q$RT::rtname\E/o unless $token_re;
 814     return if $sub =~ /\[$token_re\s+#$id\]/;
 815
 816     $sub =~ s/(\r\n|\n|\s)/ /gi;
 817     chomp $sub;
 818     $self->TemplateObj->MIMEObj->head->replace(
 819         Subject => "[$RT::rtname #$id] $sub",
 820     );
 821 }
 822
 823 # }}}
 824
 825 =head2 SetReferencesHeaders
 826
 827 Set References and In-Reply-To headers for this message.
 828
 829 =cut
 830
 831 sub SetReferencesHeaders {
 832
 833     my $self = shift;
 834     my ( @in_reply_to, @references, @msgid );
 835
 836     my $attachments = $self->TransactionObj->Message;
 837
 838     if ( my $top = $attachments->First() ) {
 839         @in_reply_to = split(/\s+/m, $top->GetHeader('In-Reply-To') || '');
 840         @references = split(/\s+/m, $top->GetHeader('References') || '' );
 841         @msgid = split(/\s+/m, $top->GetHeader('Message-ID') || '');
 842     }
 843     else {
 844         return (undef);
 845     }
 846
 847     # There are two main cases -- this transaction was created with
 848     # the RT Web UI, and hence we want to *not* append its Message-ID
 849     # to the References and In-Reply-To.  OR it came from an outside
 850     # source, and we should treat it as per the RFC
 851     if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@$RT::Organization>/) {
 852
 853       # Make all references which are internal be to version which we
 854       # have sent out
 855       for (@references, @in_reply_to) {
 856         s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@$RT::Organization>$/
 857           "<$1." . $self->TicketObj->id .
 858              "-" . $self->ScripObj->id .
 859              "-" . $self->ScripActionObj->{_Message_ID} .
 860              "@" . $RT::Organization . ">"/eg
 861       }
 862
 863       # In reply to whatever the internal message was in reply to
 864       $self->SetHeader( 'In-Reply-To', join( " ",  ( @in_reply_to )));
 865
 866       # Default the references to whatever we're in reply to
 867       @references = @in_reply_to unless @references;
 868
 869       # References are unchanged from internal
 870     } else {
 871       # In reply to that message
 872       $self->SetHeader( 'In-Reply-To', join( " ",  ( @msgid )));
 873
 874       # Default the references to whatever we're in reply to
 875       @references = @in_reply_to unless @references;
 876
 877       # Push that message onto the end of the references
 878       push @references, @msgid;
 879     }
 880
 881     # Push pseudo-ref to the front
 882     my $pseudo_ref = $self->PseudoReference;
 883     @references = ($pseudo_ref, grep { $_ ne $pseudo_ref } @references);
 884
 885     # If there are more than 10 references headers, remove all but the
 886     # first four and the last six (Gotta keep this from growing
 887     # forever)
 888     splice(@references, 4, -6) if ($#references >= 10);
 889
 890     # Add on the references
 891     $self->SetHeader( 'References', join( " ",   @references) );
 892     $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 );
 893
 894 }
 895
 896 # }}}
 897
 898 =head2 PseudoReference
 899
 900 Returns a fake Message-ID: header for the ticket to allow a base level of threading
 901
 902 =cut
 903
 904 sub PseudoReference {
 905
 906     my $self = shift;
 907     my $pseudo_ref =  '<RT-Ticket-'.$self->TicketObj->id .'@'.$RT::Organization .'>';
 908     return $pseudo_ref;
 909 }
 910
 911
 912 # {{{ SetHeadingAsEncoding
 913
 914 =head2 SetHeaderAsEncoding($field_name, $charset_encoding)
 915
 916 This routine converts the field into specified charset encoding.
 917
 918 =cut
 919
 920 sub SetHeaderAsEncoding {
 921     my $self = shift;
 922     my ( $field, $enc ) = ( shift, shift );
 923
 924     if ($field eq 'From' and $RT::SMTPFrom) {
 925         $self->TemplateObj->MIMEObj->head->replace( $field, $RT::SMTPFrom );
 926         return;
 927     }
 928
 929     my $value = $self->TemplateObj->MIMEObj->head->get($field);
 930
 931     $value =  $self->MIMEEncodeString($value, $enc);
 932
 933     $self->TemplateObj->MIMEObj->head->replace( $field, $value );
 934
 935
 936 }
 937 # }}}
 938
 939 # {{{ MIMEEncodeString
 940
 941 =head2 MIMEEncodeString STRING ENCODING
 942
 943 Takes a string and a possible encoding and returns the string wrapped in MIME goo.
 944
 945 =cut
 946
 947 sub MIMEEncodeString {
 948     my  $self = shift;
 949     my $value = shift;
 950     # using RFC2047 notation, sec 2.
 951     # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
 952     my $charset = shift;
 953     my $encoding = 'B';
 954     # An 'encoded-word' may not be more than 75 characters long
 955     #
 956     # MIME encoding increases 4/3*(number of bytes), and always in multiples
 957     # of 4. Thus we have to find the best available value of bytes available
 958     # for each chunk.
 959     #
 960     # First we get the integer max which max*4/3 would fit on space.
 961     # Then we find the greater multiple of 3 lower or equal than $max.
 962     my $max = int(((75-length('=?'.$charset.'?'.$encoding.'?'.'?='))*3)/4);
 963     $max = int($max/3)*3;
 964
 965     chomp $value;
 966
 967     if ( $max <= 0 ) {
 968       # gives an error...
 969       $RT::Logger->crit("Can't encode! Charset or encoding too big.\n");
 970       return ($value);
 971     }
 972
 973     return ($value) unless $value =~ /[^\x20-\x7e]/;
 974
 975     $value =~ s/\s*$//;
 976
 977     # we need perl string to split thing char by char
 978     Encode::_utf8_on($value) unless Encode::is_utf8( $value );
 979
 980     my ($tmp, @chunks) = ('', ());
 981     while ( length $value ) {
 982         my $char = substr($value, 0, 1, '');
 983         my $octets = Encode::encode( $charset, $char );
 984         if ( length($tmp) + length($octets) > $max ) {
 985             push @chunks, $tmp;
 986             $tmp = '';
 987         }
 988         $tmp .= $octets;
 989     }
 990     push @chunks, $tmp if length $tmp;
 991
 992     # encode an join chuncks
 993     $value = join "\n ",
 994                map encode_mimeword( $_, $encoding, $charset ), @chunks ;
 995     return($value);
 996 }
 997
 998 # }}}
 999
1000 eval "require RT::Action::SendEmail_Vendor";
1001 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Action/SendEmail_Vendor.pm});
1002 eval "require RT::Action::SendEmail_Local";
1003 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Action/SendEmail_Local.pm});
1004
1005 1;
1006