rt/lib/RT/Action/SendEmail.pm

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