+If Charset is not provided then $EmailOutputEncoding config option
+is used, or "latin-1" if that is not set.
+
+=cut
+
+sub EncodeToMIME {
+ my %args = (
+ String => undef,
+ Charset => undef,
+ @_
+ );
+ my $value = $args{'String'};
+ return $value unless $value; # 0 is perfect ascii
+ my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
+ my $encoding = 'B';
+
+ # using RFC2047 notation, sec 2.
+ # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
+
+ # An 'encoded-word' may not be more than 75 characters long
+ #
+ # MIME encoding increases 4/3*(number of bytes), and always in multiples
+ # of 4. Thus we have to find the best available value of bytes available
+ # for each chunk.
+ #
+ # First we get the integer max which max*4/3 would fit on space.
+ # Then we find the greater multiple of 3 lower or equal than $max.
+ my $max = int(
+ ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
+ * 3
+ ) / 4
+ );
+ $max = int( $max / 3 ) * 3;
+
+ chomp $value;
+
+ if ( $max <= 0 ) {
+
+ # gives an error...
+ $RT::Logger->crit("Can't encode! Charset or encoding too big.");
+ return ($value);
+ }
+
+ return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s;
+
+ $value =~ s/\s+$//;
+
+ my ( $tmp, @chunks ) = ( '', () );
+ while ( length $value ) {
+ my $char = substr( $value, 0, 1, '' );
+ my $octets = Encode::encode( $charset, $char );
+ if ( length($tmp) + length($octets) > $max ) {
+ push @chunks, $tmp;
+ $tmp = '';
+ }
+ $tmp .= $octets;
+ }
+ push @chunks, $tmp if length $tmp;
+
+ # encode an join chuncks
+ $value = join "\n ",
+ map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
+ @chunks;
+ return ($value);
+}
+
+sub CreateUser {
+ my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
+
+ my $NewUser = RT::User->new( RT->SystemUser );
+
+ my ( $Val, $Message ) = $NewUser->Create(
+ Name => ( $Username || $Address ),
+ EmailAddress => $Address,
+ RealName => $Name,
+ Password => undef,
+ Privileged => 0,
+ Comments => 'Autocreated on ticket submission',
+ );
+
+ unless ($Val) {
+
+ # Deal with the race condition of two account creations at once
+ if ($Username) {
+ $NewUser->LoadByName($Username);
+ }
+
+ unless ( $NewUser->Id ) {
+ $NewUser->LoadByEmail($Address);
+ }
+
+ unless ( $NewUser->Id ) {
+ MailError(
+ To => $ErrorsTo,
+ Subject => "User could not be created",
+ Explanation =>
+ "User creation failed in mailgateway: $Message",
+ MIMEObj => $entity,
+ LogLevel => 'crit',
+ );
+ }
+ }
+
+ #Load the new user object
+ my $CurrentUser = RT::CurrentUser->new;
+ $CurrentUser->LoadByEmail( $Address );
+
+ unless ( $CurrentUser->id ) {
+ $RT::Logger->warning(
+ "Couldn't load user '$Address'." . "giving up" );
+ MailError(
+ To => $ErrorsTo,
+ Subject => "User could not be loaded",
+ Explanation =>
+ "User '$Address' could not be loaded in the mail gateway",
+ MIMEObj => $entity,
+ LogLevel => 'crit'
+ );
+ }
+
+ return $CurrentUser;
+}
+
+
+
+=head2 ParseCcAddressesFromHead HASH
+
+Takes a hash containing QueueObj, Head and CurrentUser objects.
+Returns a list of all email addresses in the To and Cc
+headers b<except> the current Queue's email addresses, the CurrentUser's
+email address and anything that the configuration sub RT::IsRTAddress matches.
+
+=cut
+
+sub ParseCcAddressesFromHead {
+ my %args = (
+ Head => undef,
+ QueueObj => undef,
+ CurrentUser => undef,
+ @_
+ );
+
+ my $current_address = lc $args{'CurrentUser'}->EmailAddress;
+ my $user = $args{'CurrentUser'}->UserObj;
+
+ return
+ grep { $_ ne $current_address
+ && !RT::EmailParser->IsRTAddress( $_ )
+ && !IgnoreCcAddress( $_ )
+ }
+ map lc $user->CanonicalizeEmailAddress( $_->address ),
+ map RT::EmailParser->CleanupAddresses( Email::Address->parse(
+ Encode::decode( "UTF-8", $args{'Head'}->get( $_ ) ) ) ),
+ qw(To Cc);
+}
+
+=head2 IgnoreCcAddress ADDRESS
+
+Returns true if ADDRESS matches the $IgnoreCcRegexp config variable.
+
+=cut
+
+sub IgnoreCcAddress {
+ my $address = shift;
+ if ( my $address_re = RT->Config->Get('IgnoreCcRegexp') ) {
+ return 1 if $address =~ /$address_re/i;
+ }
+ return undef;
+}
+
+=head2 ParseSenderAddressFromHead HEAD
+
+Takes a MIME::Header object. Returns (user@host, friendly name, errors)
+where the first two values are the From (evaluated in order of
+Reply-To:, From:, Sender).
+
+A list of error messages may be returned even when a Sender value is
+found, since it could be a parse error for another (checked earlier)
+sender field. In this case, the errors aren't fatal, but may be useful
+to investigate the parse failure.
+
+=cut
+
+sub ParseSenderAddressFromHead {
+ my $head = shift;
+ my @sender_headers = ('Reply-To', 'From', 'Sender');
+ my @errors; # Accumulate any errors
+
+ #Figure out who's sending this message.
+ foreach my $header ( @sender_headers ) {
+ my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next;
+ my ($addr, $name) = ParseAddressFromHeader( $addr_line );
+ # only return if the address is not empty
+ return ($addr, $name, @errors) if $addr;
+
+ chomp $addr_line;
+ push @errors, "$header: $addr_line";
+ }
+
+ return (undef, undef, @errors);
+}
+
+=head2 ParseErrorsToAddressFromHead HEAD
+
+Takes a MIME::Header object. Return a single value : user@host
+of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
+From:, Sender)
+
+=cut
+
+sub ParseErrorsToAddressFromHead {
+ my $head = shift;
+
+ #Figure out who's sending this message.
+
+ foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
+
+ # If there's a header of that name
+ my $headerobj = Encode::decode( "UTF-8", $head->get($header) );
+ if ($headerobj) {
+ my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
+
+ # If it's got actual useful content...
+ return ($addr) if ($addr);
+ }
+ }
+}
+
+
+
+=head2 ParseAddressFromHeader ADDRESS
+
+Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
+
+=cut
+
+sub ParseAddressFromHeader {
+ my $Addr = shift;
+
+ # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
+ $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
+ my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
+
+ my ($AddrObj) = grep ref $_, @Addresses;
+ unless ( $AddrObj ) {
+ return ( undef, undef );
+ }
+
+ return ( $AddrObj->address, $AddrObj->phrase );
+}
+
+=head2 DeleteRecipientsFromHead HEAD RECIPIENTS
+
+Gets a head object and list of addresses.
+Deletes addresses from To, Cc or Bcc fields.
+
+=cut
+
+sub DeleteRecipientsFromHead {
+ my $head = shift;
+ my %skip = map { lc $_ => 1 } @_;
+
+ foreach my $field ( qw(To Cc Bcc) ) {
+ $head->replace( $field => Encode::encode( "UTF-8",
+ join ', ', map $_->format, grep !$skip{ lc $_->address },
+ Email::Address->parse( Encode::decode( "UTF-8", $head->get( $field ) ) ) )
+ );
+ }
+}
+
+sub GenMessageId {
+ my %args = (
+ Ticket => undef,
+ Scrip => undef,
+ ScripAction => undef,
+ @_
+ );
+ my $org = RT->Config->Get('Organization');
+ my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
+ my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
+ my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
+
+ return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
+ . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
+}
+
+sub SetInReplyTo {
+ my %args = (
+ Message => undef,
+ InReplyTo => undef,
+ Ticket => undef,
+ @_
+ );
+ return unless $args{'Message'} && $args{'InReplyTo'};
+
+ my $get_header = sub {
+ my @res;
+ if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
+ @res = map {Encode::decode("UTF-8", $_)} $args{'InReplyTo'}->head->get( shift );
+ } else {
+ @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
+ }
+ return grep length, map { split /\s+/m, $_ } grep defined, @res;
+ };
+
+ my @id = $get_header->('Message-ID');
+ #XXX: custom header should begin with X- otherwise is violation of the standard
+ my @rtid = $get_header->('RT-Message-ID');
+ my @references = $get_header->('References');
+ unless ( @references ) {
+ @references = $get_header->('In-Reply-To');
+ }
+ push @references, @id, @rtid;
+ if ( $args{'Ticket'} ) {
+ my $pseudo_ref = PseudoReference( $args{'Ticket'} );
+ push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
+ }
+ splice @references, 4, -6
+ if @references > 10;
+
+ my $mail = $args{'Message'};
+ $mail->head->replace( 'In-Reply-To' => Encode::encode( "UTF-8", join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
+ $mail->head->replace( 'References' => Encode::encode( "UTF-8", join ' ', @references) );
+}
+
+sub PseudoReference {
+ my $ticket = shift;
+ return '<RT-Ticket-'. $ticket->id .'@'. RT->Config->Get('Organization') .'>';
+}
+
+=head2 ExtractTicketId
+
+Passed a MIME::Entity. Returns a ticket id or undef to signal 'new ticket'.
+
+This is a great entry point if you need to customize how ticket ids are
+handled for your site. RT-Extension-RepliesToResolved demonstrates one
+possible use for this extension.
+
+If the Subject of this ticket is modified, it will be reloaded by the
+mail gateway code before Ticket creation.
+
+=cut
+
+sub ExtractTicketId {
+ my $entity = shift;
+
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') || '' );
+ chomp $subject;
+ return ParseTicketId( $subject );
+}
+
+=head2 ParseTicketId
+
+Takes a string and searches for [subjecttag #id]
+
+Returns the id if a match is found. Otherwise returns undef.
+
+=cut
+
+sub ParseTicketId {
+ my $Subject = shift;
+
+ my $rtname = RT->Config->Get('rtname');
+ my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
+
+ # We use @captures and pull out the last capture value to guard against
+ # someone using (...) instead of (?:...) in $EmailSubjectTagRegex.
+ my $id;
+ if ( my @captures = $Subject =~ /\[$test_name\s+\#(\d+)\s*\]/i ) {
+ $id = $captures[-1];
+ } else {
+ foreach my $tag ( RT->System->SubjectTag ) {
+ next unless my @captures = $Subject =~ /\[\Q$tag\E\s+\#(\d+)\s*\]/i;
+ $id = $captures[-1];
+ last;
+ }
+ }
+ return undef unless $id;
+
+ $RT::Logger->debug("Found a ticket ID. It's $id");
+ return $id;
+}
+
+sub AddSubjectTag {
+ my $subject = shift;
+ my $ticket = shift;
+ unless ( ref $ticket ) {
+ my $tmp = RT::Ticket->new( RT->SystemUser );
+ $tmp->Load( $ticket );
+ $ticket = $tmp;
+ }
+ my $id = $ticket->id;
+ my $queue_tag = $ticket->QueueObj->SubjectTag;
+
+ my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
+ unless ( $tag_re ) {
+ my $tag = $queue_tag || RT->Config->Get('rtname');
+ $tag_re = qr/\Q$tag\E/;
+ } elsif ( $queue_tag ) {
+ $tag_re = qr/$tag_re|\Q$queue_tag\E/;
+ }
+ return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
+
+ $subject =~ s/(\r\n|\n|\s)/ /g;
+ chomp $subject;
+ return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
+}
+
+
+=head2 Gateway ARGSREF
+
+
+Takes parameters:
+
+ action
+ queue
+ message
+
+
+This performs all the "guts" of the mail rt-mailgate program, and is
+designed to be called from the web interface with a message, user
+object, and so on.
+
+Can also take an optional 'ticket' parameter; this ticket id overrides
+any ticket id found in the subject.
+
+Returns:
+
+ An array of:
+
+ (status code, message, optional ticket object)
+
+ status code is a numeric value.
+
+ for temporary failures, the status code should be -75
+
+ for permanent failures which are handled by RT, the status code
+ should be 0
+
+ for succces, the status code should be 1
+
+
+
+=cut
+
+sub _LoadPlugins {
+ my @mail_plugins = @_;
+
+ my @res;
+ foreach my $plugin (@mail_plugins) {
+ if ( ref($plugin) eq "CODE" ) {
+ push @res, $plugin;
+ } elsif ( !ref $plugin ) {
+ my $Class = $plugin;
+ $Class = "RT::Interface::Email::" . $Class
+ unless $Class =~ /^RT::/;
+ $Class->require or
+ do { $RT::Logger->error("Couldn't load $Class: $@"); next };
+
+ no strict 'refs';
+ unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
+ $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
+ next;
+ }
+ push @res, $Class;
+ } else {
+ $RT::Logger->crit( "$plugin - is not class name or code reference");
+ }
+ }
+ return @res;
+}
+
+sub Gateway {
+ my $argsref = shift;
+ my %args = (
+ action => 'correspond',
+ queue => '1',
+ ticket => undef,
+ message => undef,
+ %$argsref
+ );
+
+ my $SystemTicket;
+ my $Right;
+
+ # Validate the action
+ my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
+ unless ($status) {
+ return (
+ -75,
+ "Invalid 'action' parameter "
+ . $actions[0]
+ . " for queue "
+ . $args{'queue'},
+ undef
+ );
+ }
+
+ my $parser = RT::EmailParser->new();
+ $parser->SmartParseMIMEEntityFromScalar(
+ Message => $args{'message'},
+ Decode => 0,
+ Exact => 1,
+ );
+
+ my $Message = $parser->Entity();
+ unless ($Message) {
+ MailError(
+ Subject => "RT Bounce: Unparseable message",
+ Explanation => "RT couldn't process the message below",
+ Attach => $args{'message'}
+ );
+
+ return ( 0,
+ "Failed to parse this message. Something is likely badly wrong with the message"
+ );
+ }
+
+ my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
+ push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
+ @mail_plugins = _LoadPlugins( @mail_plugins );
+
+ #Set up a queue object
+ my $SystemQueueObj = RT::Queue->new( RT->SystemUser );
+ $SystemQueueObj->Load( $args{'queue'} );
+
+ my %skip_plugin;
+ foreach my $class( grep !ref, @mail_plugins ) {
+ # check if we should apply filter before decoding
+ my $check_cb = do {
+ no strict 'refs';
+ *{ $class . "::ApplyBeforeDecode" }{CODE};
+ };
+ next unless defined $check_cb;
+ next unless $check_cb->(
+ Message => $Message,
+ RawMessageRef => \$args{'message'},
+ Queue => $SystemQueueObj,
+ Actions => \@actions,
+ );
+
+ $skip_plugin{ $class }++;
+
+ my $Code = do {
+ no strict 'refs';
+ *{ $class . "::GetCurrentUser" }{CODE};
+ };
+ my ($status, $msg) = $Code->(
+ Message => $Message,
+ RawMessageRef => \$args{'message'},
+ Queue => $SystemQueueObj,
+ Actions => \@actions,
+ );
+ next if $status > 0;
+
+ if ( $status == -2 ) {
+ return (1, $msg, undef);
+ } elsif ( $status == -1 ) {
+ return (0, $msg, undef);
+ }
+ }
+ @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
+ $parser->_DecodeBodies;
+ $parser->RescueOutlook;
+ $parser->_PostProcessNewEntity;
+
+ my $head = $Message->head;
+ my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
+ my $Sender = (ParseSenderAddressFromHead( $head ))[0];
+ my $From = Encode::decode( "UTF-8", $head->get("From") );
+ chomp $From if defined $From;
+
+ my $MessageId = Encode::decode( "UTF-8", $head->get('Message-ID') )
+ || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
+
+ #Pull apart the subject line
+ my $Subject = Encode::decode( "UTF-8", $head->get('Subject') || '');
+ chomp $Subject;
+
+ # Lets check for mail loops of various sorts.
+ my ($should_store_machine_generated_message, $IsALoop, $result);
+ ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
+ _HandleMachineGeneratedMail(
+ Message => $Message,
+ ErrorsTo => $ErrorsTo,
+ Subject => $Subject,
+ MessageId => $MessageId
+ );
+
+ # Do not pass loop messages to MailPlugins, to make sure the loop
+ # is broken, unless $RT::StoreLoops is set.
+ if ($IsALoop && !$should_store_machine_generated_message) {
+ return ( 0, $result, undef );
+ }
+ # }}}
+
+ $args{'ticket'} ||= ExtractTicketId( $Message );
+
+ # ExtractTicketId may have been overridden, and edited the Subject
+ my $NewSubject = Encode::decode( "UTF-8", $Message->head->get('Subject') );
+ chomp $NewSubject;
+
+ $SystemTicket = RT::Ticket->new( RT->SystemUser );
+ $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
+ if ( $SystemTicket->id ) {
+ $Right = 'ReplyToTicket';
+ } else {
+ $Right = 'CreateTicket';
+ }
+
+ # We can safely have no queue of we have a known-good ticket
+ unless ( $SystemTicket->id || $SystemQueueObj->id ) {
+ return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
+ }
+
+ my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
+ MailPlugins => \@mail_plugins,
+ Actions => \@actions,
+ Message => $Message,
+ RawMessageRef => \$args{message},
+ SystemTicket => $SystemTicket,
+ SystemQueue => $SystemQueueObj,
+ );
+
+ # If authentication fails and no new user was created, get out.
+ if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
+
+ # If the plugins refused to create one, they lose.
+ unless ( $AuthStat == -1 ) {
+ _NoAuthorizedUserFound(
+ Right => $Right,
+ Message => $Message,
+ Requestor => $ErrorsTo,
+ Queue => $args{'queue'}
+ );
+
+ }
+ return ( 0, "Could not load a valid user", undef );
+ }
+
+ # If we got a user, but they don't have the right to say things
+ if ( $AuthStat == 0 ) {
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Permission Denied",
+ Explanation =>
+ "You do not have permission to communicate with RT",
+ MIMEObj => $Message
+ );
+ return (
+ 0,
+ ($CurrentUser->EmailAddress || $CurrentUser->Name)
+ . " ($Sender) tried to submit a message to "
+ . $args{'Queue'}
+ . " without permission.",
+ undef
+ );
+ }
+
+
+ unless ($should_store_machine_generated_message) {
+ return ( 0, $result, undef );
+ }
+
+ $head->replace('X-RT-Interface' => 'Email');
+
+ # if plugin's updated SystemTicket then update arguments
+ $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
+
+ my $Ticket = RT::Ticket->new($CurrentUser);
+
+ if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
+ {
+
+ my @Cc;
+ my @Requestors = ( $CurrentUser->id );
+
+ if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
+ @Cc = ParseCcAddressesFromHead(
+ Head => $head,
+ CurrentUser => $CurrentUser,
+ QueueObj => $SystemQueueObj
+ );
+ }
+
+ my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
+ Queue => $SystemQueueObj->Id,
+ Subject => $NewSubject,
+ Requestor => \@Requestors,
+ Cc => \@Cc,
+ MIMEObj => $Message
+ );