rt/lib/RT/Action/SendEmail.pm

   1 # BEGIN LICENSE BLOCK
   2 #
   3 # Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
   4 #
   5 # (Except where explictly superceded by other copyright notices)
   6 #
   7 # This work is made available to you under the terms of Version 2 of
   8 # the GNU General Public License. A copy of that license should have
   9 # been provided with this software, but in any event can be snarfed
  10 # from www.gnu.org.
  11 #
  12 # This work is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # Unless otherwise specified, all modifications, corrections or
  18 # extensions to this work which alter its source code become the
  19 # property of Best Practical Solutions, LLC when submitted for
  20 # inclusion in the work.
  21 #
  22 #
  23 # END LICENSE BLOCK
  24 # Portions Copyright 2000 Tobias Brox <tobix@cpan.org>
  25
  26 package RT::Action::SendEmail;
  27 require RT::Action::Generic;
  28
  29 use strict;
  30 use vars qw/@ISA/;
  31 @ISA = qw(RT::Action::Generic);
  32
  33 use MIME::Words qw(encode_mimeword);
  34
  35 use RT::EmailParser;
  36
  37 =head1 NAME
  38
  39 RT::Action::SendEmail - An Action which users can use to send mail
  40 or can subclassed for more specialized mail sending behavior.
  41 RT::Action::AutoReply is a good example subclass.
  42
  43 =head1 SYNOPSIS
  44
  45   require RT::Action::SendEmail;
  46   @ISA  = qw(RT::Action::SendEmail);
  47
  48
  49 =head1 DESCRIPTION
  50
  51 Basically, you create another module RT::Action::YourAction which ISA
  52 RT::Action::SendEmail.
  53
  54 If you want to set the recipients of the mail to something other than
  55 the addresses mentioned in the To, Cc, Bcc and headers in
  56 the template, you should subclass RT::Action::SendEmail and override
  57 either the SetRecipients method or the SetTo, SetCc, etc methods (see
  58 the comments for the SetRecipients sub).
  59
  60
  61 =begin testing
  62
  63 ok (require RT::Action::SendEmail);
  64
  65 =end testing
  66
  67
  68 =head1 AUTHOR
  69
  70 Jesse Vincent <jesse@bestpractical.com> and Tobias Brox <tobix@cpan.org>
  71
  72 =head1 SEE ALSO
  73
  74 perl(1).
  75
  76 =cut
  77
  78 # {{{ Scrip methods (_Init, Commit, Prepare, IsApplicable)
  79
  80 # {{{ sub _Init
  81 # We use _Init from RT::Action
  82 # }}}
  83
  84 # {{{ sub Commit
  85 #Do what we need to do and send it out.
  86 sub Commit {
  87     my $self = shift;
  88
  89     my $MIMEObj = $self->TemplateObj->MIMEObj;
  90     my $msgid = $MIMEObj->head->get('Message-Id');
  91     chomp $msgid;
  92     $RT::Logger->info($msgid." #".$self->TicketObj->id."/".$self->TransactionObj->id." - Scrip ". $self->ScripObj->id ." ".$self->ScripObj->Description);
  93     #send the email
  94
  95         # Weed out any RT addresses. We really don't want to talk to ourselves!
  96         @{$self->{'To'}} = RT::EmailParser::CullRTAddresses("", @{$self->{'To'}});
  97         @{$self->{'Cc'}} = RT::EmailParser::CullRTAddresses("", @{$self->{'Cc'}});
  98         @{$self->{'Bcc'}} = RT::EmailParser::CullRTAddresses("", @{$self->{'Bcc'}});
  99     # If there are no recipients, don't try to send the message.
 100     # If the transaction has content and has the header RT-Squelch-Replies-To
 101
 102     if ( defined $self->TransactionObj->Attachments->First() ) {
 103
 104         my $squelch = $self->TransactionObj->Attachments->First->GetHeader( 'RT-Squelch-Replies-To');
 105
 106         if ($squelch) {
 107             my @blacklist = split ( /,/, $squelch );
 108
 109             # Cycle through the people we're sending to and pull out anyone on the
 110             # system blacklist
 111
 112             foreach my $person_to_yank (@blacklist) {
 113                 $person_to_yank =~ s/\s//g;
 114                 @{ $self->{'To'} } =
 115                   grep ( !/^$person_to_yank$/, @{ $self->{'To'} } );
 116                 @{ $self->{'Cc'} } =
 117                   grep ( !/^$person_to_yank$/, @{ $self->{'Cc'} } );
 118                 @{ $self->{'Bcc'} } =
 119                   grep ( !/^$person_to_yank$/, @{ $self->{'Bcc'} } );
 120             }
 121         }
 122     }
 123
 124     # Go add all the Tos, Ccs and Bccs that we need to to the message to
 125     # make it happy, but only if we actually have values in those arrays.
 126
 127     $self->SetHeader( 'To', join ( ',', @{ $self->{'To'} } ) )
 128       if ( $self->{'To'} && @{ $self->{'To'} } );
 129     $self->SetHeader( 'Cc', join ( ',', @{ $self->{'Cc'} } ) )
 130       if ( $self->{'Cc'} && @{ $self->{'Cc'} } );
 131     $self->SetHeader( 'Bcc', join ( ',', @{ $self->{'Bcc'} } ) )
 132       if ( $self->{'Bcc'} && @{ $self->{'Bcc'} } );
 133
 134
 135     $self->SetHeader('MIME-Version', '1.0');
 136
 137     # try to convert message body from utf-8 to $RT::EmailOutputEncoding
 138     $self->SetHeader( 'Content-Type', 'text/plain; charset="utf-8"' );
 139
 140     RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, $RT::EmailOutputEncoding, 'mime_words_ok' );
 141     $self->SetHeader( 'Content-Type', 'text/plain; charset="' . $RT::EmailOutputEncoding . '"' );
 142
 143
 144     # Build up a MIME::Entity that looks like the original message.
 145
 146     my $do_attach = $self->TemplateObj->MIMEObj->head->get('RT-Attach-Message');
 147
 148     if ($do_attach) {
 149         $self->TemplateObj->MIMEObj->head->delete('RT-Attach-Message');
 150
 151         my $attachments = RT::Attachments->new($RT::SystemUser);
 152         $attachments->Limit( FIELD => 'TransactionId',
 153                              VALUE => $self->TransactionObj->Id );
 154         $attachments->OrderBy('id');
 155
 156         my $transaction_content_obj = $self->TransactionObj->ContentObj;
 157
 158         # attach any of this transaction's attachments
 159         while ( my $attach = $attachments->Next ) {
 160
 161             # Don't attach anything blank
 162             next unless ( $attach->ContentLength );
 163
 164             # We want to make sure that we don't include the attachment that's being sued as the "Content" of this message"
 165             next
 166               if (    $transaction_content_obj
 167                    && $transaction_content_obj->Id == $attach->Id
 168                    && $transaction_content_obj->ContentType =~ qr{text/plain}i
 169                 );
 170             $MIMEObj->make_multipart('mixed');
 171             $MIMEObj->attach( Type => $attach->ContentType,
 172                               Charset => $attach->OriginalEncoding,
 173                               Data => $attach->OriginalContent,
 174                               Filename => $self->MIMEEncodeString( $attach->Filename, $RT::EmailOutputEncoding ),
 175                               Encoding    => '-SUGGEST');
 176         }
 177
 178     }
 179
 180
 181     my $retval = $self->SendMessage($MIMEObj);
 182
 183
 184     return ($retval);
 185 }
 186
 187 # }}}
 188
 189 # {{{ sub Prepare
 190
 191 sub Prepare {
 192     my $self = shift;
 193
 194     # This actually populates the MIME::Entity fields in the Template Object
 195
 196     unless ( $self->TemplateObj ) {
 197         $RT::Logger->warning("No template object handed to $self\n");
 198     }
 199
 200     unless ( $self->TransactionObj ) {
 201         $RT::Logger->warning("No transaction object handed to $self\n");
 202
 203     }
 204
 205     unless ( $self->TicketObj ) {
 206         $RT::Logger->warning("No ticket object handed to $self\n");
 207
 208     }
 209
 210     my ( $result, $message ) = $self->TemplateObj->Parse(
 211                                          Argument       => $self->Argument,
 212                                          TicketObj      => $self->TicketObj,
 213                                          TransactionObj => $self->TransactionObj
 214     );
 215     if ($result) {
 216
 217         # Header
 218         $self->SetSubject();
 219         $self->SetSubjectToken();
 220         $self->SetRecipients();
 221         $self->SetReturnAddress();
 222         $self->SetRTSpecialHeaders();
 223         if ($RT::EmailOutputEncoding) {
 224
 225             # l10n related header
 226             $self->SetHeaderAsEncoding( 'Subject', $RT::EmailOutputEncoding );
 227         }
 228     }
 229
 230     return $result;
 231
 232 }
 233
 234 # }}}
 235
 236 # }}}
 237
 238 # {{{ SendMessage
 239 =head2 SendMessage MIMEObj
 240
 241 sends the message using RT's preferred API.
 242 TODO: Break this out to a separate module
 243
 244 =cut
 245
 246 sub SendMessage {
 247     my $self = shift;
 248     my $MIMEObj = shift;
 249
 250     my $msgid = $MIMEObj->head->get('Message-Id');
 251
 252
 253     #If we don't have any recipients to send to, don't send a message;
 254     unless (    $MIMEObj->head->get('To')
 255              || $MIMEObj->head->get('Cc')
 256              || $MIMEObj->head->get('Bcc') ) {
 257         $RT::Logger->info($msgid.  " No recipients found. Not sending.\n");
 258         return (1);
 259     }
 260
 261     # PseudoTo  (fake to headers) shouldn't get matched for message recipients.
 262     # If we don't have any 'To' header, drop in the pseudo-to header.
 263
 264     $self->SetHeader( 'To', join ( ',', @{ $self->{'PseudoTo'} } ) )
 265       if ( $self->{'PseudoTo'} && ( @{ $self->{'PseudoTo'} } )
 266            and ( !$MIMEObj->head->get('To') ) );
 267     if ( $RT::MailCommand eq 'sendmailpipe' ) {
 268         eval {
 269             open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) || die $!;
 270             print MAIL $MIMEObj->as_string;
 271             close(MAIL);
 272           };
 273           if ($@) {
 274             $RT::Logger->crit($msgid.  "Could not send mail. -".$@ );
 275         }
 276     }
 277     else {
 278         my @mailer_args = ($RT::MailCommand);
 279         local $ENV{MAILADDRESS};
 280
 281         if ( $RT::MailCommand eq 'sendmail' ) {
 282             push @mailer_args, split(/\s+/, $RT::SendmailArguments);
 283         }
 284         elsif ( $RT::MailCommand eq 'smtp' ) {
 285             $ENV{MAILADDRESS} = $RT::SMTPFrom || $MIMEObj->head->get('From');
 286             push @mailer_args, (Server => $RT::SMTPServer);
 287             push @mailer_args, (Debug => $RT::SMTPDebug);
 288         }
 289         else {
 290             push @mailer_args, $RT::MailParams;
 291         }
 292
 293         unless ( $MIMEObj->send( @mailer_args ) ) {
 294             $RT::Logger->crit($msgid.  "Could not send mail." );
 295             return (0);
 296         }
 297     }
 298
 299
 300      my $success = ($msgid. " sent To: ".$MIMEObj->head->get('To') . " Cc: ".$MIMEObj->head->get('Cc') . " Bcc: ".$MIMEObj->head->get('Bcc'));
 301     $success =~ s/\n//gi;
 302     $RT::Logger->info($success);
 303
 304     return (1);
 305 }
 306
 307 # }}}
 308
 309 # {{{ Deal with message headers (Set* subs, designed for  easy overriding)
 310
 311 # {{{ sub SetRTSpecialHeaders
 312
 313 =head2 SetRTSpecialHeaders
 314
 315 This routine adds all the random headers that RT wants in a mail message
 316 that don't matter much to anybody else.
 317
 318 =cut
 319
 320 sub SetRTSpecialHeaders {
 321     my $self = shift;
 322
 323     $self->SetReferences();
 324
 325     $self->SetMessageID();
 326
 327     $self->SetPrecedence();
 328
 329     $self->SetHeader( 'X-RT-Loop-Prevention', $RT::rtname );
 330     $self->SetHeader( 'RT-Ticket',
 331                       $RT::rtname . " #" . $self->TicketObj->id() );
 332     $self->SetHeader( 'Managed-by',
 333                       "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
 334
 335     $self->SetHeader( 'RT-Originator',
 336                       $self->TransactionObj->CreatorObj->EmailAddress );
 337     return ();
 338
 339 }
 340
 341 # {{{ sub SetReferences
 342
 343 =head2 SetReferences
 344
 345   # This routine will set the References: and In-Reply-To headers,
 346 # autopopulating it with all the correspondence on this ticket so
 347 # far. This should make RT responses threadable.
 348
 349 =cut
 350
 351 sub SetReferences {
 352     my $self = shift;
 353
 354     # TODO: this one is broken.  What is this email really a reply to?
 355     # If it's a reply to an incoming message, we'll need to use the
 356     # actual message-id from the appropriate Attachment object.  For
 357     # incoming mails, we would like to preserve the In-Reply-To and/or
 358     # References.
 359
 360     $self->SetHeader( 'In-Reply-To',
 361                    "<rt-" . $self->TicketObj->id() . "\@" . $RT::rtname . ">" );
 362
 363     # TODO We should always add References headers for all message-ids
 364     # of previous messages related to this ticket.
 365 }
 366
 367 # }}}
 368
 369 # {{{ sub SetMessageID
 370
 371 =head2 SetMessageID
 372
 373 Without this one, threading won't work very nice in email agents.
 374 Anyway, I'm not really sure it's that healthy if we need to send
 375 several separate/different emails about the same transaction.
 376
 377 =cut
 378
 379 sub SetMessageID {
 380     my $self = shift;
 381
 382     # TODO this one might be sort of broken.  If we have several scrips +++
 383     # sending several emails to several different persons, we need to
 384     # pull out different message-ids.  I'd suggest message ids like
 385     # "rt-ticket#-transaction#-scrip#-receipient#"
 386
 387     $self->SetHeader( 'Message-ID',
 388                       "<rt-"
 389                         . $RT::VERSION ."-"
 390                         . $self->TicketObj->id() . "-"
 391                         . $self->TransactionObj->id() . "."
 392                         . rand(20) . "\@"
 393                         . $RT::Organization . ">" )
 394       unless $self->TemplateObj->MIMEObj->head->get('Message-ID');
 395 }
 396
 397 # }}}
 398
 399 # }}}
 400
 401 # {{{ sub SetReturnAddress
 402
 403 =head2 SetReturnAddress is_comment => BOOLEAN
 404
 405 Calculate and set From and Reply-To headers based on the is_comment flag.
 406
 407 =cut
 408
 409 sub SetReturnAddress {
 410
 411     my $self = shift;
 412     my %args = ( is_comment => 0,
 413                  @_ );
 414
 415     # From and Reply-To
 416     # $args{is_comment} should be set if the comment address is to be used.
 417     my $replyto;
 418
 419     if ( $args{'is_comment'} ) {
 420         $replyto = $self->TicketObj->QueueObj->CommentAddress
 421           || $RT::CommentAddress;
 422     }
 423     else {
 424         $replyto = $self->TicketObj->QueueObj->CorrespondAddress
 425           || $RT::CorrespondAddress;
 426     }
 427
 428     unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
 429         if ($RT::UseFriendlyFromLine) {
 430             my $friendly_name = $self->TransactionObj->CreatorObj->RealName;
 431             if ( $friendly_name =~ /^"(.*)"$/ ) {    # a quoted string
 432                 $friendly_name = $1;
 433             }
 434
 435             $friendly_name =~ s/"/\\"/g;
 436             $self->SetHeader( 'From',
 437                         sprintf($RT::FriendlyFromLineFormat,
 438                 $self->MIMEEncodeString( $friendly_name, $RT::EmailOutputEncoding ), $replyto),
 439             );
 440         }
 441         else {
 442             $self->SetHeader( 'From', $replyto );
 443         }
 444     }
 445
 446     unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
 447         $self->SetHeader( 'Reply-To', "$replyto" );
 448     }
 449
 450 }
 451
 452 # }}}
 453
 454 # {{{ sub SetHeader
 455
 456 =head2 SetHeader FIELD, VALUE
 457
 458 Set the FIELD of the current MIME object into VALUE.
 459
 460 =cut
 461
 462 sub SetHeader {
 463     my $self  = shift;
 464     my $field = shift;
 465     my $val   = shift;
 466
 467     chomp $val;
 468     chomp $field;
 469     $self->TemplateObj->MIMEObj->head->fold_length( $field, 10000 );
 470     $self->TemplateObj->MIMEObj->head->replace( $field,     $val );
 471     return $self->TemplateObj->MIMEObj->head->get($field);
 472 }
 473
 474 # }}}
 475
 476 # {{{ sub SetRecipients
 477
 478 =head2 SetRecipients
 479
 480 Dummy method to be overriden by subclasses which want to set the recipients.
 481
 482 =cut
 483
 484 sub SetRecipients {
 485     my $self = shift;
 486     return ();
 487 }
 488
 489 # }}}
 490
 491 # {{{ sub SetTo
 492
 493 =head2 SetTo
 494
 495 Takes a string that is the addresses you want to send mail to
 496
 497 =cut
 498
 499 sub SetTo {
 500     my $self      = shift;
 501     my $addresses = shift;
 502     return $self->SetHeader( 'To', $addresses );
 503 }
 504
 505 # }}}
 506
 507 # {{{ sub SetCc
 508
 509 =head2 SetCc
 510
 511 Takes a string that is the addresses you want to Cc
 512
 513 =cut
 514
 515 sub SetCc {
 516     my $self      = shift;
 517     my $addresses = shift;
 518
 519     return $self->SetHeader( 'Cc', $addresses );
 520 }
 521
 522 # }}}
 523
 524 # {{{ sub SetBcc
 525
 526 =head2 SetBcc
 527
 528 Takes a string that is the addresses you want to Bcc
 529
 530 =cut
 531
 532 sub SetBcc {
 533     my $self      = shift;
 534     my $addresses = shift;
 535
 536     return $self->SetHeader( 'Bcc', $addresses );
 537 }
 538
 539 # }}}
 540
 541 # {{{ sub SetPrecedence
 542
 543 sub SetPrecedence {
 544     my $self = shift;
 545
 546     unless ( $self->TemplateObj->MIMEObj->head->get("Precedence") ) {
 547         $self->SetHeader( 'Precedence', "bulk" );
 548     }
 549 }
 550
 551 # }}}
 552
 553 # {{{ sub SetSubject
 554
 555 =head2 SetSubject
 556
 557 This routine sets the subject. it does not add the rt tag. that gets done elsewhere
 558 If $self->{'Subject'} is already defined, it uses that. otherwise, it tries to get
 559 the transaction's subject.
 560
 561 =cut
 562
 563 sub SetSubject {
 564     my $self = shift;
 565     my $subject;
 566
 567     unless ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
 568         my $message = $self->TransactionObj->Attachments;
 569         my $ticket  = $self->TicketObj->Id;
 570
 571         if ( $self->{'Subject'} ) {
 572             $subject = $self->{'Subject'};
 573         }
 574         elsif (    ( $message->First() )
 575                 && ( $message->First->Headers ) ) {
 576             my $header = $message->First->Headers();
 577             $header =~ s/\n\s+/ /g;
 578             if ( $header =~ /^Subject: (.*?)$/m ) {
 579                 $subject = $1;
 580             }
 581             else {
 582                 $subject = $self->TicketObj->Subject();
 583             }
 584
 585         }
 586         else {
 587             $subject = $self->TicketObj->Subject();
 588         }
 589
 590         $subject =~ s/(\r\n|\n|\s)/ /gi;
 591
 592         chomp $subject;
 593         $self->SetHeader( 'Subject', $subject );
 594
 595     }
 596     return ($subject);
 597 }
 598
 599 # }}}
 600
 601 # {{{ sub SetSubjectToken
 602
 603 =head2 SetSubjectToken
 604
 605 This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this.
 606
 607 =cut
 608
 609 sub SetSubjectToken {
 610     my $self = shift;
 611     my $tag  = "[$RT::rtname #" . $self->TicketObj->id . "]";
 612     my $sub  = $self->TemplateObj->MIMEObj->head->get('Subject');
 613     unless ( $sub =~ /\Q$tag\E/ ) {
 614         $sub =~ s/(\r\n|\n|\s)/ /gi;
 615         chomp $sub;
 616         $self->TemplateObj->MIMEObj->head->replace( 'Subject', "$tag $sub" );
 617     }
 618 }
 619
 620 # }}}
 621
 622 # }}}
 623
 624 # {{{
 625
 626 =head2 SetHeaderAsEncoding($field_name, $charset_encoding)
 627
 628 This routine converts the field into specified charset encoding.
 629
 630 =cut
 631
 632 sub SetHeaderAsEncoding {
 633     my $self = shift;
 634     my ( $field, $enc ) = ( shift, shift );
 635
 636     if ($field eq 'From' and $RT::SMTPFrom) {
 637         $self->TemplateObj->MIMEObj->head->replace( $field, $RT::SMTPFrom );
 638         return;
 639     }
 640
 641     my $value = $self->TemplateObj->MIMEObj->head->get($field);
 642
 643     # don't bother if it's us-ascii
 644
 645     # See RT::I18N, 'NOTES:  Why Encode::_utf8_off before Encode::from_to'
 646
 647     $value =  $self->MIMEEncodeString($value, $enc);
 648
 649     $self->TemplateObj->MIMEObj->head->replace( $field, $value );
 650
 651
 652 }
 653 # }}}
 654
 655 # {{{ MIMENcodeString
 656
 657 =head2 MIMEEncodeString STRING ENCODING
 658
 659 Takes a string and a possible encoding and returns the string wrapped in MIME goo.
 660
 661 =cut
 662
 663 sub MIMEEncodeString {
 664     my  $self = shift;
 665     my $value = shift;
 666     # using RFC2047 notation, sec 2.
 667     # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
 668     my $charset = shift;
 669     my $encoding = 'B';
 670     # An 'encoded-word' may not be more than 75 characters long
 671     #
 672     # MIME encoding increases 4/3*(number of bytes), and always in multiples
 673     # of 4. Thus we have to find the best available value of bytes available
 674     # for each chunk.
 675     #
 676     # First we get the integer max which max*4/3 would fit on space.
 677     # Then we find the greater multiple of 3 lower or equal than $max.
 678     my $max = int(((75-length('=?'.$charset.'?'.$encoding.'?'.'?='))*3)/4);
 679     $max = int($max/3)*3;
 680
 681     chomp $value;
 682     return ($value) unless $value =~ /[^\x20-\x7e]/;
 683
 684     $value =~ s/\s*$//;
 685     Encode::_utf8_off($value);
 686     my $res = Encode::from_to( $value, "utf-8", $charset );
 687
 688     if ($max > 0) {
 689       # copy value and split in chuncks
 690       my $str=$value;
 691       my @chunks = unpack("a$max" x int(length($str)/$max
 692                                   + ((length($str) % $max) ? 1:0)), $str);
 693       # encode an join chuncks
 694       $value = join " ",
 695                      map encode_mimeword( $_, $encoding, $charset ), @chunks ;
 696       return($value);
 697     } else {
 698       # gives an error...
 699       $RT::Logger->crit("Can't encode! Charset or encoding too big.\n");
 700     }
 701 }
 702
 703 # }}}
 704
 705 eval "require RT::Action::SendEmail_Vendor";
 706 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Action/SendEmail_Vendor.pm});
 707 eval "require RT::Action::SendEmail_Local";
 708 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Action/SendEmail_Local.pm});
 709
 710 1;
 711