+++ /dev/null
-# BEGIN BPS TAGGED BLOCK {{{
-#
-# COPYRIGHT:
-#
-# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
-# <sales@bestpractical.com>
-#
-# (Except where explicitly superseded by other copyright notices)
-#
-#
-# LICENSE:
-#
-# This work is made available to you under the terms of Version 2 of
-# the GNU General Public License. A copy of that license should have
-# been provided with this software, but in any event can be snarfed
-# from www.gnu.org.
-#
-# This work is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-# 02110-1301 or visit their web page on the internet at
-# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
-#
-#
-# CONTRIBUTION SUBMISSION POLICY:
-#
-# (The following paragraph is not intended to limit the rights granted
-# to you to modify and distribute this software under the terms of
-# the GNU General Public License and is only of importance to you if
-# you choose to contribute your changes and enhancements to the
-# community by submitting them to Best Practical Solutions, LLC.)
-#
-# By intentionally submitting any modifications, corrections or
-# derivatives to this work, or any other work intended for use with
-# Request Tracker, to Best Practical Solutions, LLC, you confirm that
-# you are the copyright holder for those contributions and you grant
-# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
-# royalty-free, perpetual, license to use, copy, create derivative
-# works based on those contributions, and sublicense and distribute
-# those contributions and any derivatives thereof.
-#
-# END BPS TAGGED BLOCK }}}
-
-package RT::Action::CreateTickets;
-use base 'RT::Action';
-
-use strict;
-use warnings;
-
-use MIME::Entity;
-
-=head1 NAME
-
-RT::Action::CreateTickets - Create one or more tickets according to an externally supplied template
-
-=head1 SYNOPSIS
-
- ===Create-Ticket: codereview
- Subject: Code review for {$Tickets{'TOP'}->Subject}
- Depended-On-By: TOP
- Content: Someone has created a ticket. you should review and approve it,
- so they can finish their work
- ENDOFCONTENT
-
-=head1 DESCRIPTION
-
-The CreateTickets ScripAction allows you to create automated workflows in RT,
-creating new tickets in response to actions and conditions from other
-tickets.
-
-=head2 Format
-
-CreateTickets uses the RT template configured in the scrip as a template
-for an ordered set of tickets to create. The basic format is as follows:
-
- ===Create-Ticket: identifier
- Param: Value
- Param2: Value
- Param3: Value
- Content: Blah
- blah
- blah
- ENDOFCONTENT
- ===Create-Ticket: id2
- Param: Value
- Content: Blah
- ENDOFCONTENT
-
-As shown, you can put one or more C<===Create-Ticket:> sections in
-a template. Each C<===Create-Ticket:> section is evaluated as its own
-L<Text::Template> object, which means that you can embed snippets
-of Perl inside the L<Text::Template> using C<{}> delimiters, but that
-such sections absolutely can not span a C<===Create-Ticket:> boundary.
-
-Note that each C<Value> must come right after the C<Param> on the same
-line. The C<Content:> param can extend over multiple lines, but the text
-of the first line must start right after C<Content:>. Don't try to start
-your C<Content:> section with a newline.
-
-After each ticket is created, it's stuffed into a hash called C<%Tickets>
-making it available during the creation of other tickets during the
-same ScripAction. The hash key for each ticket is C<create-[identifier]>,
-where C<[identifier]> is the value you put after C<===Create-Ticket:>. The hash
-is prepopulated with the ticket which triggered the ScripAction as
-C<$Tickets{'TOP'}>. You can also access that ticket using the shorthand
-C<TOP>.
-
-A simple example:
-
- ===Create-Ticket: codereview
- Subject: Code review for {$Tickets{'TOP'}->Subject}
- Depended-On-By: TOP
- Content: Someone has created a ticket. you should review and approve it,
- so they can finish their work
- ENDOFCONTENT
-
-A convoluted example:
-
- ===Create-Ticket: approval
- { # Find out who the administrators of the group called "HR"
- # of which the creator of this ticket is a member
- my $name = "HR";
-
- my $groups = RT::Groups->new(RT->SystemUser);
- $groups->LimitToUserDefinedGroups();
- $groups->Limit(FIELD => "Name", OPERATOR => "=", VALUE => "$name");
- $groups->WithMember($TransactionObj->CreatorObj->Id);
-
- my $groupid = $groups->First->Id;
-
- my $adminccs = RT::Users->new(RT->SystemUser);
- $adminccs->WhoHaveRight(
- Right => "AdminGroup",
- Object =>$groups->First,
- IncludeSystemRights => undef,
- IncludeSuperusers => 0,
- IncludeSubgroupMembers => 0,
- );
-
- our @admins;
- while (my $admin = $adminccs->Next) {
- push (@admins, $admin->EmailAddress);
- }
- }
- Queue: ___Approvals
- Type: approval
- AdminCc: {join ("\nAdminCc: ",@admins) }
- Depended-On-By: TOP
- Refers-To: TOP
- Subject: Approval for ticket: {$Tickets{"TOP"}->Id} - {$Tickets{"TOP"}->Subject}
- Due: {time + 86400}
- Content-Type: text/plain
- Content: Your approval is requested for the ticket {$Tickets{"TOP"}->Id}: {$Tickets{"TOP"}->Subject}
- Blah
- Blah
- ENDOFCONTENT
- ===Create-Ticket: two
- Subject: Manager approval
- Type: approval
- Depended-On-By: TOP
- Refers-To: {$Tickets{"create-approval"}->Id}
- Queue: ___Approvals
- Content-Type: text/plain
- Content: Your approval is requred for this ticket, too.
- ENDOFCONTENT
-
-As shown above, you can include a block with Perl code to set up some
-values for the new tickets. If you want to access a variable in the
-template section after the block, you must scope it with C<our> rather
-than C<my>. Just as with other RT templates, you can also include
-Perl code in the template sections using C<{}>.
-
-=head2 Acceptable Fields
-
-A complete list of acceptable fields:
-
- * Queue => Name or id# of a queue
- Subject => A text string
- ! Status => A valid status. Defaults to 'new'
- Due => Dates can be specified in seconds since the epoch
- to be handled literally or in a semi-free textual
- format which RT will attempt to parse.
- Starts =>
- Started =>
- Resolved =>
- Owner => Username or id of an RT user who can and should own
- this ticket; forces the owner if necessary
- + Requestor => Email address
- + Cc => Email address
- + AdminCc => Email address
- + RequestorGroup => Group name
- + CcGroup => Group name
- + AdminCcGroup => Group name
- TimeWorked =>
- TimeEstimated =>
- TimeLeft =>
- InitialPriority =>
- FinalPriority =>
- Type =>
- +! DependsOn =>
- +! DependedOnBy =>
- +! RefersTo =>
- +! ReferredToBy =>
- +! Members =>
- +! MemberOf =>
- Content => Content. Can extend to multiple lines. Everything
- within a template after a Content: header is treated
- as content until we hit a line containing only
- ENDOFCONTENT
- ContentType => the content-type of the Content field. Defaults to
- 'text/plain'
- UpdateType => 'correspond' or 'comment'; used in conjunction with
- 'content' if this is an update. Defaults to
- 'correspond'
-
- CustomField-<id#> => custom field value
- CF-name => custom field value
- CustomField-name => custom field value
-
-Fields marked with an C<*> are required.
-
-Fields marked with a C<+> may have multiple values, simply
-by repeating the fieldname on a new line with an additional value.
-
-Fields marked with a C<!> have processing postponed until after all
-tickets in the same actions are created. Except for C<Status>, those
-fields can also take a ticket name within the same action (i.e.
-the identifiers after C<===Create-Ticket:>), instead of raw ticket ID
-numbers.
-
-When parsed, field names are converted to lowercase and have hyphens stripped.
-C<Refers-To>, C<RefersTo>, C<refersto>, C<refers-to> and C<r-e-f-er-s-tO> will
-all be treated as the same thing.
-
-=head1 METHODS
-
-=cut
-
-my %LINKTYPEMAP = (
- MemberOf => {
- Type => 'MemberOf',
- Mode => 'Target',
- },
- Parents => {
- Type => 'MemberOf',
- Mode => 'Target',
- },
- Members => {
- Type => 'MemberOf',
- Mode => 'Base',
- },
- Children => {
- Type => 'MemberOf',
- Mode => 'Base',
- },
- HasMember => {
- Type => 'MemberOf',
- Mode => 'Base',
- },
- RefersTo => {
- Type => 'RefersTo',
- Mode => 'Target',
- },
- ReferredToBy => {
- Type => 'RefersTo',
- Mode => 'Base',
- },
- DependsOn => {
- Type => 'DependsOn',
- Mode => 'Target',
- },
- DependedOnBy => {
- Type => 'DependsOn',
- Mode => 'Base',
- },
-
-);
-
-
-#Do what we need to do and send it out.
-sub Commit {
- my $self = shift;
-
- # Create all the tickets we care about
- return (1) unless $self->TicketObj->Type eq 'ticket';
-
- $self->CreateByTemplate( $self->TicketObj );
- $self->UpdateByTemplate( $self->TicketObj );
- return (1);
-}
-
-
-
-sub Prepare {
- my $self = shift;
-
- unless ( $self->TemplateObj ) {
- $RT::Logger->warning("No template object handed to $self");
- }
-
- unless ( $self->TransactionObj ) {
- $RT::Logger->warning("No transaction object handed to $self");
-
- }
-
- unless ( $self->TicketObj ) {
- $RT::Logger->warning("No ticket object handed to $self");
-
- }
-
- my $active = 0;
- if ( $self->TemplateObj->Type eq 'Perl' ) {
- $active = 1;
- } else {
- RT->Logger->info(sprintf(
- "Template #%d is type %s. You most likely want to use a Perl template instead.",
- $self->TemplateObj->id, $self->TemplateObj->Type
- ));
- }
-
- $self->Parse(
- Content => $self->TemplateObj->Content,
- _ActiveContent => $active,
- );
- return 1;
-
-}
-
-
-
-sub CreateByTemplate {
- my $self = shift;
- my $top = shift;
-
- $RT::Logger->debug("In CreateByTemplate");
-
- my @results;
-
- # XXX: cargo cult programming that works. i'll be back.
-
- local %T::Tickets = %T::Tickets;
- local $T::TOP = $T::TOP;
- local $T::ID = $T::ID;
- $T::Tickets{'TOP'} = $T::TOP = $top if $top;
- local $T::TransactionObj = $self->TransactionObj;
-
- my $ticketargs;
- my ( @links, @postponed );
- foreach my $template_id ( @{ $self->{'create_tickets'} } ) {
- $RT::Logger->debug("Workflow: processing $template_id of $T::TOP")
- if $T::TOP;
-
- $T::ID = $template_id;
- @T::AllID = @{ $self->{'create_tickets'} };
-
- ( $T::Tickets{$template_id}, $ticketargs )
- = $self->ParseLines( $template_id, \@links, \@postponed );
-
- # Now we have a %args to work with.
- # Make sure we have at least the minimum set of
- # reasonable data and do our thang
-
- my ( $id, $transid, $msg )
- = $T::Tickets{$template_id}->Create(%$ticketargs);
-
- foreach my $res ( split( '\n', $msg ) ) {
- push @results,
- $T::Tickets{$template_id}
- ->loc( "Ticket [_1]", $T::Tickets{$template_id}->Id ) . ': '
- . $res;
- }
- if ( !$id ) {
- if ( $self->TicketObj ) {
- $msg = "Couldn't create related ticket $template_id for "
- . $self->TicketObj->Id . " "
- . $msg;
- } else {
- $msg = "Couldn't create ticket $template_id " . $msg;
- }
-
- $RT::Logger->error($msg);
- next;
- }
-
- $RT::Logger->debug("Assigned $template_id with $id");
- $T::Tickets{$template_id}->SetOriginObj( $self->TicketObj )
- if $self->TicketObj
- && $T::Tickets{$template_id}->can('SetOriginObj');
-
- }
-
- $self->PostProcess( \@links, \@postponed );
-
- return @results;
-}
-
-sub UpdateByTemplate {
- my $self = shift;
- my $top = shift;
-
- # XXX: cargo cult programming that works. i'll be back.
-
- my @results;
- local %T::Tickets = %T::Tickets;
- local $T::ID = $T::ID;
-
- my $ticketargs;
- my ( @links, @postponed );
- foreach my $template_id ( @{ $self->{'update_tickets'} } ) {
- $RT::Logger->debug("Update Workflow: processing $template_id");
-
- $T::ID = $template_id;
- @T::AllID = @{ $self->{'update_tickets'} };
-
- ( $T::Tickets{$template_id}, $ticketargs )
- = $self->ParseLines( $template_id, \@links, \@postponed );
-
- # Now we have a %args to work with.
- # Make sure we have at least the minimum set of
- # reasonable data and do our thang
-
- my @attribs = qw(
- Subject
- FinalPriority
- Priority
- TimeEstimated
- TimeWorked
- TimeLeft
- Status
- Queue
- Due
- Starts
- Started
- Resolved
- );
-
- my $id = $template_id;
- $id =~ s/update-(\d+).*/$1/;
- my ($loaded, $msg) = $T::Tickets{$template_id}->LoadById($id);
-
- unless ( $loaded ) {
- $RT::Logger->error("Couldn't update ticket $template_id: " . $msg);
- push @results, $self->loc( "Couldn't load ticket '[_1]'", $id );
- next;
- }
-
- my $current = $self->GetBaseTemplate( $T::Tickets{$template_id} );
-
- $template_id =~ m/^update-(.*)/;
- my $base_id = "base-$1";
- my $base = $self->{'templates'}->{$base_id};
- if ($base) {
- $base =~ s/\r//g;
- $base =~ s/\n+$//;
- $current =~ s/\n+$//;
-
- # If we have no base template, set what we can.
- if ( $base ne $current ) {
- push @results,
- "Could not update ticket "
- . $T::Tickets{$template_id}->Id
- . ": Ticket has changed";
- next;
- }
- }
- push @results, $T::Tickets{$template_id}->Update(
- AttributesRef => \@attribs,
- ARGSRef => $ticketargs
- );
-
- if ( $ticketargs->{'Owner'} ) {
- ($id, $msg) = $T::Tickets{$template_id}->SetOwner($ticketargs->{'Owner'}, "Force");
- push @results, $msg unless $msg eq $self->loc("That user already owns that ticket");
- }
-
- push @results,
- $self->UpdateWatchers( $T::Tickets{$template_id}, $ticketargs );
-
- push @results,
- $self->UpdateCustomFields( $T::Tickets{$template_id}, $ticketargs );
-
- next unless $ticketargs->{'MIMEObj'};
- if ( $ticketargs->{'UpdateType'} =~ /^(private|comment)$/i ) {
- my ( $Transaction, $Description, $Object )
- = $T::Tickets{$template_id}->Comment(
- BccMessageTo => $ticketargs->{'Bcc'},
- MIMEObj => $ticketargs->{'MIMEObj'},
- TimeTaken => $ticketargs->{'TimeWorked'}
- );
- push( @results,
- $T::Tickets{$template_id}
- ->loc( "Ticket [_1]", $T::Tickets{$template_id}->id )
- . ': '
- . $Description );
- } elsif ( $ticketargs->{'UpdateType'} =~ /^(public|response|correspond)$/i ) {
- my ( $Transaction, $Description, $Object )
- = $T::Tickets{$template_id}->Correspond(
- BccMessageTo => $ticketargs->{'Bcc'},
- MIMEObj => $ticketargs->{'MIMEObj'},
- TimeTaken => $ticketargs->{'TimeWorked'}
- );
- push( @results,
- $T::Tickets{$template_id}
- ->loc( "Ticket [_1]", $T::Tickets{$template_id}->id )
- . ': '
- . $Description );
- } else {
- push(
- @results,
- $T::Tickets{$template_id}->loc(
- "Update type was neither correspondence nor comment.")
- . " "
- . $T::Tickets{$template_id}->loc("Update not recorded.")
- );
- }
- }
-
- $self->PostProcess( \@links, \@postponed );
-
- return @results;
-}
-
-=head2 Parse
-
-Takes (in order) template content, a default queue, a default requestor, and
-active (a boolean flag).
-
-Parses a template in the template content, defaulting queue and requestor if
-unspecified in the template to the values provided as arguments.
-
-If the active flag is true, then we'll use L<Text::Template> to parse the
-templates, allowing you to embed active Perl in your templates.
-
-=cut
-
-sub Parse {
- my $self = shift;
- my %args = (
- Content => undef,
- Queue => undef,
- Requestor => undef,
- _ActiveContent => undef,
- @_
- );
-
- if ( $args{'_ActiveContent'} ) {
- $self->{'UsePerlTextTemplate'} = 1;
- } else {
-
- $self->{'UsePerlTextTemplate'} = 0;
- }
-
- if ( substr( $args{'Content'}, 0, 3 ) eq '===' ) {
- $self->_ParseMultilineTemplate(%args);
- } elsif ( $args{'Content'} =~ /(?:\t|,)/i ) {
- $self->_ParseXSVTemplate(%args);
- } else {
- RT->Logger->error("Invalid Template Content (Couldn't find ===, and is not a csv/tsv template) - unable to parse: $args{Content}");
- }
-}
-
-=head2 _ParseMultilineTemplate
-
-Parses mulitline templates. Things like:
-
- ===Create-Ticket: ...
-
-Takes the same arguments as L</Parse>.
-
-=cut
-
-sub _ParseMultilineTemplate {
- my $self = shift;
- my %args = (@_);
-
- my $template_id;
- my ( $queue, $requestor );
- $RT::Logger->debug("Line: ===");
- foreach my $line ( split( /\n/, $args{'Content'} ) ) {
- $line =~ s/\r$//;
- $RT::Logger->debug( "Line: $line" );
- if ( $line =~ /^===/ ) {
- if ( $template_id && !$queue && $args{'Queue'} ) {
- $self->{'templates'}->{$template_id}
- .= "Queue: $args{'Queue'}\n";
- }
- if ( $template_id && !$requestor && $args{'Requestor'} ) {
- $self->{'templates'}->{$template_id}
- .= "Requestor: $args{'Requestor'}\n";
- }
- $queue = 0;
- $requestor = 0;
- }
- if ( $line =~ /^===Create-Ticket: (.*)$/ ) {
- $template_id = "create-$1";
- $RT::Logger->debug("**** Create ticket: $template_id");
- push @{ $self->{'create_tickets'} }, $template_id;
- } elsif ( $line =~ /^===Update-Ticket: (.*)$/ ) {
- $template_id = "update-$1";
- $RT::Logger->debug("**** Update ticket: $template_id");
- push @{ $self->{'update_tickets'} }, $template_id;
- } elsif ( $line =~ /^===Base-Ticket: (.*)$/ ) {
- $template_id = "base-$1";
- $RT::Logger->debug("**** Base ticket: $template_id");
- push @{ $self->{'base_tickets'} }, $template_id;
- } elsif ( $line =~ /^===#.*$/ ) { # a comment
- next;
- } else {
- if ( $line =~ /^Queue:(.*)/i ) {
- $queue = 1;
- my $value = $1;
- $value =~ s/^\s//;
- $value =~ s/\s$//;
- if ( !$value && $args{'Queue'} ) {
- $value = $args{'Queue'};
- $line = "Queue: $value";
- }
- }
- if ( $line =~ /^Requestors?:(.*)/i ) {
- $requestor = 1;
- my $value = $1;
- $value =~ s/^\s//;
- $value =~ s/\s$//;
- if ( !$value && $args{'Requestor'} ) {
- $value = $args{'Requestor'};
- $line = "Requestor: $value";
- }
- }
- $self->{'templates'}->{$template_id} .= $line . "\n";
- }
- }
- if ( $template_id && !$queue && $args{'Queue'} ) {
- $self->{'templates'}->{$template_id} .= "Queue: $args{'Queue'}\n";
- }
- }
-
-sub ParseLines {
- my $self = shift;
- my $template_id = shift;
- my $links = shift;
- my $postponed = shift;
-
- my $content = $self->{'templates'}->{$template_id};
-
- if ( $self->{'UsePerlTextTemplate'} ) {
-
- $RT::Logger->debug(
- "Workflow: evaluating\n$self->{templates}{$template_id}");
-
- my $template = Text::Template->new(
- TYPE => 'STRING',
- SOURCE => $content
- );
-
- my $err;
- $content = $template->fill_in(
- PACKAGE => 'T',
- BROKEN => sub {
- $err = {@_}->{error};
- }
- );
-
- $RT::Logger->debug("Workflow: yielding $content");
-
- if ($err) {
- $RT::Logger->error( "Ticket creation failed: " . $err );
- while ( my ( $k, $v ) = each %T::X ) {
- $RT::Logger->debug(
- "Eliminating $template_id from ${k}'s parents.");
- delete $v->{$template_id};
- }
- next;
- }
- }
-
- my $TicketObj ||= RT::Ticket->new( $self->CurrentUser );
-
- my %args;
- my %original_tags;
- my @lines = ( split( /\n/, $content ) );
- while ( defined( my $line = shift @lines ) ) {
- if ( $line =~ /^(.*?):(?:\s+)(.*?)(?:\s*)$/ ) {
- my $value = $2;
- my $original_tag = $1;
- my $tag = lc($original_tag);
- $tag =~ s/-//g;
- $tag =~ s/^(requestor|cc|admincc)s?$/$1/i;
-
- $original_tags{$tag} = $original_tag;
-
- if ( ref( $args{$tag} ) )
- { #If it's an array, we want to push the value
- push @{ $args{$tag} }, $value;
- } elsif ( defined( $args{$tag} ) )
- { #if we're about to get a second value, make it an array
- $args{$tag} = [ $args{$tag}, $value ];
- } else { #if there's nothing there, just set the value
- $args{$tag} = $value;
- }
-
- if ( $tag =~ /^content$/i ) { #just build up the content
- # convert it to an array
- $args{$tag} = defined($value) ? [ $value . "\n" ] : [];
- while ( defined( my $l = shift @lines ) ) {
- last if ( $l =~ /^ENDOFCONTENT\s*$/ );
- push @{ $args{'content'} }, $l . "\n";
- }
- } else {
- # if it's not content, strip leading and trailing spaces
- if ( $args{$tag} ) {
- $args{$tag} =~ s/^\s+//g;
- $args{$tag} =~ s/\s+$//g;
- }
- if (
- ($tag =~ /^(requestor|cc|admincc)(group)?$/i
- or grep {lc $_ eq $tag} keys %LINKTYPEMAP)
- and $args{$tag} =~ /,/
- ) {
- $args{$tag} = [ split /,\s*/, $args{$tag} ];
- }
- }
- }
- }
-
- foreach my $date (qw(due starts started resolved)) {
- my $dateobj = RT::Date->new( $self->CurrentUser );
- next unless $args{$date};
- if ( $args{$date} =~ /^\d+$/ ) {
- $dateobj->Set( Format => 'unix', Value => $args{$date} );
- } else {
- eval {
- $dateobj->Set( Format => 'iso', Value => $args{$date} );
- };
- if ($@ or $dateobj->Unix <= 0) {
- $dateobj->Set( Format => 'unknown', Value => $args{$date} );
- }
- }
- $args{$date} = $dateobj->ISO;
- }
-
- foreach my $role (qw(requestor cc admincc)) {
- next unless my $value = $args{ $role . 'group' };
-
- my $group = RT::Group->new( $self->CurrentUser );
- $group->LoadUserDefinedGroup( $value );
- unless ( $group->id ) {
- $RT::Logger->error("Couldn't load group '$value'");
- next;
- }
-
- $args{ $role } = $args{ $role } ? [$args{ $role }] : []
- unless ref $args{ $role };
- push @{ $args{ $role } }, $group->PrincipalObj->id;
- }
-
- $args{'requestor'} ||= $self->TicketObj->Requestors->MemberEmailAddresses
- if $self->TicketObj;
-
- $args{'type'} ||= 'ticket';
-
- my %ticketargs = (
- Queue => $args{'queue'},
- Subject => $args{'subject'},
- Status => $args{'status'} || 'new',
- Due => $args{'due'},
- Starts => $args{'starts'},
- Started => $args{'started'},
- Resolved => $args{'resolved'},
- Owner => $args{'owner'},
- Requestor => $args{'requestor'},
- Cc => $args{'cc'},
- AdminCc => $args{'admincc'},
- TimeWorked => $args{'timeworked'},
- TimeEstimated => $args{'timeestimated'},
- TimeLeft => $args{'timeleft'},
- InitialPriority => $args{'initialpriority'} || 0,
- FinalPriority => $args{'finalpriority'} || 0,
- SquelchMailTo => $args{'squelchmailto'},
- Type => $args{'type'},
- $self->Rules
- );
-
- if ( $args{content} ) {
- my $mimeobj = MIME::Entity->build(
- Type => $args{'contenttype'} || 'text/plain',
- Charset => 'UTF-8',
- Data => [ map {Encode::encode( "UTF-8", $_ )} @{$args{'content'}} ],
- );
- $ticketargs{MIMEObj} = $mimeobj;
- $ticketargs{UpdateType} = $args{'updatetype'} || 'correspond';
- }
-
- foreach my $tag ( keys(%args) ) {
- # if the tag was added later, skip it
- my $orig_tag = $original_tags{$tag} or next;
- if ( $orig_tag =~ /^customfield-?(\d+)$/i ) {
- $ticketargs{ "CustomField-" . $1 } = $args{$tag};
- } elsif ( $orig_tag =~ /^(?:customfield|cf)-?(.+)$/i ) {
- my $cf = RT::CustomField->new( $self->CurrentUser );
- $cf->LoadByName( Name => $1, Queue => $ticketargs{Queue} );
- $cf->LoadByName( Name => $1, Queue => 0 ) unless $cf->id;
- next unless $cf->id;
- $ticketargs{ "CustomField-" . $cf->id } = $args{$tag};
- } elsif ($orig_tag) {
- my $cf = RT::CustomField->new( $self->CurrentUser );
- $cf->LoadByName( Name => $orig_tag, Queue => $ticketargs{Queue} );
- $cf->LoadByName( Name => $orig_tag, Queue => 0 ) unless $cf->id;
- next unless $cf->id;
- $ticketargs{ "CustomField-" . $cf->id } = $args{$tag};
-
- }
- }
-
- $self->GetDeferred( \%args, $template_id, $links, $postponed );
-
- return $TicketObj, \%ticketargs;
-}
-
-
-=head2 _ParseXSVTemplate
-
-Parses a tab or comma delimited template. Should only ever be called by
-L</Parse>.
-
-=cut
-
-sub _ParseXSVTemplate {
- my $self = shift;
- my %args = (@_);
-
- use Regexp::Common qw(delimited);
- my($first, $content) = split(/\r?\n/, $args{'Content'}, 2);
-
- my $delimiter;
- if ( $first =~ /\t/ ) {
- $delimiter = "\t";
- } else {
- $delimiter = ',';
- }
- my @fields = split( /$delimiter/, $first );
-
- my $delimiter_re = qr[$delimiter];
- my $justquoted = qr[$RE{quoted}];
-
- # Used to generate automatic template ids
- my $autoid = 1;
-
- LINE:
- while ($content) {
- $content =~ s/^(\s*\r?\n)+//;
-
- # Keep track of Queue and Requestor, so we can provide defaults
- my $queue;
- my $requestor;
-
- # The template for this line
- my $template;
-
- # What column we're on
- my $i = 0;
-
- # If the last iteration was the end of the line
- my $EOL = 0;
-
- # The template id
- my $template_id;
-
- COLUMN:
- while (not $EOL and length $content and $content =~ s/^($justquoted|.*?)($delimiter_re|$)//smix) {
- $EOL = not $2;
-
- # Strip off quotes, if they exist
- my $value = $1;
- if ( $value =~ /^$RE{delimited}{-delim=>qq{\'\"}}$/ ) {
- substr( $value, 0, 1 ) = "";
- substr( $value, -1, 1 ) = "";
- }
-
- # What column is this?
- my $field = $fields[$i++];
- next COLUMN unless $field =~ /\S/;
- $field =~ s/^\s//;
- $field =~ s/\s$//;
-
- if ( $field =~ /^id$/i ) {
- # Special case if this is the ID column
- if ( $value =~ /^\d+$/ ) {
- $template_id = 'update-' . $value;
- push @{ $self->{'update_tickets'} }, $template_id;
- } elsif ( $value =~ /^#base-(\d+)$/ ) {
- $template_id = 'base-' . $1;
- push @{ $self->{'base_tickets'} }, $template_id;
- } elsif ( $value =~ /\S/ ) {
- $template_id = 'create-' . $value;
- push @{ $self->{'create_tickets'} }, $template_id;
- }
- } else {
- # Some translations
- if ( $field =~ /^Body$/i
- || $field =~ /^Data$/i
- || $field =~ /^Message$/i )
- {
- $field = 'Content';
- } elsif ( $field =~ /^Summary$/i ) {
- $field = 'Subject';
- } elsif ( $field =~ /^Queue$/i ) {
- # Note that we found a queue
- $queue = 1;
- $value ||= $args{'Queue'};
- } elsif ( $field =~ /^Requestors?$/i ) {
- $field = 'Requestor'; # Remove plural
- # Note that we found a requestor
- $requestor = 1;
- $value ||= $args{'Requestor'};
- }
-
- # Tack onto the end of the template
- $template .= $field . ": ";
- $template .= (defined $value ? $value : "");
- $template .= "\n";
- $template .= "ENDOFCONTENT\n"
- if $field =~ /^Content$/i;
- }
- }
-
- # Ignore blank lines
- next unless $template;
-
- # If we didn't find a queue of requestor, tack on the defaults
- if ( !$queue && $args{'Queue'} ) {
- $template .= "Queue: $args{'Queue'}\n";
- }
- if ( !$requestor && $args{'Requestor'} ) {
- $template .= "Requestor: $args{'Requestor'}\n";
- }
-
- # If we never found an ID, come up with one
- unless ($template_id) {
- $autoid++ while exists $self->{'templates'}->{"create-auto-$autoid"};
- $template_id = "create-auto-$autoid";
- # Also, it's a ticket to create
- push @{ $self->{'create_tickets'} }, $template_id;
- }
-
- # Save the template we generated
- $self->{'templates'}->{$template_id} = $template;
-
- }
-}
-
-sub GetDeferred {
- my $self = shift;
- my $args = shift;
- my $id = shift;
- my $links = shift;
- my $postponed = shift;
-
- # Deferred processing
- push @$links,
- (
- $id,
- { DependsOn => $args->{'dependson'},
- DependedOnBy => $args->{'dependedonby'},
- RefersTo => $args->{'refersto'},
- ReferredToBy => $args->{'referredtoby'},
- Children => $args->{'children'},
- Parents => $args->{'parents'},
- }
- );
-
- push @$postponed, (
-
- # Status is postponed so we don't violate dependencies
- $id, { Status => $args->{'status'}, }
- );
-}
-
-sub GetUpdateTemplate {
- my $self = shift;
- my $t = shift;
-
- my $string;
- $string .= "Queue: " . $t->QueueObj->Name . "\n";
- $string .= "Subject: " . $t->Subject . "\n";
- $string .= "Status: " . $t->Status . "\n";
- $string .= "UpdateType: correspond\n";
- $string .= "Content: \n";
- $string .= "ENDOFCONTENT\n";
- $string .= "Due: " . $t->DueObj->AsString . "\n";
- $string .= "Starts: " . $t->StartsObj->AsString . "\n";
- $string .= "Started: " . $t->StartedObj->AsString . "\n";
- $string .= "Resolved: " . $t->ResolvedObj->AsString . "\n";
- $string .= "Owner: " . $t->OwnerObj->Name . "\n";
- $string .= "Requestor: " . $t->RequestorAddresses . "\n";
- $string .= "Cc: " . $t->CcAddresses . "\n";
- $string .= "AdminCc: " . $t->AdminCcAddresses . "\n";
- $string .= "TimeWorked: " . $t->TimeWorked . "\n";
- $string .= "TimeEstimated: " . $t->TimeEstimated . "\n";
- $string .= "TimeLeft: " . $t->TimeLeft . "\n";
- $string .= "InitialPriority: " . $t->Priority . "\n";
- $string .= "FinalPriority: " . $t->FinalPriority . "\n";
-
- foreach my $type ( sort keys %LINKTYPEMAP ) {
-
- # don't display duplicates
- if ( $type eq "HasMember"
- || $type eq "Members"
- || $type eq "MemberOf" )
- {
- next;
- }
- $string .= "$type: ";
-
- my $mode = $LINKTYPEMAP{$type}->{Mode};
- my $method = $LINKTYPEMAP{$type}->{Type};
-
- my $links = '';
- while ( my $link = $t->$method->Next ) {
- $links .= ", " if $links;
-
- my $object = $mode . "Obj";
- my $member = $link->$object;
- $links .= $member->Id if $member;
- }
- $string .= $links;
- $string .= "\n";
- }
-
- return $string;
-}
-
-sub GetBaseTemplate {
- my $self = shift;
- my $t = shift;
-
- my $string;
- $string .= "Queue: " . $t->Queue . "\n";
- $string .= "Subject: " . $t->Subject . "\n";
- $string .= "Status: " . $t->Status . "\n";
- $string .= "Due: " . $t->DueObj->Unix . "\n";
- $string .= "Starts: " . $t->StartsObj->Unix . "\n";
- $string .= "Started: " . $t->StartedObj->Unix . "\n";
- $string .= "Resolved: " . $t->ResolvedObj->Unix . "\n";
- $string .= "Owner: " . $t->Owner . "\n";
- $string .= "Requestor: " . $t->RequestorAddresses . "\n";
- $string .= "Cc: " . $t->CcAddresses . "\n";
- $string .= "AdminCc: " . $t->AdminCcAddresses . "\n";
- $string .= "TimeWorked: " . $t->TimeWorked . "\n";
- $string .= "TimeEstimated: " . $t->TimeEstimated . "\n";
- $string .= "TimeLeft: " . $t->TimeLeft . "\n";
- $string .= "InitialPriority: " . $t->Priority . "\n";
- $string .= "FinalPriority: " . $t->FinalPriority . "\n";
-
- return $string;
-}
-
-sub GetCreateTemplate {
- my $self = shift;
-
- my $string;
-
- $string .= "Queue: General\n";
- $string .= "Subject: \n";
- $string .= "Status: new\n";
- $string .= "Content: \n";
- $string .= "ENDOFCONTENT\n";
- $string .= "Due: \n";
- $string .= "Starts: \n";
- $string .= "Started: \n";
- $string .= "Resolved: \n";
- $string .= "Owner: \n";
- $string .= "Requestor: \n";
- $string .= "Cc: \n";
- $string .= "AdminCc:\n";
- $string .= "TimeWorked: \n";
- $string .= "TimeEstimated: \n";
- $string .= "TimeLeft: \n";
- $string .= "InitialPriority: \n";
- $string .= "FinalPriority: \n";
-
- foreach my $type ( keys %LINKTYPEMAP ) {
-
- # don't display duplicates
- if ( $type eq "HasMember"
- || $type eq 'Members'
- || $type eq 'MemberOf' )
- {
- next;
- }
- $string .= "$type: \n";
- }
- return $string;
-}
-
-sub UpdateWatchers {
- my $self = shift;
- my $ticket = shift;
- my $args = shift;
-
- my @results;
-
- foreach my $type (qw(Requestor Cc AdminCc)) {
- my $method = $type . 'Addresses';
- my $oldaddr = $ticket->$method;
-
- # Skip unless we have a defined field
- next unless defined $args->{$type};
- my $newaddr = $args->{$type};
-
- my @old = split( /,\s*/, $oldaddr );
- my @new;
- for (ref $newaddr ? @{$newaddr} : split( /,\s*/, $newaddr )) {
- # Sometimes these are email addresses, sometimes they're
- # users. Try to guess which is which, as we want to deal
- # with email addresses if at all possible.
- if (/^\S+@\S+$/) {
- push @new, $_;
- } else {
- # It doesn't look like an email address. Try to load it.
- my $user = RT::User->new($self->CurrentUser);
- $user->Load($_);
- if ($user->Id) {
- push @new, $user->EmailAddress;
- } else {
- push @new, $_;
- }
- }
- }
-
- my %oldhash = map { $_ => 1 } @old;
- my %newhash = map { $_ => 1 } @new;
-
- my @add = grep( !defined $oldhash{$_}, @new );
- my @delete = grep( !defined $newhash{$_}, @old );
-
- foreach (@add) {
- my ( $val, $msg ) = $ticket->AddWatcher(
- Type => $type,
- Email => $_
- );
-
- push @results,
- $ticket->loc( "Ticket [_1]", $ticket->Id ) . ': ' . $msg;
- }
-
- foreach (@delete) {
- my ( $val, $msg ) = $ticket->DeleteWatcher(
- Type => $type,
- Email => $_
- );
- push @results,
- $ticket->loc( "Ticket [_1]", $ticket->Id ) . ': ' . $msg;
- }
- }
- return @results;
-}
-
-sub UpdateCustomFields {
- my $self = shift;
- my $ticket = shift;
- my $args = shift;
-
- my @results;
- foreach my $arg (keys %{$args}) {
- next unless $arg =~ /^CustomField-(\d+)$/;
- my $cf = $1;
-
- my $CustomFieldObj = RT::CustomField->new($self->CurrentUser);
- $CustomFieldObj->SetContextObject( $ticket );
- $CustomFieldObj->LoadById($cf);
-
- my @values;
- if ($CustomFieldObj->Type =~ /text/i) { # Both Text and Wikitext
- @values = ($args->{$arg});
- } else {
- @values = split /\n/, $args->{$arg};
- }
-
- if ( ($CustomFieldObj->Type eq 'Freeform'
- && ! $CustomFieldObj->SingleValue) ||
- $CustomFieldObj->Type =~ /text/i) {
- foreach my $val (@values) {
- $val =~ s/\r//g;
- }
- }
-
- foreach my $value (@values) {
- next unless length($value);
- my ( $val, $msg ) = $ticket->AddCustomFieldValue(
- Field => $cf,
- Value => $value
- );
- push ( @results, $msg );
- }
- }
- return @results;
-}
-
-sub PostProcess {
- my $self = shift;
- my $links = shift;
- my $postponed = shift;
-
- # postprocessing: add links
-
- while ( my $template_id = shift(@$links) ) {
- my $ticket = $T::Tickets{$template_id};
- $RT::Logger->debug( "Handling links for " . $ticket->Id );
- my %args = %{ shift(@$links) };
-
- foreach my $type ( keys %LINKTYPEMAP ) {
- next unless ( defined $args{$type} );
- foreach my $link (
- ref( $args{$type} ) ? @{ $args{$type} } : ( $args{$type} ) )
- {
- next unless $link;
-
- if ( $link =~ /^TOP$/i ) {
- $RT::Logger->debug( "Building $type link for $link: "
- . $T::Tickets{TOP}->Id );
- $link = $T::Tickets{TOP}->Id;
-
- } elsif ( $link !~ m/^\d+$/ ) {
- my $key = "create-$link";
- if ( !exists $T::Tickets{$key} ) {
- $RT::Logger->debug(
- "Skipping $type link for $key (non-existent)");
- next;
- }
- $RT::Logger->debug( "Building $type link for $link: "
- . $T::Tickets{$key}->Id );
- $link = $T::Tickets{$key}->Id;
- } else {
- $RT::Logger->debug("Building $type link for $link");
- }
-
- my ( $wval, $wmsg ) = $ticket->AddLink(
- Type => $LINKTYPEMAP{$type}->{'Type'},
- $LINKTYPEMAP{$type}->{'Mode'} => $link,
- Silent => 1
- );
-
- $RT::Logger->warning("AddLink thru $link failed: $wmsg")
- unless $wval;
-
- # push @non_fatal_errors, $wmsg unless ($wval);
- }
-
- }
- }
-
- # postponed actions -- Status only, currently
- while ( my $template_id = shift(@$postponed) ) {
- my $ticket = $T::Tickets{$template_id};
- $RT::Logger->debug( "Handling postponed actions for " . $ticket->id );
- my %args = %{ shift(@$postponed) };
- $ticket->SetStatus( $args{Status} ) if defined $args{Status};
- }
-
-}
-
-sub Options {
- my $self = shift;
- my $queues = RT::Queues->new($self->CurrentUser);
- $queues->UnLimit;
- my @names;
- while (my $queue = $queues->Next) {
- push @names, $queue->Id, $queue->Name;
- }
- return (
- {
- 'name' => 'Queue',
- 'label' => 'In queue',
- 'type' => 'select',
- 'options' => \@names
- }
- )
-}
-
-RT::Base->_ImportOverlays();
-
-1;
-
+++ /dev/null
-# BEGIN BPS TAGGED BLOCK {{{
-#
-# COPYRIGHT:
-#
-# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
-# <sales@bestpractical.com>
-#
-# (Except where explicitly superseded by other copyright notices)
-#
-#
-# LICENSE:
-#
-# This work is made available to you under the terms of Version 2 of
-# the GNU General Public License. A copy of that license should have
-# been provided with this software, but in any event can be snarfed
-# from www.gnu.org.
-#
-# This work is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-# 02110-1301 or visit their web page on the internet at
-# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
-#
-#
-# CONTRIBUTION SUBMISSION POLICY:
-#
-# (The following paragraph is not intended to limit the rights granted
-# to you to modify and distribute this software under the terms of
-# the GNU General Public License and is only of importance to you if
-# you choose to contribute your changes and enhancements to the
-# community by submitting them to Best Practical Solutions, LLC.)
-#
-# By intentionally submitting any modifications, corrections or
-# derivatives to this work, or any other work intended for use with
-# Request Tracker, to Best Practical Solutions, LLC, you confirm that
-# you are the copyright holder for those contributions and you grant
-# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
-# royalty-free, perpetual, license to use, copy, create derivative
-# works based on those contributions, and sublicense and distribute
-# those contributions and any derivatives thereof.
-#
-# END BPS TAGGED BLOCK }}}
-
-# Portions Copyright 2000 Tobias Brox <tobix@cpan.org>
-
-package RT::Action::SendEmail;
-
-use strict;
-use warnings;
-
-use base qw(RT::Action);
-
-use RT::EmailParser;
-use RT::Interface::Email;
-use Email::Address;
-our @EMAIL_RECIPIENT_HEADERS = qw(To Cc Bcc);
-
-
-=head1 NAME
-
-RT::Action::SendEmail - An Action which users can use to send mail
-or can subclassed for more specialized mail sending behavior.
-RT::Action::AutoReply is a good example subclass.
-
-=head1 SYNOPSIS
-
- use base 'RT::Action::SendEmail';
-
-=head1 DESCRIPTION
-
-Basically, you create another module RT::Action::YourAction which ISA
-RT::Action::SendEmail.
-
-=head1 METHODS
-
-=head2 CleanSlate
-
-Cleans class-wide options, like L</AttachTickets>.
-
-=cut
-
-sub CleanSlate {
- my $self = shift;
- $self->AttachTickets(undef);
-}
-
-=head2 Commit
-
-Sends the prepared message and writes outgoing record into DB if the feature is
-activated in the config.
-
-=cut
-
-sub Commit {
- my $self = shift;
-
- return abs $self->SendMessage( $self->TemplateObj->MIMEObj )
- unless RT->Config->Get('RecordOutgoingEmail');
-
- $self->DeferDigestRecipients();
- my $message = $self->TemplateObj->MIMEObj;
-
- my $orig_message;
- $orig_message = $message->dup if RT::Interface::Email::WillSignEncrypt(
- Attachment => $self->TransactionObj->Attachments->First,
- Ticket => $self->TicketObj,
- );
-
- my ($ret) = $self->SendMessage($message);
- return abs( $ret ) if $ret <= 0;
-
- if ($orig_message) {
- $message->attach(
- Type => 'application/x-rt-original-message',
- Disposition => 'inline',
- Data => $orig_message->as_string,
- );
- }
- $self->RecordOutgoingMailTransaction($message);
- $self->RecordDeferredRecipients();
- return 1;
-}
-
-=head2 Prepare
-
-Builds an outgoing email we're going to send using scrip's template.
-
-=cut
-
-sub Prepare {
- my $self = shift;
-
- my ( $result, $message ) = $self->TemplateObj->Parse(
- Argument => $self->Argument,
- TicketObj => $self->TicketObj,
- TransactionObj => $self->TransactionObj
- );
- if ( !$result ) {
- return (undef);
- }
-
- my $MIMEObj = $self->TemplateObj->MIMEObj;
-
- # Header
- $self->SetRTSpecialHeaders();
-
- my %seen;
- foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
- @{ $self->{$type} }
- = grep defined && length && !$seen{ lc $_ }++,
- @{ $self->{$type} };
- }
-
- $self->RemoveInappropriateRecipients();
-
- # Go add all the Tos, Ccs and Bccs that we need to to the message to
- # make it happy, but only if we actually have values in those arrays.
-
-# TODO: We should be pulling the recipients out of the template and shove them into To, Cc and Bcc
-
- for my $header (@EMAIL_RECIPIENT_HEADERS) {
-
- $self->SetHeader( $header, join( ', ', @{ $self->{$header} } ) )
- if (!$MIMEObj->head->get($header)
- && $self->{$header}
- && @{ $self->{$header} } );
- }
- # PseudoTo (fake to headers) shouldn't get matched for message recipients.
- # If we don't have any 'To' header (but do have other recipients), drop in
- # the pseudo-to header.
- $self->SetHeader( 'To', join( ', ', @{ $self->{'PseudoTo'} } ) )
- if $self->{'PseudoTo'}
- && @{ $self->{'PseudoTo'} }
- && !$MIMEObj->head->get('To')
- && ( $MIMEObj->head->get('Cc') or $MIMEObj->head->get('Bcc') );
-
- # We should never have to set the MIME-Version header
- $self->SetHeader( 'MIME-Version', '1.0' );
-
- # fsck.com #5959: Since RT sends 8bit mail, we should say so.
- $self->SetHeader( 'Content-Transfer-Encoding', '8bit' );
-
- # For security reasons, we only send out textual mails.
- foreach my $part ( grep !$_->is_multipart, $MIMEObj->parts_DFS ) {
- my $type = $part->mime_type || 'text/plain';
- $type = 'text/plain' unless RT::I18N::IsTextualContentType($type);
- $part->head->mime_attr( "Content-Type" => $type );
- # utf-8 here is for _FindOrGuessCharset in I18N.pm
- # it's not the final charset/encoding sent
- $part->head->mime_attr( "Content-Type.charset" => 'utf-8' );
- }
-
- RT::I18N::SetMIMEEntityToEncoding( $MIMEObj,
- RT->Config->Get('EmailOutputEncoding'),
- 'mime_words_ok', );
-
- # Build up a MIME::Entity that looks like the original message.
- $self->AddAttachments if ( $MIMEObj->head->get('RT-Attach-Message')
- && ( $MIMEObj->head->get('RT-Attach-Message') !~ /^(n|no|0|off|false)$/i ) );
-
- $self->AddTickets;
-
- my $attachment = $self->TransactionObj->Attachments->First;
- if ($attachment
- && !(
- $attachment->GetHeader('X-RT-Encrypt')
- || $self->TicketObj->QueueObj->Encrypt
- )
- )
- {
- $attachment->SetHeader( 'X-RT-Encrypt' => 1 )
- if ( $attachment->GetHeader("X-RT-Incoming-Encryption") || '' ) eq
- 'Success';
- }
-
- return $result;
-}
-
-=head2 To
-
-Returns an array of L<Email::Address> objects containing all the To: recipients for this notification
-
-=cut
-
-sub To {
- my $self = shift;
- return ( $self->AddressesFromHeader('To') );
-}
-
-=head2 Cc
-
-Returns an array of L<Email::Address> objects containing all the Cc: recipients for this notification
-
-=cut
-
-sub Cc {
- my $self = shift;
- return ( $self->AddressesFromHeader('Cc') );
-}
-
-=head2 Bcc
-
-Returns an array of L<Email::Address> objects containing all the Bcc: recipients for this notification
-
-=cut
-
-sub Bcc {
- my $self = shift;
- return ( $self->AddressesFromHeader('Bcc') );
-
-}
-
-sub AddressesFromHeader {
- my $self = shift;
- my $field = shift;
- my $header = $self->TemplateObj->MIMEObj->head->get($field);
- my @addresses = Email::Address->parse($header);
-
- return (@addresses);
-}
-
-=head2 SendMessage MIMEObj
-
-sends the message using RT's preferred API.
-TODO: Break this out to a separate module
-
-=cut
-
-sub SendMessage {
-
- # DO NOT SHIFT @_ in this subroutine. It breaks Hook::LexWrap's
- # ability to pass @_ to a 'post' routine.
- my ( $self, $MIMEObj ) = @_;
-
- my $msgid = $MIMEObj->head->get('Message-ID');
- chomp $msgid;
-
- $self->ScripActionObj->{_Message_ID}++;
-
- $RT::Logger->info( $msgid . " #"
- . $self->TicketObj->id . "/"
- . $self->TransactionObj->id
- . " - Scrip "
- . ($self->ScripObj->id || '#rule'). " "
- . ( $self->ScripObj->Description || '' ) );
-
- my $status = RT::Interface::Email::SendEmail(
- Entity => $MIMEObj,
- Ticket => $self->TicketObj,
- Transaction => $self->TransactionObj,
- );
-
-
- return $status unless ($status > 0 || exists $self->{'Deferred'});
-
- my $success = $msgid . " sent ";
- foreach (@EMAIL_RECIPIENT_HEADERS) {
- my $recipients = $MIMEObj->head->get($_);
- $success .= " $_: " . $recipients if $recipients;
- }
-
- if( exists $self->{'Deferred'} ) {
- for (qw(daily weekly susp)) {
- $success .= "\nBatched email $_ for: ". join(", ", keys %{ $self->{'Deferred'}{ $_ } } )
- if exists $self->{'Deferred'}{ $_ };
- }
- }
-
- $success =~ s/\n//g;
-
- $RT::Logger->info($success);
-
- return (1);
-}
-
-=head2 AddAttachments
-
-Takes any attachments to this transaction and attaches them to the message
-we're building.
-
-=cut
-
-sub AddAttachments {
- my $self = shift;
-
- my $MIMEObj = $self->TemplateObj->MIMEObj;
-
- $MIMEObj->head->delete('RT-Attach-Message');
-
- my $attachments = RT::Attachments->new( RT->SystemUser );
- $attachments->Limit(
- FIELD => 'TransactionId',
- VALUE => $self->TransactionObj->Id
- );
-
- # Don't attach anything blank
- $attachments->LimitNotEmpty;
- $attachments->OrderBy( FIELD => 'id' );
-
- # We want to make sure that we don't include the attachment that's
- # being used as the "Content" of this message" unless that attachment's
- # content type is not like text/...
- my $transaction_content_obj = $self->TransactionObj->ContentObj;
-
- if ( $transaction_content_obj
- && $transaction_content_obj->ContentType =~ m{text/}i )
- {
- # If this was part of a multipart/alternative, skip all of the kids
- my $parent = $transaction_content_obj->ParentObj;
- if ($parent and $parent->Id and $parent->ContentType eq "multipart/alternative") {
- $attachments->Limit(
- ENTRYAGGREGATOR => 'AND',
- FIELD => 'parent',
- OPERATOR => '!=',
- VALUE => $parent->Id,
- );
- } else {
- $attachments->Limit(
- ENTRYAGGREGATOR => 'AND',
- FIELD => 'id',
- OPERATOR => '!=',
- VALUE => $transaction_content_obj->Id,
- );
- }
- }
-
- # attach any of this transaction's attachments
- my $seen_attachment = 0;
- while ( my $attach = $attachments->Next ) {
- if ( !$seen_attachment ) {
- $MIMEObj->make_multipart( 'mixed', Force => 1 );
- $seen_attachment = 1;
- }
- $self->AddAttachment($attach);
- }
-}
-
-=head2 AddAttachment $attachment
-
-Takes one attachment object of L<RT::Attachment> class and attaches it to the message
-we're building.
-
-=cut
-
-sub AddAttachment {
- my $self = shift;
- my $attach = shift;
- my $MIMEObj = shift || $self->TemplateObj->MIMEObj;
-
- # $attach->TransactionObj may not always be $self->TransactionObj
- return unless $attach->Id
- and $attach->TransactionObj->CurrentUserCanSee;
-
- # ->attach expects just the disposition type; extract it if we have the header
- # or default to "attachment"
- my $disp = ($attach->GetHeader('Content-Disposition') || '')
- =~ /^\s*(inline|attachment)/i ? $1 : "attachment";
-
- $MIMEObj->attach(
- Type => $attach->ContentType,
- Charset => $attach->OriginalEncoding,
- Data => $attach->OriginalContent,
- Disposition => $disp,
- Filename => $self->MIMEEncodeString( $attach->Filename ),
- 'RT-Attachment:' => $self->TicketObj->Id . "/"
- . $self->TransactionObj->Id . "/"
- . $attach->id,
- Encoding => '-SUGGEST',
- );
-}
-
-=head2 AttachTickets [@IDs]
-
-Returns or set list of ticket's IDs that should be attached to an outgoing message.
-
-B<Note> this method works as a class method and setup things global, so you have to
-clean list by passing undef as argument.
-
-=cut
-
-{
- my $list = [];
-
- sub AttachTickets {
- my $self = shift;
- $list = [ grep defined, @_ ] if @_;
- return @$list;
- }
-}
-
-=head2 AddTickets
-
-Attaches tickets to the current message, list of tickets' ids get from
-L</AttachTickets> method.
-
-=cut
-
-sub AddTickets {
- my $self = shift;
- $self->AddTicket($_) foreach $self->AttachTickets;
- return;
-}
-
-=head2 AddTicket $ID
-
-Attaches a ticket with ID to the message.
-
-Each ticket is attached as multipart entity and all its messages and attachments
-are attached as sub entities in order of creation, but only if transaction type
-is Create or Correspond.
-
-=cut
-
-sub AddTicket {
- my $self = shift;
- my $tid = shift;
-
- my $attachs = RT::Attachments->new( $self->TransactionObj->CreatorObj );
- my $txn_alias = $attachs->TransactionAlias;
- $attachs->Limit( ALIAS => $txn_alias, FIELD => 'Type', VALUE => 'Create' );
- $attachs->Limit(
- ALIAS => $txn_alias,
- FIELD => 'Type',
- VALUE => 'Correspond'
- );
- $attachs->LimitByTicket($tid);
- $attachs->LimitNotEmpty;
- $attachs->OrderBy( FIELD => 'Created' );
-
- my $ticket_mime = MIME::Entity->build(
- Type => 'multipart/mixed',
- Top => 0,
- Description => "ticket #$tid",
- );
- while ( my $attachment = $attachs->Next ) {
- $self->AddAttachment( $attachment, $ticket_mime );
- }
- if ( $ticket_mime->parts ) {
- my $email_mime = $self->TemplateObj->MIMEObj;
- $email_mime->make_multipart;
- $email_mime->add_part($ticket_mime);
- }
- return;
-}
-
-=head2 RecordOutgoingMailTransaction MIMEObj
-
-Record a transaction in RT with this outgoing message for future record-keeping purposes
-
-=cut
-
-sub RecordOutgoingMailTransaction {
- my $self = shift;
- my $MIMEObj = shift;
-
- my @parts = $MIMEObj->parts;
- my @attachments;
- my @keep;
- foreach my $part (@parts) {
- my $attach = $part->head->get('RT-Attachment');
- if ($attach) {
- $RT::Logger->debug(
- "We found an attachment. we want to not record it.");
- push @attachments, $attach;
- } else {
- $RT::Logger->debug("We found a part. we want to record it.");
- push @keep, $part;
- }
- }
- $MIMEObj->parts( \@keep );
- foreach my $attachment (@attachments) {
- $MIMEObj->head->add( 'RT-Attachment', $attachment );
- }
-
- RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, 'utf-8', 'mime_words_ok' );
-
- my $transaction
- = RT::Transaction->new( $self->TransactionObj->CurrentUser );
-
-# XXX: TODO -> Record attachments as references to things in the attachments table, maybe.
-
- my $type;
- if ( $self->TransactionObj->Type eq 'Comment' ) {
- $type = 'CommentEmailRecord';
- } else {
- $type = 'EmailRecord';
- }
-
- my $msgid = $MIMEObj->head->get('Message-ID');
- chomp $msgid;
-
- my ( $id, $msg ) = $transaction->Create(
- Ticket => $self->TicketObj->Id,
- Type => $type,
- Data => $msgid,
- MIMEObj => $MIMEObj,
- ActivateScrips => 0
- );
-
- if ($id) {
- $self->{'OutgoingMailTransaction'} = $id;
- } else {
- $RT::Logger->warning(
- "Could not record outgoing message transaction: $msg");
- }
- return $id;
-}
-
-=head2 SetRTSpecialHeaders
-
-This routine adds all the random headers that RT wants in a mail message
-that don't matter much to anybody else.
-
-=cut
-
-sub SetRTSpecialHeaders {
- my $self = shift;
-
- $self->SetSubject();
- $self->SetSubjectToken();
- $self->SetHeaderAsEncoding( 'Subject',
- RT->Config->Get('EmailOutputEncoding') )
- if ( RT->Config->Get('EmailOutputEncoding') );
- $self->SetReturnAddress();
- $self->SetReferencesHeaders();
-
- unless ( $self->TemplateObj->MIMEObj->head->get('Message-ID') ) {
-
- # Get Message-ID for this txn
- my $msgid = "";
- if ( my $msg = $self->TransactionObj->Message->First ) {
- $msgid = $msg->GetHeader("RT-Message-ID")
- || $msg->GetHeader("Message-ID");
- }
-
- # If there is one, and we can parse it, then base our Message-ID on it
- if ( $msgid
- and $msgid
- =~ s/<(rt-.*?-\d+-\d+)\.(\d+)-\d+-\d+\@\QRT->Config->Get('Organization')\E>$/
- "<$1." . $self->TicketObj->id
- . "-" . $self->ScripObj->id
- . "-" . $self->ScripActionObj->{_Message_ID}
- . "@" . RT->Config->Get('Organization') . ">"/eg
- and $2 == $self->TicketObj->id
- )
- {
- $self->SetHeader( "Message-ID" => $msgid );
- } else {
- $self->SetHeader(
- 'Message-ID' => RT::Interface::Email::GenMessageId(
- Ticket => $self->TicketObj,
- Scrip => $self->ScripObj,
- ScripAction => $self->ScripActionObj
- ),
- );
- }
- }
-
- if (my $precedence = RT->Config->Get('DefaultMailPrecedence')
- and !$self->TemplateObj->MIMEObj->head->get("Precedence")
- ) {
- $self->SetHeader( 'Precedence', $precedence );
- }
-
- $self->SetHeader( 'X-RT-Loop-Prevention', RT->Config->Get('rtname') );
- $self->SetHeader( 'RT-Ticket',
- RT->Config->Get('rtname') . " #" . $self->TicketObj->id() );
- $self->SetHeader( 'Managed-by',
- "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
-
-# XXX, TODO: use /ShowUser/ShowUserEntry(or something like that) when it would be
-# refactored into user's method.
- if ( my $email = $self->TransactionObj->CreatorObj->EmailAddress
- and RT->Config->Get('UseOriginatorHeader')
- ) {
- $self->SetHeader( 'RT-Originator', $email );
- }
-
-}
-
-
-sub DeferDigestRecipients {
- my $self = shift;
- $RT::Logger->debug( "Calling SetRecipientDigests for transaction " . $self->TransactionObj . ", id " . $self->TransactionObj->id );
-
- # The digest attribute will be an array of notifications that need to
- # be sent for this transaction. The array will have the following
- # format for its objects.
- # $digest_hash -> {daily|weekly|susp} -> address -> {To|Cc|Bcc}
- # -> sent -> {true|false}
- # The "sent" flag will be used by the cron job to indicate that it has
- # run on this transaction.
- # In a perfect world we might move this hash construction to the
- # extension module itself.
- my $digest_hash = {};
-
- foreach my $mailfield (@EMAIL_RECIPIENT_HEADERS) {
- # If we have a "PseudoTo", the "To" contains it, so we don't need to access it
- next if ( ( $self->{'PseudoTo'} && @{ $self->{'PseudoTo'} } ) && ( $mailfield eq 'To' ) );
- $RT::Logger->debug( "Working on mailfield $mailfield; recipients are " . join( ',', @{ $self->{$mailfield} } ) );
-
- # Store the 'daily digest' folk in an array.
- my ( @send_now, @daily_digest, @weekly_digest, @suspended );
-
- # Have to get the list of addresses directly from the MIME header
- # at this point.
- $RT::Logger->debug( $self->TemplateObj->MIMEObj->head->as_string );
- foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) {
- next unless $rcpt;
- my $user_obj = RT::User->new(RT->SystemUser);
- $user_obj->LoadByEmail($rcpt);
- if ( ! $user_obj->id ) {
- # If there's an email address in here without an associated
- # RT user, pass it on through.
- $RT::Logger->debug( "User $rcpt is not associated with an RT user object. Send mail.");
- push( @send_now, $rcpt );
- next;
- }
-
- my $mailpref = RT->Config->Get( 'EmailFrequency', $user_obj ) || '';
- $RT::Logger->debug( "Got user mail preference '$mailpref' for user $rcpt");
-
- if ( $mailpref =~ /daily/i ) { push( @daily_digest, $rcpt ) }
- elsif ( $mailpref =~ /weekly/i ) { push( @weekly_digest, $rcpt ) }
- elsif ( $mailpref =~ /suspend/i ) { push( @suspended, $rcpt ) }
- else { push( @send_now, $rcpt ) }
- }
-
- # Reset the relevant mail field.
- $RT::Logger->debug( "Removing deferred recipients from $mailfield: line");
- if (@send_now) {
- $self->SetHeader( $mailfield, join( ', ', @send_now ) );
- } else { # No recipients! Remove the header.
- $self->TemplateObj->MIMEObj->head->delete($mailfield);
- }
-
- # Push the deferred addresses into the appropriate field in
- # our attribute hash, with the appropriate mail header.
- $RT::Logger->debug(
- "Setting deferred recipients for attribute creation");
- $digest_hash->{'daily'}->{$_} = {'header' => $mailfield , _sent => 0} for (@daily_digest);
- $digest_hash->{'weekly'}->{$_} ={'header' => $mailfield, _sent => 0} for (@weekly_digest);
- $digest_hash->{'susp'}->{$_} = {'header' => $mailfield, _sent =>0 } for (@suspended);
- }
-
- if ( scalar keys %$digest_hash ) {
-
- # Save the hash so that we can add it as an attribute to the
- # outgoing email transaction.
- $self->{'Deferred'} = $digest_hash;
- } else {
- $RT::Logger->debug( "No recipients found for deferred delivery on "
- . "transaction #"
- . $self->TransactionObj->id );
- }
-}
-
-
-
-sub RecordDeferredRecipients {
- my $self = shift;
- return unless exists $self->{'Deferred'};
-
- my $txn_id = $self->{'OutgoingMailTransaction'};
- return unless $txn_id;
-
- my $txn_obj = RT::Transaction->new( $self->CurrentUser );
- $txn_obj->Load( $txn_id );
- my( $ret, $msg ) = $txn_obj->AddAttribute(
- Name => 'DeferredRecipients',
- Content => $self->{'Deferred'}
- );
- $RT::Logger->warning( "Unable to add deferred recipients to outgoing transaction: $msg" )
- unless $ret;
-
- return ($ret,$msg);
-}
-
-=head2 SquelchMailTo
-
-Returns list of the addresses to squelch on this transaction.
-
-=cut
-
-sub SquelchMailTo {
- my $self = shift;
- return map $_->Content, $self->TransactionObj->SquelchMailTo;
-}
-
-=head2 RemoveInappropriateRecipients
-
-Remove addresses that are RT addresses or that are on this transaction's blacklist
-
-=cut
-
-sub RemoveInappropriateRecipients {
- my $self = shift;
-
- my @blacklist = ();
-
- # If there are no recipients, don't try to send the message.
- # If the transaction has content and has the header RT-Squelch-Replies-To
-
- my $msgid = $self->TemplateObj->MIMEObj->head->get('Message-Id');
- if ( my $attachment = $self->TransactionObj->Attachments->First ) {
-
- if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) {
-
- # What do we want to do with this? It's probably (?) a bounce
- # caused by one of the watcher addresses being broken.
- # Default ("true") is to redistribute, for historical reasons.
-
- if ( !RT->Config->Get('RedistributeAutoGeneratedMessages') ) {
-
- # Don't send to any watchers.
- @{ $self->{$_} } = () for (@EMAIL_RECIPIENT_HEADERS);
- $RT::Logger->info( $msgid
- . " The incoming message was autogenerated. "
- . "Not redistributing this message based on site configuration."
- );
- } elsif ( RT->Config->Get('RedistributeAutoGeneratedMessages') eq
- 'privileged' )
- {
-
- # Only send to "privileged" watchers.
- foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
- foreach my $addr ( @{ $self->{$type} } ) {
- my $user = RT::User->new(RT->SystemUser);
- $user->LoadByEmail($addr);
- push @blacklist, $addr unless $user->id && $user->Privileged;
- }
- }
- $RT::Logger->info( $msgid
- . " The incoming message was autogenerated. "
- . "Not redistributing this message to unprivileged users based on site configuration."
- );
- }
- }
-
- if ( my $squelch = $attachment->GetHeader('RT-Squelch-Replies-To') ) {
- push @blacklist, split( /,/, $squelch );
- }
- }
-
- # Let's grab the SquelchMailTo attributes and push those entries into the @blacklisted
- push @blacklist, map $_->Content, $self->TicketObj->SquelchMailTo, $self->TransactionObj->SquelchMailTo;
-
- # Cycle through the people we're sending to and pull out anyone on the
- # system blacklist
-
- # Trim leading and trailing spaces.
- @blacklist = map { RT::User->CanonicalizeEmailAddress( $_->address ) }
- Email::Address->parse( join ', ', grep defined, @blacklist );
-
- foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
- my @addrs;
- foreach my $addr ( @{ $self->{$type} } ) {
-
- # Weed out any RT addresses. We really don't want to talk to ourselves!
- # If we get a reply back, that means it's not an RT address
- if ( !RT::EmailParser->CullRTAddresses($addr) ) {
- $RT::Logger->info( $msgid . "$addr appears to point to this RT instance. Skipping" );
- next;
- }
- if ( grep $addr eq $_, @blacklist ) {
- $RT::Logger->info( $msgid . "$addr was blacklisted for outbound mail on this transaction. Skipping");
- next;
- }
- push @addrs, $addr;
- }
- foreach my $addr ( @{ $self->{'NoSquelch'}{$type} || [] } ) {
- # never send email to itself
- if ( !RT::EmailParser->CullRTAddresses($addr) ) {
- $RT::Logger->info( $msgid . "$addr appears to point to this RT instance. Skipping" );
- next;
- }
- push @addrs, $addr;
- }
- @{ $self->{$type} } = @addrs;
- }
-}
-
-=head2 SetReturnAddress is_comment => BOOLEAN
-
-Calculate and set From and Reply-To headers based on the is_comment flag.
-
-=cut
-
-sub SetReturnAddress {
-
- my $self = shift;
- my %args = (
- is_comment => 0,
- friendly_name => undef,
- @_
- );
-
- # From and Reply-To
- # $args{is_comment} should be set if the comment address is to be used.
- my $replyto;
-
- if ( $args{'is_comment'} ) {
- $replyto = $self->TicketObj->QueueObj->CommentAddress
- || RT->Config->Get('CommentAddress');
- } else {
- $replyto = $self->TicketObj->QueueObj->CorrespondAddress
- || RT->Config->Get('CorrespondAddress');
- }
-
- unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
- $self->SetFrom( %args, From => $replyto );
- }
-
- unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
- $self->SetHeader( 'Reply-To', "$replyto" );
- }
-
-}
-
-=head2 SetFrom ( From => emailaddress )
-
-Set the From: address for outgoing email
-
-=cut
-
-sub SetFrom {
- my $self = shift;
- my %args = @_;
-
- my $from = $args{From};
-
- if ( RT->Config->Get('UseFriendlyFromLine') ) {
- my $friendly_name = $self->GetFriendlyName(%args);
- $from =
- sprintf(
- RT->Config->Get('FriendlyFromLineFormat'),
- $self->MIMEEncodeString(
- $friendly_name, RT->Config->Get('EmailOutputEncoding')
- ),
- $args{From}
- );
- }
-
- $self->SetHeader( 'From', $from );
-
- #also set Sender:, otherwise MTAs add a nonsensical value like rt@machine,
- #and then Outlook prepends "rt@machine on behalf of" to the From: header
- $self->SetHeader( 'Sender', $from );
-}
-
-=head2 GetFriendlyName
-
-Calculate the proper Friendly Name based on the creator of the transaction
-
-=cut
-
-sub GetFriendlyName {
- my $self = shift;
- my %args = (
- is_comment => 0,
- friendly_name => '',
- @_
- );
- my $friendly_name = $args{friendly_name};
-
- unless ( $friendly_name ) {
- $friendly_name = $self->TransactionObj->CreatorObj->FriendlyName;
- if ( $friendly_name =~ /^"(.*)"$/ ) { # a quoted string
- $friendly_name = $1;
- }
- }
-
- $friendly_name =~ s/"/\\"/g;
- return $friendly_name;
-
-}
-
-=head2 SetHeader FIELD, VALUE
-
-Set the FIELD of the current MIME object into VALUE.
-
-=cut
-
-sub SetHeader {
- my $self = shift;
- my $field = shift;
- my $val = shift;
-
- chomp $val;
- chomp $field;
- my $head = $self->TemplateObj->MIMEObj->head;
- $head->fold_length( $field, 10000 );
- $head->replace( $field, $val );
- return $head->get($field);
-}
-
-=head2 SetSubject
-
-This routine sets the subject. it does not add the rt tag. That gets done elsewhere
-If subject is already defined via template, it uses that. otherwise, it tries to get
-the transaction's subject.
-
-=cut
-
-sub SetSubject {
- my $self = shift;
- my $subject;
-
- if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
- return ();
- }
-
- # don't use Transaction->Attachments because it caches
- # and anything which later calls ->Attachments will be hurt
- # by our RowsPerPage() call. caching is hard.
- my $message = RT::Attachments->new( $self->CurrentUser );
- $message->Limit( FIELD => 'TransactionId', VALUE => $self->TransactionObj->id);
- $message->OrderBy( FIELD => 'id', ORDER => 'ASC' );
- $message->RowsPerPage(1);
-
- if ( $self->{'Subject'} ) {
- $subject = $self->{'Subject'};
- } elsif ( my $first = $message->First ) {
- my $tmp = $first->GetHeader('Subject');
- $subject = defined $tmp ? $tmp : $self->TicketObj->Subject;
- } else {
- $subject = $self->TicketObj->Subject;
- }
- $subject = '' unless defined $subject;
- chomp $subject;
-
- $subject =~ s/(\r\n|\n|\s)/ /g;
-
- $self->SetHeader( 'Subject', Encode::encode_utf8( $subject ) );
-
-}
-
-=head2 SetSubjectToken
-
-This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this.
-
-=cut
-
-sub SetSubjectToken {
- my $self = shift;
-
- my $head = $self->TemplateObj->MIMEObj->head;
- $self->SetHeader(
- Subject =>
- Encode::encode_utf8(
- RT::Interface::Email::AddSubjectTag(
- Encode::decode_utf8( $head->get('Subject') ),
- $self->TicketObj,
- ),
- ),
- );
-}
-
-=head2 SetReferencesHeaders
-
-Set References and In-Reply-To headers for this message.
-
-=cut
-
-sub SetReferencesHeaders {
- my $self = shift;
-
- my $top = $self->TransactionObj->Message->First;
- unless ( $top ) {
- $self->SetHeader( References => $self->PseudoReference );
- return (undef);
- }
-
- my @in_reply_to = split( /\s+/m, $top->GetHeader('In-Reply-To') || '' );
- my @references = split( /\s+/m, $top->GetHeader('References') || '' );
- my @msgid = split( /\s+/m, $top->GetHeader('Message-ID') || '' );
-
- # There are two main cases -- this transaction was created with
- # the RT Web UI, and hence we want to *not* append its Message-ID
- # to the References and In-Reply-To. OR it came from an outside
- # source, and we should treat it as per the RFC
- my $org = RT->Config->Get('Organization');
- if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+)-0-0\@\Q$org\E>/ ) {
-
- # Make all references which are internal be to version which we
- # have sent out
-
- for ( @references, @in_reply_to ) {
- s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>$/
- "<$1." . $self->TicketObj->id .
- "-" . $self->ScripObj->id .
- "-" . $self->ScripActionObj->{_Message_ID} .
- "@" . $org . ">"/eg
- }
-
- # In reply to whatever the internal message was in reply to
- $self->SetHeader( 'In-Reply-To', join( " ", (@in_reply_to) ) );
-
- # Default the references to whatever we're in reply to
- @references = @in_reply_to unless @references;
-
- # References are unchanged from internal
- } else {
-
- # In reply to that message
- $self->SetHeader( 'In-Reply-To', join( " ", (@msgid) ) );
-
- # Default the references to whatever we're in reply to
- @references = @in_reply_to unless @references;
-
- # Push that message onto the end of the references
- push @references, @msgid;
- }
-
- # Push pseudo-ref to the front
- my $pseudo_ref = $self->PseudoReference;
- @references = ( $pseudo_ref, grep { $_ ne $pseudo_ref } @references );
-
- # If there are more than 10 references headers, remove all but the
- # first four and the last six (Gotta keep this from growing
- # forever)
- splice( @references, 4, -6 ) if ( $#references >= 10 );
-
- # Add on the references
- $self->SetHeader( 'References', join( " ", @references ) );
- $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 );
-
-}
-
-=head2 PseudoReference
-
-Returns a fake Message-ID: header for the ticket to allow a base level of threading
-
-=cut
-
-sub PseudoReference {
-
- my $self = shift;
- my $pseudo_ref
- = '<RT-Ticket-'
- . $self->TicketObj->id . '@'
- . RT->Config->Get('Organization') . '>';
- return $pseudo_ref;
-}
-
-=head2 SetHeaderAsEncoding($field_name, $charset_encoding)
-
-This routine converts the field into specified charset encoding.
-
-=cut
-
-sub SetHeaderAsEncoding {
- my $self = shift;
- my ( $field, $enc ) = ( shift, shift );
-
- my $head = $self->TemplateObj->MIMEObj->head;
-
- if ( lc($field) eq 'from' and RT->Config->Get('SMTPFrom') ) {
- $head->replace( $field, RT->Config->Get('SMTPFrom') );
- return;
- }
-
- my $value = $head->get( $field );
- $value = $self->MIMEEncodeString( $value, $enc );
- $head->replace( $field, $value );
-
-}
-
-=head2 MIMEEncodeString
-
-Takes a perl string and optional encoding pass it over
-L<RT::Interface::Email/EncodeToMIME>.
-
-Basicly encode a string using B encoding according to RFC2047.
-
-=cut
-
-sub MIMEEncodeString {
- my $self = shift;
- return RT::Interface::Email::EncodeToMIME( String => $_[0], Charset => $_[1] );
-}
-
-RT::Base->_ImportOverlays();
-
-1;
-
+++ /dev/null
-# BEGIN BPS TAGGED BLOCK {{{
-#
-# COPYRIGHT:
-#
-# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
-# <sales@bestpractical.com>
-#
-# (Except where explicitly superseded by other copyright notices)
-#
-#
-# LICENSE:
-#
-# This work is made available to you under the terms of Version 2 of
-# the GNU General Public License. A copy of that license should have
-# been provided with this software, but in any event can be snarfed
-# from www.gnu.org.
-#
-# This work is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-# 02110-1301 or visit their web page on the internet at
-# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
-#
-#
-# CONTRIBUTION SUBMISSION POLICY:
-#
-# (The following paragraph is not intended to limit the rights granted
-# to you to modify and distribute this software under the terms of
-# the GNU General Public License and is only of importance to you if
-# you choose to contribute your changes and enhancements to the
-# community by submitting them to Best Practical Solutions, LLC.)
-#
-# By intentionally submitting any modifications, corrections or
-# derivatives to this work, or any other work intended for use with
-# Request Tracker, to Best Practical Solutions, LLC, you confirm that
-# you are the copyright holder for those contributions and you grant
-# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
-# royalty-free, perpetual, license to use, copy, create derivative
-# works based on those contributions, and sublicense and distribute
-# those contributions and any derivatives thereof.
-#
-# END BPS TAGGED BLOCK }}}
-
-package RT::Interface::Email;
-
-use strict;
-use warnings;
-
-use Email::Address;
-use MIME::Entity;
-use RT::EmailParser;
-use File::Temp;
-use UNIVERSAL::require;
-use Mail::Mailer ();
-use Text::ParseWords qw/shellwords/;
-
-BEGIN {
- use base 'Exporter';
- use vars qw ( @EXPORT_OK);
-
- # set the version for version checking
- our $VERSION = 2.0;
-
- # your exported package globals go here,
- # as well as any optionally exported functions
- @EXPORT_OK = qw(
- &CreateUser
- &GetMessageContent
- &CheckForLoops
- &CheckForSuspiciousSender
- &CheckForAutoGenerated
- &CheckForBounce
- &MailError
- &ParseCcAddressesFromHead
- &ParseSenderAddressFromHead
- &ParseErrorsToAddressFromHead
- &ParseAddressFromHeader
- &Gateway);
-
-}
-
-=head1 NAME
-
- RT::Interface::Email - helper functions for parsing email sent to RT
-
-=head1 SYNOPSIS
-
- use lib "!!RT_LIB_PATH!!";
- use lib "!!RT_ETC_PATH!!";
-
- use RT::Interface::Email qw(Gateway CreateUser);
-
-=head1 DESCRIPTION
-
-
-
-
-=head1 METHODS
-
-=head2 CheckForLoops HEAD
-
-Takes a HEAD object of L<MIME::Head> class and returns true if the
-message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
-field of the head for test.
-
-=cut
-
-sub CheckForLoops {
- my $head = shift;
-
- # If this instance of RT sent it our, we don't want to take it in
- my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
- chomp ($RTLoop); # remove that newline
- if ( $RTLoop eq RT->Config->Get('rtname') ) {
- return 1;
- }
-
- # TODO: We might not trap the case where RT instance A sends a mail
- # to RT instance B which sends a mail to ...
- return undef;
-}
-
-=head2 CheckForSuspiciousSender HEAD
-
-Takes a HEAD object of L<MIME::Head> class and returns true if sender
-is suspicious. Suspicious means mailer daemon.
-
-See also L</ParseSenderAddressFromHead>.
-
-=cut
-
-sub CheckForSuspiciousSender {
- my $head = shift;
-
- #if it's from a postmaster or mailer daemon, it's likely a bounce.
-
- #TODO: better algorithms needed here - there is no standards for
- #bounces, so it's very difficult to separate them from anything
- #else. At the other hand, the Return-To address is only ment to be
- #used as an error channel, we might want to put up a separate
- #Return-To address which is treated differently.
-
- #TODO: search through the whole email and find the right Ticket ID.
-
- my ( $From, $junk ) = ParseSenderAddressFromHead($head);
-
- # If unparseable (non-ASCII), $From can come back undef
- return undef if not defined $From;
-
- if ( ( $From =~ /^mailer-daemon\@/i )
- or ( $From =~ /^postmaster\@/i )
- or ( $From eq "" ))
- {
- return (1);
-
- }
-
- return undef;
-}
-
-=head2 CheckForAutoGenerated HEAD
-
-Takes a HEAD object of L<MIME::Head> class and returns true if message
-is autogenerated. Checks 'Precedence' and 'X-FC-Machinegenerated'
-fields of the head in tests.
-
-=cut
-
-sub CheckForAutoGenerated {
- my $head = shift;
-
- my $Precedence = $head->get("Precedence") || "";
- if ( $Precedence =~ /^(bulk|junk)/i ) {
- return (1);
- }
-
- # Per RFC3834, any Auto-Submitted header which is not "no" means
- # it is auto-generated.
- my $AutoSubmitted = $head->get("Auto-Submitted") || "";
- if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
- return (1);
- }
-
- # First Class mailer uses this as a clue.
- my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
- if ( $FCJunk =~ /^true/i ) {
- return (1);
- }
-
- return (0);
-}
-
-
-sub CheckForBounce {
- my $head = shift;
-
- my $ReturnPath = $head->get("Return-path") || "";
- return ( $ReturnPath =~ /<>/ );
-}
-
-
-=head2 MailError PARAM HASH
-
-Sends an error message. Takes a param hash:
-
-=over 4
-
-=item From - sender's address, by default is 'CorrespondAddress';
-
-=item To - recipient, by default is 'OwnerEmail';
-
-=item Bcc - optional Bcc recipients;
-
-=item Subject - subject of the message, default is 'There has been an error';
-
-=item Explanation - main content of the error, default value is 'Unexplained error';
-
-=item MIMEObj - optional MIME entity that's attached to the error mail, as well we
-add 'In-Reply-To' field to the error that points to this message.
-
-=item Attach - optional text that attached to the error as 'message/rfc822' part.
-
-=item LogLevel - log level under which we should write the subject and
-explanation message into the log, by default we log it as critical.
-
-=back
-
-=cut
-
-sub MailError {
- my %args = (
- To => RT->Config->Get('OwnerEmail'),
- Bcc => undef,
- From => RT->Config->Get('CorrespondAddress'),
- Subject => 'There has been an error',
- Explanation => 'Unexplained error',
- MIMEObj => undef,
- Attach => undef,
- LogLevel => 'crit',
- @_
- );
-
- $RT::Logger->log(
- level => $args{'LogLevel'},
- message => "$args{Subject}: $args{'Explanation'}",
- ) if $args{'LogLevel'};
-
- # the colons are necessary to make ->build include non-standard headers
- my %entity_args = (
- Type => "multipart/mixed",
- From => $args{'From'},
- Bcc => $args{'Bcc'},
- To => $args{'To'},
- Subject => $args{'Subject'},
- 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
- );
-
- # only set precedence if the sysadmin wants us to
- if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
- $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence');
- }
-
- my $entity = MIME::Entity->build(%entity_args);
- SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
-
- $entity->attach( Data => $args{'Explanation'} . "\n" );
-
- if ( $args{'MIMEObj'} ) {
- $args{'MIMEObj'}->sync_headers;
- $entity->add_part( $args{'MIMEObj'} );
- }
-
- if ( $args{'Attach'} ) {
- $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' );
-
- }
-
- SendEmail( Entity => $entity, Bounce => 1 );
-}
-
-
-=head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
-
-Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
-RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
-true value, the message will be marked as an autogenerated error, if
-possible. Sets Date field of the head to now if it's not set.
-
-If the C<X-RT-Squelch> header is set to any true value, the mail will
-not be sent. One use is to let extensions easily cancel outgoing mail.
-
-Ticket and Transaction arguments are optional. If Transaction is
-specified and Ticket is not then ticket of the transaction is
-used, but only if the transaction belongs to a ticket.
-
-Returns 1 on success, 0 on error or -1 if message has no recipients
-and hasn't been sent.
-
-=head3 Signing and Encrypting
-
-This function as well signs and/or encrypts the message according to
-headers of a transaction's attachment or properties of a ticket's queue.
-To get full access to the configuration Ticket and/or Transaction
-arguments must be provided, but you can force behaviour using Sign
-and/or Encrypt arguments.
-
-The following precedence of arguments are used to figure out if
-the message should be encrypted and/or signed:
-
-* if Sign or Encrypt argument is defined then its value is used
-
-* else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
-header field then it's value is used
-
-* else properties of a queue of the Ticket are used.
-
-=cut
-
-sub WillSignEncrypt {
- my %args = @_;
- my $attachment = delete $args{Attachment};
- my $ticket = delete $args{Ticket};
-
- if ( not RT->Config->Get('GnuPG')->{'Enable'} ) {
- $args{Sign} = $args{Encrypt} = 0;
- return wantarray ? %args : 0;
- }
-
- for my $argument ( qw(Sign Encrypt) ) {
- next if defined $args{ $argument };
-
- if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) {
- $args{$argument} = $attachment->GetHeader("X-RT-$argument");
- } elsif ( $ticket and $argument eq "Encrypt" ) {
- $args{Encrypt} = $ticket->QueueObj->Encrypt();
- } elsif ( $ticket and $argument eq "Sign" ) {
- # Note that $queue->Sign is UI-only, and that all
- # UI-generated messages explicitly set the X-RT-Crypt header
- # to 0 or 1; thus this path is only taken for messages
- # generated _not_ via the web UI.
- $args{Sign} = $ticket->QueueObj->SignAuto();
- }
- }
-
- return wantarray ? %args : ($args{Sign} || $args{Encrypt});
-}
-
-sub SendEmail {
- my (%args) = (
- Entity => undef,
- Bounce => 0,
- Ticket => undef,
- Transaction => undef,
- @_,
- );
-
- my $TicketObj = $args{'Ticket'};
- my $TransactionObj = $args{'Transaction'};
-
- foreach my $arg( qw(Entity Bounce) ) {
- next unless defined $args{ lc $arg };
-
- $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead");
- $args{ $arg } = delete $args{ lc $arg };
- }
-
- unless ( $args{'Entity'} ) {
- $RT::Logger->crit( "Could not send mail without 'Entity' object" );
- return 0;
- }
-
- my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
- chomp $msgid;
-
- # If we don't have any recipients to send to, don't send a message;
- unless ( $args{'Entity'}->head->get('To')
- || $args{'Entity'}->head->get('Cc')
- || $args{'Entity'}->head->get('Bcc') )
- {
- $RT::Logger->info( $msgid . " No recipients found. Not sending." );
- return -1;
- }
-
- if ($args{'Entity'}->head->get('X-RT-Squelch')) {
- $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
- return -1;
- }
-
- if ( $TransactionObj && !$TicketObj
- && $TransactionObj->ObjectType eq 'RT::Ticket' )
- {
- $TicketObj = $TransactionObj->Object;
- }
-
- if ( RT->Config->Get('GnuPG')->{'Enable'} ) {
- %args = WillSignEncrypt(
- %args,
- Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef,
- Ticket => $TicketObj,
- );
- my $res = SignEncrypt( %args );
- return $res unless $res > 0;
- }
-
- unless ( $args{'Entity'}->head->get('Date') ) {
- require RT::Date;
- my $date = RT::Date->new( RT->SystemUser );
- $date->SetToNow;
- $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) );
- }
-
- my $mail_command = RT->Config->Get('MailCommand');
-
- if ($mail_command eq 'testfile' and not $Mail::Mailer::testfile::config{outfile}) {
- $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
- $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}");
- }
-
- # if it is a sub routine, we just return it;
- return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
-
- if ( $mail_command eq 'sendmailpipe' ) {
- my $path = RT->Config->Get('SendmailPath');
- my @args = shellwords(RT->Config->Get('SendmailArguments'));
-
- # SetOutgoingMailFrom and bounces conflict, since they both want -f
- if ( $args{'Bounce'} ) {
- push @args, shellwords(RT->Config->Get('SendmailBounceArguments'));
- } elsif ( my $MailFrom = RT->Config->Get('SetOutgoingMailFrom') ) {
- my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef;
- my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {};
-
- if ($TicketObj) {
- my $QueueName = $TicketObj->QueueObj->Name;
- my $QueueAddressOverride = $Overrides->{$QueueName};
-
- if ($QueueAddressOverride) {
- $OutgoingMailAddress = $QueueAddressOverride;
- } else {
- $OutgoingMailAddress ||= $TicketObj->QueueObj->CorrespondAddress
- || RT->Config->Get('CorrespondAddress');
- }
- }
- elsif ($Overrides->{'Default'}) {
- $OutgoingMailAddress = $Overrides->{'Default'};
- }
-
- push @args, "-f", $OutgoingMailAddress
- if $OutgoingMailAddress;
- }
-
- # VERP
- if ( $TransactionObj and
- my $prefix = RT->Config->Get('VERPPrefix') and
- my $domain = RT->Config->Get('VERPDomain') )
- {
- my $from = $TransactionObj->CreatorObj->EmailAddress;
- $from =~ s/@/=/g;
- $from =~ s/\s//g;
- push @args, "-f", "$prefix$from\@$domain";
- }
-
- eval {
- # don't ignore CHLD signal to get proper exit code
- local $SIG{'CHLD'} = 'DEFAULT';
-
- # if something wrong with $mail->print we will get PIPE signal, handle it
- local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
-
- require IPC::Open2;
- my ($mail, $stdout);
- my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args )
- or die "couldn't execute program: $!";
-
- $args{'Entity'}->print($mail);
- close $mail or die "close pipe failed: $!";
-
- waitpid($pid, 0);
- if ($?) {
- # sendmail exit statuses mostly errors with data not software
- # TODO: status parsing: core dump, exit on signal or EX_*
- my $msg = "$msgid: `$path @args` exited with code ". ($?>>8);
- $msg = ", interrupted by signal ". ($?&127) if $?&127;
- $RT::Logger->error( $msg );
- die $msg;
- }
- };
- if ( $@ ) {
- $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ );
- if ( $TicketObj ) {
- _RecordSendEmailFailure( $TicketObj );
- }
- return 0;
- }
- }
- elsif ( $mail_command eq 'smtp' ) {
- require Net::SMTP;
- my $smtp = do { local $@; eval { Net::SMTP->new(
- Host => RT->Config->Get('SMTPServer'),
- Debug => RT->Config->Get('SMTPDebug'),
- ) } };
- unless ( $smtp ) {
- $RT::Logger->crit( "Could not connect to SMTP server.");
- if ($TicketObj) {
- _RecordSendEmailFailure( $TicketObj );
- }
- return 0;
- }
-
- # duplicate head as we want drop Bcc field
- my $head = $args{'Entity'}->head->dup;
- my @recipients = map $_->address, map
- Email::Address->parse($head->get($_)), qw(To Cc Bcc);
- $head->delete('Bcc');
-
- my $sender = RT->Config->Get('SMTPFrom')
- || $args{'Entity'}->head->get('From');
- chomp $sender;
-
- my $status = $smtp->mail( $sender )
- && $smtp->recipient( @recipients );
-
- if ( $status ) {
- $smtp->data;
- my $fh = $smtp->tied_fh;
- $head->print( $fh );
- print $fh "\n";
- $args{'Entity'}->print_body( $fh );
- $smtp->dataend;
- }
- $smtp->quit;
-
- unless ( $status ) {
- $RT::Logger->crit( "$msgid: Could not send mail via SMTP." );
- if ( $TicketObj ) {
- _RecordSendEmailFailure( $TicketObj );
- }
- return 0;
- }
- }
- else {
- local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
-
- my @mailer_args = ($mail_command);
- if ( $mail_command eq 'sendmail' ) {
- $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
- push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments'));
- }
- else {
- push @mailer_args, RT->Config->Get('MailParams');
- }
-
- unless ( $args{'Entity'}->send( @mailer_args ) ) {
- $RT::Logger->crit( "$msgid: Could not send mail." );
- if ( $TicketObj ) {
- _RecordSendEmailFailure( $TicketObj );
- }
- return 0;
- }
- }
- return 1;
-}
-
-=head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
-
-Loads a template. Parses it using arguments if it's not empty.
-Returns a tuple (L<RT::Template> object, error message).
-
-Note that even if a template object is returned MIMEObj method
-may return undef for empty templates.
-
-=cut
-
-sub PrepareEmailUsingTemplate {
- my %args = (
- Template => '',
- Arguments => {},
- @_
- );
-
- my $template = RT::Template->new( RT->SystemUser );
- $template->LoadGlobalTemplate( $args{'Template'} );
- unless ( $template->id ) {
- return (undef, "Couldn't load template '". $args{'Template'} ."'");
- }
- return $template if $template->IsEmpty;
-
- my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
- return (undef, $msg) unless $status;
-
- return $template;
-}
-
-=head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
-
-Sends email using a template, takes name of template, arguments for it and recipients.
-
-=cut
-
-sub SendEmailUsingTemplate {
- my %args = (
- Template => '',
- Arguments => {},
- To => undef,
- Cc => undef,
- Bcc => undef,
- From => RT->Config->Get('CorrespondAddress'),
- InReplyTo => undef,
- ExtraHeaders => {},
- @_
- );
-
- my ($template, $msg) = PrepareEmailUsingTemplate( %args );
- return (0, $msg) unless $template;
-
- my $mail = $template->MIMEObj;
- unless ( $mail ) {
- $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
- return -1;
- }
-
- $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) )
- foreach grep defined $args{$_}, qw(To Cc Bcc From);
-
- $mail->head->set( $_ => $args{ExtraHeaders}{$_} )
- foreach keys %{ $args{ExtraHeaders} };
-
- SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
-
- return SendEmail( Entity => $mail );
-}
-
-=head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => ''
-
-Forwards transaction with all attachments as 'message/rfc822'.
-
-=cut
-
-sub ForwardTransaction {
- my $txn = shift;
- my %args = ( To => '', Cc => '', Bcc => '', @_ );
-
- my $entity = $txn->ContentAsMIME;
-
- my ( $ret, $msg ) = SendForward( %args, Entity => $entity, Transaction => $txn );
- if ($ret) {
- my $ticket = $txn->TicketObj;
- my ( $ret, $msg ) = $ticket->_NewTransaction(
- Type => 'Forward Transaction',
- Field => $txn->id,
- Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc},
- );
- unless ($ret) {
- $RT::Logger->error("Failed to create transaction: $msg");
- }
- }
- return ( $ret, $msg );
-}
-
-=head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => ''
-
-Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'.
-
-=cut
-
-sub ForwardTicket {
- my $ticket = shift;
- my %args = ( To => '', Cc => '', Bcc => '', @_ );
-
- my $txns = $ticket->Transactions;
- $txns->Limit(
- FIELD => 'Type',
- VALUE => $_,
- ) for qw(Create Correspond);
-
- my $entity = MIME::Entity->build(
- Type => 'multipart/mixed',
- Description => 'forwarded ticket',
- );
- $entity->add_part( $_ ) foreach
- map $_->ContentAsMIME,
- @{ $txns->ItemsArrayRef };
-
- my ( $ret, $msg ) = SendForward(
- %args,
- Entity => $entity,
- Ticket => $ticket,
- Template => 'Forward Ticket',
- );
-
- if ($ret) {
- my ( $ret, $msg ) = $ticket->_NewTransaction(
- Type => 'Forward Ticket',
- Field => $ticket->id,
- Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc},
- );
- unless ($ret) {
- $RT::Logger->error("Failed to create transaction: $msg");
- }
- }
-
- return ( $ret, $msg );
-
-}
-
-=head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => ''
-
-Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template.
-
-=cut
-
-sub SendForward {
- my (%args) = (
- Entity => undef,
- Ticket => undef,
- Transaction => undef,
- Template => 'Forward',
- To => '', Cc => '', Bcc => '',
- @_
- );
-
- my $txn = $args{'Transaction'};
- my $ticket = $args{'Ticket'};
- $ticket ||= $txn->Object if $txn;
-
- my $entity = $args{'Entity'};
- unless ( $entity ) {
- require Carp;
- $RT::Logger->error(Carp::longmess("No entity provided"));
- return (0, $ticket->loc("Couldn't send email"));
- }
-
- my ($template, $msg) = PrepareEmailUsingTemplate(
- Template => $args{'Template'},
- Arguments => {
- Ticket => $ticket,
- Transaction => $txn,
- },
- );
-
- my $mail;
- if ( $template ) {
- $mail = $template->MIMEObj;
- } else {
- $RT::Logger->warning($msg);
- }
- unless ( $mail ) {
- $RT::Logger->warning("Couldn't generate email using template '$args{Template}'");
-
- my $description;
- unless ( $args{'Transaction'} ) {
- $description = 'This is forward of ticket #'. $ticket->id;
- } else {
- $description = 'This is forward of transaction #'
- . $txn->id ." of a ticket #". $txn->ObjectId;
- }
- $mail = MIME::Entity->build(
- Type => 'text/plain',
- Data => $description,
- );
- }
-
- $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) )
- foreach grep defined $args{$_}, qw(To Cc Bcc);
-
- $mail->make_multipart unless $mail->is_multipart;
- $mail->add_part( $entity );
-
- my $from;
- unless (defined $mail->head->get('Subject')) {
- my $subject = '';
- $subject = $txn->Subject if $txn;
- $subject ||= $ticket->Subject if $ticket;
-
- unless ( RT->Config->Get('ForwardFromUser') ) {
- # XXX: what if want to forward txn of other object than ticket?
- $subject = AddSubjectTag( $subject, $ticket );
- }
-
- $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) );
- }
-
- $mail->head->set(
- From => EncodeToMIME(
- String => GetForwardFrom( Transaction => $txn, Ticket => $ticket )
- )
- );
-
- my $status = RT->Config->Get('ForwardFromUser')
- # never sign if we forward from User
- ? SendEmail( %args, Entity => $mail, Sign => 0 )
- : SendEmail( %args, Entity => $mail );
- return (0, $ticket->loc("Couldn't send email")) unless $status;
- return (1, $ticket->loc("Sent email successfully"));
-}
-
-=head2 GetForwardFrom Ticket => undef, Transaction => undef
-
-Resolve the From field to use in forward mail
-
-=cut
-
-sub GetForwardFrom {
- my %args = ( Ticket => undef, Transaction => undef, @_ );
- my $txn = $args{Transaction};
- my $ticket = $args{Ticket} || $txn->Object;
-
- if ( RT->Config->Get('ForwardFromUser') ) {
- return ( $txn || $ticket )->CurrentUser->EmailAddress;
- }
- else {
- return $ticket->QueueObj->CorrespondAddress
- || RT->Config->Get('CorrespondAddress');
- }
-}
-
-=head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
-
-Signs and encrypts message using L<RT::Crypt::GnuPG>, but as well
-handle errors with users' keys.
-
-If a recipient has no key or has other problems with it, then the
-unction sends a error to him using 'Error: public key' template.
-Also, notifies RT's owner using template 'Error to RT owner: public key'
-to inform that there are problems with users' keys. Then we filter
-all bad recipients and retry.
-
-Returns 1 on success, 0 on error and -1 if all recipients are bad and
-had been filtered out.
-
-=cut
-
-sub SignEncrypt {
- my %args = (
- Entity => undef,
- Sign => 0,
- Encrypt => 0,
- @_
- );
- return 1 unless $args{'Sign'} || $args{'Encrypt'};
-
- my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
- chomp $msgid;
-
- $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
- $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
-
- require RT::Crypt::GnuPG;
- my %res = RT::Crypt::GnuPG::SignEncrypt( %args );
- return 1 unless $res{'exit_code'};
-
- my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} );
-
- my @bad_recipients;
- foreach my $line ( @status ) {
- # if the passphrase fails, either you have a bad passphrase
- # or gpg-agent has died. That should get caught in Create and
- # Update, but at least throw an error here
- if (($line->{'Operation'}||'') eq 'PassphraseCheck'
- && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
- $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
- return 0;
- }
- next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
- next if $line->{'Status'} eq 'DONE';
- $RT::Logger->error( $line->{'Message'} );
- push @bad_recipients, $line;
- }
- return 0 unless @bad_recipients;
-
- $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
- foreach @bad_recipients;
-
- foreach my $recipient ( @bad_recipients ) {
- my $status = SendEmailUsingTemplate(
- To => $recipient->{'AddressObj'}->address,
- Template => 'Error: public key',
- Arguments => {
- %$recipient,
- TicketObj => $args{'Ticket'},
- TransactionObj => $args{'Transaction'},
- },
- );
- unless ( $status ) {
- $RT::Logger->error("Couldn't send 'Error: public key'");
- }
- }
-
- my $status = SendEmailUsingTemplate(
- To => RT->Config->Get('OwnerEmail'),
- Template => 'Error to RT owner: public key',
- Arguments => {
- BadRecipients => \@bad_recipients,
- TicketObj => $args{'Ticket'},
- TransactionObj => $args{'Transaction'},
- },
- );
- unless ( $status ) {
- $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
- }
-
- DeleteRecipientsFromHead(
- $args{'Entity'}->head,
- map $_->{'AddressObj'}->address, @bad_recipients
- );
-
- unless ( $args{'Entity'}->head->get('To')
- || $args{'Entity'}->head->get('Cc')
- || $args{'Entity'}->head->get('Bcc') )
- {
- $RT::Logger->debug("$msgid No recipients that have public key, not sending");
- return -1;
- }
-
- # redo without broken recipients
- %res = RT::Crypt::GnuPG::SignEncrypt( %args );
- return 0 if $res{'exit_code'};
-
- return 1;
-}
-
-use MIME::Words ();
-
-=head2 EncodeToMIME
-
-Takes a hash with a String and a Charset. Returns the string encoded
-according to RFC2047, using B (base64 based) encoding.
-
-String must be a perl string, octets are returned.
-
-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+$//;
-
- # we need perl string to split thing char by char
- Encode::_utf8_on($value) unless Encode::is_utf8($value);
-
- 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( $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 = $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 = $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->set( $field =>
- join ', ', map $_->format, grep !$skip{ lc $_->address },
- Email::Address->parse( $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 = $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 = '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>';
- push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
- }
- @references = splice @references, 4, -6
- if @references > 10;
-
- my $mail = $args{'Message'};
- $mail->head->set( 'In-Reply-To' => Encode::encode_utf8(join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
- $mail->head->set( 'References' => Encode::encode_utf8(join ' ', @references) );
-}
-
-sub ExtractTicketId {
- my $entity = shift;
-
- my $subject = $entity->head->get('Subject') || '';
- chomp $subject;
- return ParseTicketId( $subject );
-}
-
-sub ParseTicketId {
- my $Subject = shift;
-
- my $rtname = RT->Config->Get('rtname');
- my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
-
- my $id;
- if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
- $id = $1;
- } else {
- foreach my $tag ( RT->System->SubjectTag ) {
- next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i;
- $id = $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 );
-
- 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'},
- );
-
- $skip_plugin{ $class }++;
-
- my $Code = do {
- no strict 'refs';
- *{ $class . "::GetCurrentUser" }{CODE};
- };
- my ($status, $msg) = $Code->(
- Message => $Message,
- RawMessageRef => \$args{'message'},
- );
- 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 = $head->get("From");
- chomp $From if defined $From;
-
- my $MessageId = $head->get('Message-ID')
- || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
-
- #Pull apart the subject line
- my $Subject = $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 = $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';
- }
-
- #Set up a queue object
- my $SystemQueueObj = RT::Queue->new( RT->SystemUser );
- $SystemQueueObj->Load( $args{'queue'} );
-
- # 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 );
- }
-
- # 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
- );
- }
-
- $head->replace('X-RT-Interface' => 'Email');
-
- my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
- Queue => $SystemQueueObj->Id,
- Subject => $NewSubject,
- Requestor => \@Requestors,
- Cc => \@Cc,
- MIMEObj => $Message
- );
- if ( $id == 0 ) {
- MailError(
- To => $ErrorsTo,
- Subject => "Ticket creation failed: $Subject",
- Explanation => $ErrStr,
- MIMEObj => $Message
- );
- return ( 0, "Ticket creation From: $From failed: $ErrStr", $Ticket );
- }
-
- # strip comments&corresponds from the actions we don't need
- # to record them if we've created the ticket just now
- @actions = grep !/^(comment|correspond)$/, @actions;
- $args{'ticket'} = $id;
-
- } elsif ( $args{'ticket'} ) {
-
- $Ticket->Load( $args{'ticket'} );
- unless ( $Ticket->Id ) {
- my $error = "Could not find a ticket with id " . $args{'ticket'};
- MailError(
- To => $ErrorsTo,
- Subject => "Message not recorded: $Subject",
- Explanation => $error,
- MIMEObj => $Message
- );
-
- return ( 0, $error );
- }
- $args{'ticket'} = $Ticket->id;
- } else {
- return ( 1, "Success", $Ticket );
- }
-
- # }}}
-
- my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
- foreach my $action (@actions) {
-
- # If the action is comment, add a comment.
- if ( $action =~ /^(?:comment|correspond)$/i ) {
- my $method = ucfirst lc $action;
- my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
- unless ($status) {
-
- #Warn the sender that we couldn't actually submit the comment.
- MailError(
- To => $ErrorsTo,
- Subject => "Message not recorded ($method): $Subject",
- Explanation => $msg,
- MIMEObj => $Message
- );
- return ( 0, "Message From: $From not recorded: $msg", $Ticket );
- }
- } elsif ($unsafe_actions) {
- my ( $status, $msg ) = _RunUnsafeAction(
- Action => $action,
- ErrorsTo => $ErrorsTo,
- Message => $Message,
- Ticket => $Ticket,
- CurrentUser => $CurrentUser,
- );
- return ($status, $msg, $Ticket) unless $status == 1;
- }
- }
- return ( 1, "Success", $Ticket );
-}
-
-=head2 GetAuthenticationLevel
-
- # Authentication Level
- # -1 - Get out. this user has been explicitly declined
- # 0 - User may not do anything (Not used at the moment)
- # 1 - Normal user
- # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
-
-=cut
-
-sub GetAuthenticationLevel {
- my %args = (
- MailPlugins => [],
- Actions => [],
- Message => undef,
- RawMessageRef => undef,
- SystemTicket => undef,
- SystemQueue => undef,
- @_,
- );
-
- my ( $CurrentUser, $AuthStat, $error );
-
- # Initalize AuthStat so comparisons work correctly
- $AuthStat = -9999999;
-
- # if plugin returns AuthStat -2 we skip action
- # NOTE: this is experimental API and it would be changed
- my %skip_action = ();
-
- # Since this needs loading, no matter what
- foreach (@{ $args{MailPlugins} }) {
- my ($Code, $NewAuthStat);
- if ( ref($_) eq "CODE" ) {
- $Code = $_;
- } else {
- no strict 'refs';
- $Code = *{ $_ . "::GetCurrentUser" }{CODE};
- }
-
- foreach my $action (@{ $args{Actions} }) {
- ( $CurrentUser, $NewAuthStat ) = $Code->(
- Message => $args{Message},
- RawMessageRef => $args{RawMessageRef},
- CurrentUser => $CurrentUser,
- AuthLevel => $AuthStat,
- Action => $action,
- Ticket => $args{SystemTicket},
- Queue => $args{SystemQueue},
- );
-
-# You get the highest level of authentication you were assigned, unless you get the magic -1
-# If a module returns a "-1" then we discard the ticket, so.
- $AuthStat = $NewAuthStat
- if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
-
- last if $AuthStat == -1;
- $skip_action{$action}++ if $AuthStat == -2;
- }
-
- # strip actions we should skip
- @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
- if $AuthStat == -2;
- last unless @{$args{Actions}};
-
- last if $AuthStat == -1;
- }
-
- return $AuthStat if !wantarray;
-
- return ($AuthStat, $CurrentUser, $error);
-}
-
-sub _RunUnsafeAction {
- my %args = (
- Action => undef,
- ErrorsTo => undef,
- Message => undef,
- Ticket => undef,
- CurrentUser => undef,
- @_
- );
-
- my $From = $args{Message}->head->get("From");
-
- if ( $args{'Action'} =~ /^take$/i ) {
- my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
- unless ($status) {
- MailError(
- To => $args{'ErrorsTo'},
- Subject => "Ticket not taken",
- Explanation => $msg,
- MIMEObj => $args{'Message'}
- );
- return ( 0, "Ticket not taken, by email From: $From" );
- }
- } elsif ( $args{'Action'} =~ /^resolve$/i ) {
- my $new_status = $args{'Ticket'}->FirstInactiveStatus;
- if ($new_status) {
- my ( $status, $msg ) = $args{'Ticket'}->SetStatus($new_status);
- unless ($status) {
-
- #Warn the sender that we couldn't actually submit the comment.
- MailError(
- To => $args{'ErrorsTo'},
- Subject => "Ticket not resolved",
- Explanation => $msg,
- MIMEObj => $args{'Message'}
- );
- return ( 0, "Ticket not resolved, by email From: $From" );
- }
- }
- } else {
- return ( 0, "Not supported unsafe action $args{'Action'}, by email From: $From", $args{'Ticket'} );
- }
- return ( 1, "Success" );
-}
-
-=head2 _NoAuthorizedUserFound
-
-Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
-
-=cut
-
-sub _NoAuthorizedUserFound {
- my %args = (
- Right => undef,
- Message => undef,
- Requestor => undef,
- Queue => undef,
- @_
- );
-
- # Notify the RT Admin of the failure.
- MailError(
- To => RT->Config->Get('OwnerEmail'),
- Subject => "Could not load a valid user",
- Explanation => <<EOT,
-RT could not load a valid user, and RT's configuration does not allow
-for the creation of a new user for this email (@{[$args{Requestor}]}).
-
-You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
-queue @{[$args{'Queue'}]}.
-
-EOT
- MIMEObj => $args{'Message'},
- LogLevel => 'error'
- );
-
- # Also notify the requestor that his request has been dropped.
- if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
- MailError(
- To => $args{'Requestor'},
- Subject => "Could not load a valid user",
- Explanation => <<EOT,
-RT could not load a valid user, and RT's configuration does not allow
-for the creation of a new user for your email.
-
-EOT
- MIMEObj => $args{'Message'},
- LogLevel => 'error'
- );
- }
-}
-
-=head2 _HandleMachineGeneratedMail
-
-Takes named params:
- Message
- ErrorsTo
- Subject
-
-Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
-Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
-"This message appears to be a loop (boolean)" );
-
-=cut
-
-sub _HandleMachineGeneratedMail {
- my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
- my $head = $args{'Message'}->head;
- my $ErrorsTo = $args{'ErrorsTo'};
-
- my $IsBounce = CheckForBounce($head);
-
- my $IsAutoGenerated = CheckForAutoGenerated($head);
-
- my $IsSuspiciousSender = CheckForSuspiciousSender($head);
-
- my $IsALoop = CheckForLoops($head);
-
- my $SquelchReplies = 0;
-
- my $owner_mail = RT->Config->Get('OwnerEmail');
-
- #If the message is autogenerated, we need to know, so we can not
- # send mail to the sender
- if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
- $SquelchReplies = 1;
- $ErrorsTo = $owner_mail;
- }
-
- # Warn someone if it's a loop, before we drop it on the ground
- if ($IsALoop) {
- $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
-
- #Should we mail it to RTOwner?
- if ( RT->Config->Get('LoopsToRTOwner') ) {
- MailError(
- To => $owner_mail,
- Subject => "RT Bounce: ".$args{'Subject'},
- Explanation => "RT thinks this message may be a bounce",
- MIMEObj => $args{Message}
- );
- }
-
- #Do we actually want to store it?
- return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
- unless RT->Config->Get('StoreLoops');
- }
-
- # Squelch replies if necessary
- # Don't let the user stuff the RT-Squelch-Replies-To header.
- if ( $head->get('RT-Squelch-Replies-To') ) {
- $head->replace(
- 'RT-Relocated-Squelch-Replies-To',
- $head->get('RT-Squelch-Replies-To')
- );
- $head->delete('RT-Squelch-Replies-To');
- }
-
- if ($SquelchReplies) {
-
- # Squelch replies to the sender, and also leave a clue to
- # allow us to squelch ALL outbound messages. This way we
- # can punt the logic of "what to do when we get a bounce"
- # to the scrip. We might want to notify nobody. Or just
- # the RT Owner. Or maybe all Privileged watchers.
- my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
- $head->replace( 'RT-Squelch-Replies-To', $Sender );
- $head->replace( 'RT-DetectedAutoGenerated', 'true' );
- }
- return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
-}
-
-=head2 IsCorrectAction
-
-Returns a list of valid actions we've found for this message
-
-=cut
-
-sub IsCorrectAction {
- my $action = shift;
- my @actions = grep $_, split /-/, $action;
- return ( 0, '(no value)' ) unless @actions;
- foreach ( @actions ) {
- return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
- }
- return ( 1, @actions );
-}
-
-sub _RecordSendEmailFailure {
- my $ticket = shift;
- if ($ticket) {
- $ticket->_RecordNote(
- NoteType => 'SystemError',
- Content => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.",
- );
- return 1;
- }
- else {
- $RT::Logger->error( "Can't record send email failure as ticket is missing" );
- return;
- }
-}
-
-RT::Base->_ImportOverlays();
-
-1;
+++ /dev/null
-# BEGIN BPS TAGGED BLOCK {{{
-#
-# COPYRIGHT:
-#
-# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
-# <sales@bestpractical.com>
-#
-# (Except where explicitly superseded by other copyright notices)
-#
-#
-# LICENSE:
-#
-# This work is made available to you under the terms of Version 2 of
-# the GNU General Public License. A copy of that license should have
-# been provided with this software, but in any event can be snarfed
-# from www.gnu.org.
-#
-# This work is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-# 02110-1301 or visit their web page on the internet at
-# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
-#
-#
-# CONTRIBUTION SUBMISSION POLICY:
-#
-# (The following paragraph is not intended to limit the rights granted
-# to you to modify and distribute this software under the terms of
-# the GNU General Public License and is only of importance to you if
-# you choose to contribute your changes and enhancements to the
-# community by submitting them to Best Practical Solutions, LLC.)
-#
-# By intentionally submitting any modifications, corrections or
-# derivatives to this work, or any other work intended for use with
-# Request Tracker, to Best Practical Solutions, LLC, you confirm that
-# you are the copyright holder for those contributions and you grant
-# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
-# royalty-free, perpetual, license to use, copy, create derivative
-# works based on those contributions, and sublicense and distribute
-# those contributions and any derivatives thereof.
-#
-# END BPS TAGGED BLOCK }}}
-
-## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
-
-## This is a library of static subs to be used by the Mason web
-## interface to RT
-
-=head1 NAME
-
-RT::Interface::Web
-
-
-=cut
-
-use strict;
-use warnings;
-
-package RT::Interface::Web;
-
-use RT::SavedSearches;
-use URI qw();
-use RT::Interface::Web::Menu;
-use RT::Interface::Web::Session;
-use Digest::MD5 ();
-use Encode qw();
-use List::MoreUtils qw();
-use JSON qw();
-
-=head2 SquishedCSS $style
-
-=cut
-
-my %SQUISHED_CSS;
-sub SquishedCSS {
- my $style = shift or die "need name";
- return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
- require RT::Squish::CSS;
- my $css = RT::Squish::CSS->new( Style => $style );
- $SQUISHED_CSS{ $css->Style } = $css;
- return $css;
-}
-
-=head2 SquishedJS
-
-=cut
-
-my $SQUISHED_JS;
-sub SquishedJS {
- return $SQUISHED_JS if $SQUISHED_JS;
-
- require RT::Squish::JS;
- my $js = RT::Squish::JS->new();
- $SQUISHED_JS = $js;
- return $js;
-}
-
-=head2 ClearSquished
-
-Removes the cached CSS and JS entries, forcing them to be regenerated
-on next use.
-
-=cut
-
-sub ClearSquished {
- undef $SQUISHED_JS;
- %SQUISHED_CSS = ();
-}
-
-=head2 EscapeUTF8 SCALARREF
-
-does a css-busting but minimalist escaping of whatever html you're passing in.
-
-=cut
-
-sub EscapeUTF8 {
- my $ref = shift;
- return unless defined $$ref;
-
- $$ref =~ s/&/&/g;
- $$ref =~ s/</</g;
- $$ref =~ s/>/>/g;
- $$ref =~ s/\(/(/g;
- $$ref =~ s/\)/)/g;
- $$ref =~ s/"/"/g;
- $$ref =~ s/'/'/g;
-}
-
-
-
-=head2 EscapeURI SCALARREF
-
-Escapes URI component according to RFC2396
-
-=cut
-
-sub EscapeURI {
- my $ref = shift;
- return unless defined $$ref;
-
- use bytes;
- $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
-}
-
-=head2 EncodeJSON SCALAR
-
-Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple
-value or a reference.
-
-=cut
-
-sub EncodeJSON {
- JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 });
-}
-
-sub _encode_surrogates {
- my $uni = $_[0] - 0x10000;
- return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
-}
-
-sub EscapeJS {
- my $ref = shift;
- return unless defined $$ref;
-
- $$ref = "'" . join('',
- map {
- chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
- $_ <= 255 ? sprintf("\\x%02X", $_) :
- $_ <= 65535 ? sprintf("\\u%04X", $_) :
- sprintf("\\u%X\\u%X", _encode_surrogates($_))
- } unpack('U*', $$ref))
- . "'";
-}
-
-=head2 WebCanonicalizeInfo();
-
-Different web servers set different environmental varibles. This
-function must return something suitable for REMOTE_USER. By default,
-just downcase $ENV{'REMOTE_USER'}
-
-=cut
-
-sub WebCanonicalizeInfo {
- return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
-}
-
-
-
-=head2 WebExternalAutoInfo($user);
-
-Returns a hash of user attributes, used when WebExternalAuto is set.
-
-=cut
-
-sub WebExternalAutoInfo {
- my $user = shift;
-
- my %user_info;
-
- # default to making Privileged users, even if they specify
- # some other default Attributes
- if ( !$RT::AutoCreate
- || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
- {
- $user_info{'Privileged'} = 1;
- }
-
- if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
-
- # Populate fields with information from Unix /etc/passwd
-
- my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
- $user_info{'Comments'} = $comments if defined $comments;
- $user_info{'RealName'} = $realname if defined $realname;
- } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
-
- # Populate fields with information from NT domain controller
- }
-
- # and return the wad of stuff
- return {%user_info};
-}
-
-
-sub HandleRequest {
- my $ARGS = shift;
-
- if (RT->Config->Get('DevelMode')) {
- require Module::Refresh;
- Module::Refresh->refresh;
- }
-
- $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
-
- $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
-
- # Roll back any dangling transactions from a previous failed connection
- $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
-
- MaybeEnableSQLStatementLog();
-
- # avoid reentrancy, as suggested by masonbook
- local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
-
- $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
- if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
-
- ValidateWebConfig();
-
- DecodeARGS($ARGS);
- local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
- PreprocessTimeUpdates($ARGS);
-
- InitializeMenu();
- MaybeShowInstallModePage();
-
- $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
- SendSessionCookie();
-
- if ( _UserLoggedIn() ) {
- # make user info up to date
- $HTML::Mason::Commands::session{'CurrentUser'}
- ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
- undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
- }
- else {
- $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
- }
-
- # Process session-related callbacks before any auth attempts
- $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
-
- MaybeRejectPrivateComponentRequest();
-
- MaybeShowNoAuthPage($ARGS);
-
- AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
-
- _ForceLogout() unless _UserLoggedIn();
-
- # Process per-page authentication callbacks
- $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
-
- if ( $ARGS->{'NotMobile'} ) {
- $HTML::Mason::Commands::session{'NotMobile'} = 1;
- }
-
- unless ( _UserLoggedIn() ) {
- _ForceLogout();
-
- # Authenticate if the user is trying to login via user/pass query args
- my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
-
- unless ($authed) {
- my $m = $HTML::Mason::Commands::m;
-
- # REST urls get a special 401 response
- if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
- $HTML::Mason::Commands::r->content_type("text/plain");
- $m->error_format("text");
- $m->out("RT/$RT::VERSION 401 Credentials required\n");
- $m->out("\n$msg\n") if $msg;
- $m->abort;
- }
- # Specially handle /index.html and /m/index.html so that we get a nicer URL
- elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
- my $mobile = $1 ? 1 : 0;
- my $next = SetNextPage($ARGS);
- $m->comp('/NoAuth/Login.html',
- next => $next,
- actions => [$msg],
- mobile => $mobile);
- $m->abort;
- }
- else {
- TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
- }
- }
- }
-
- MaybeShowInterstitialCSRFPage($ARGS);
-
- # now it applies not only to home page, but any dashboard that can be used as a workspace
- $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
- if ( $ARGS->{'HomeRefreshInterval'} );
-
- # Process per-page global callbacks
- $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
-
- ShowRequestedPage($ARGS);
- LogRecordedSQLStatements(RequestData => {
- Path => $HTML::Mason::Commands::m->request_path,
- });
-
- # Process per-page final cleanup callbacks
- $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
-
- $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
- unless $HTML::Mason::Commands::r->content_type
- =~ qr<^(text|application)/(x-)?(css|javascript)>;
-}
-
-sub _ForceLogout {
-
- delete $HTML::Mason::Commands::session{'CurrentUser'};
-}
-
-sub _UserLoggedIn {
- if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
- return 1;
- } else {
- return undef;
- }
-
-}
-
-=head2 LoginError ERROR
-
-Pushes a login error into the Actions session store and returns the hash key.
-
-=cut
-
-sub LoginError {
- my $new = shift;
- my $key = Digest::MD5::md5_hex( rand(1024) );
- push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
- $HTML::Mason::Commands::session{'i'}++;
- return $key;
-}
-
-=head2 SetNextPage ARGSRef [PATH]
-
-Intuits and stashes the next page in the sesssion hash. If PATH is
-specified, uses that instead of the value of L<IntuitNextPage()>. Returns
-the hash value.
-
-=cut
-
-sub SetNextPage {
- my $ARGS = shift;
- my $next = $_[0] ? $_[0] : IntuitNextPage();
- my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
- my $page = { url => $next };
-
- # If an explicit URL was passed and we didn't IntuitNextPage, then
- # IsPossibleCSRF below is almost certainly unrelated to the actual
- # destination. Currently explicit next pages aren't used in RT, but the
- # API is available.
- if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
- # This isn't really CSRF, but the CSRF heuristics are useful for catching
- # requests which may have unintended side-effects.
- my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
- if ($is_csrf) {
- RT->Logger->notice(
- "Marking original destination as having side-effects before redirecting for login.\n"
- ."Request: $next\n"
- ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
- );
- $page->{'HasSideEffects'} = [$msg, @loc];
- }
- }
-
- $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
- $HTML::Mason::Commands::session{'i'}++;
- return $hash;
-}
-
-=head2 FetchNextPage HASHKEY
-
-Returns the stashed next page hashref for the given hash.
-
-=cut
-
-sub FetchNextPage {
- my $hash = shift || "";
- return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
-}
-
-=head2 RemoveNextPage HASHKEY
-
-Removes the stashed next page for the given hash and returns it.
-
-=cut
-
-sub RemoveNextPage {
- my $hash = shift || "";
- return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
-}
-
-=head2 TangentForLogin ARGSRef [HASH]
-
-Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
-the next page. Takes a hashref of request %ARGS as the first parameter.
-Optionally takes all other parameters as a hash which is dumped into query
-params.
-
-=cut
-
-sub TangentForLogin {
- my $ARGS = shift;
- my $hash = SetNextPage($ARGS);
- my %query = (@_, next => $hash);
-
- $query{mobile} = 1
- if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
-
- my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
- $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
- Redirect($login);
-}
-
-=head2 TangentForLoginWithError ERROR
-
-Localizes the passed error message, stashes it with L<LoginError> and then
-calls L<TangentForLogin> with the appropriate results key.
-
-=cut
-
-sub TangentForLoginWithError {
- my $ARGS = shift;
- my $key = LoginError(HTML::Mason::Commands::loc(@_));
- TangentForLogin( $ARGS, results => $key );
-}
-
-=head2 IntuitNextPage
-
-Attempt to figure out the path to which we should return the user after a
-tangent. The current request URL is used, or failing that, the C<WebURL>
-configuration variable.
-
-=cut
-
-sub IntuitNextPage {
- my $req_uri;
-
- # This includes any query parameters. Redirect will take care of making
- # it an absolute URL.
- if ($ENV{'REQUEST_URI'}) {
- $req_uri = $ENV{'REQUEST_URI'};
-
- # collapse multiple leading slashes so the first part doesn't look like
- # a hostname of a schema-less URI
- $req_uri =~ s{^/+}{/};
- }
-
- my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
-
- # sanitize $next
- my $uri = URI->new($next);
-
- # You get undef scheme with a relative uri like "/Search/Build.html"
- unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
- $next = RT->Config->Get('WebURL');
- }
-
- # Make sure we're logging in to the same domain
- # You can get an undef authority with a relative uri like "index.html"
- my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
- unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
- $next = RT->Config->Get('WebURL');
- }
-
- return $next;
-}
-
-=head2 MaybeShowInstallModePage
-
-This function, called exclusively by RT's autohandler, dispatches
-a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
-
-If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
-
-=cut
-
-sub MaybeShowInstallModePage {
- return unless RT->InstallMode;
-
- my $m = $HTML::Mason::Commands::m;
- if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
- $m->call_next();
- } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
- RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
- } else {
- $m->call_next();
- }
- $m->abort();
-}
-
-=head2 MaybeShowNoAuthPage \%ARGS
-
-This function, called exclusively by RT's autohandler, dispatches
-a request to the page a user requested (but only if it matches the "noauth" regex.
-
-If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
-
-=cut
-
-sub MaybeShowNoAuthPage {
- my $ARGS = shift;
-
- my $m = $HTML::Mason::Commands::m;
-
- return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
-
- # Don't show the login page to logged in users
- Redirect(RT->Config->Get('WebURL'))
- if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
-
- # If it's a noauth file, don't ask for auth.
- $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
- $m->abort;
-}
-
-=head2 MaybeRejectPrivateComponentRequest
-
-This function will reject calls to private components, like those under
-C</Elements>. If the requested path is a private component then we will
-abort with a C<403> error.
-
-=cut
-
-sub MaybeRejectPrivateComponentRequest {
- my $m = $HTML::Mason::Commands::m;
- my $path = $m->request_comp->path;
-
- # We do not check for dhandler here, because requesting our dhandlers
- # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
- # 'dhandler'.
-
- if ($path =~ m{
- / # leading slash
- ( Elements |
- _elements | # mobile UI
- Callbacks |
- Widgets |
- autohandler | # requesting this directly is suspicious
- l (_unsafe)? ) # loc component
- ( $ | / ) # trailing slash or end of path
- }xi
- && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
- )
- {
- warn "rejecting private component $path\n";
- $m->abort(403);
- }
-
- return;
-}
-
-sub InitializeMenu {
- $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
- $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
- $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
-
-}
-
-
-=head2 ShowRequestedPage \%ARGS
-
-This function, called exclusively by RT's autohandler, dispatches
-a request to the page a user requested (making sure that unpriviled users
-can only see self-service pages.
-
-=cut
-
-sub ShowRequestedPage {
- my $ARGS = shift;
-
- my $m = $HTML::Mason::Commands::m;
-
- # Ensure that the cookie that we send is up-to-date, in case the
- # session-id has been modified in any way
- SendSessionCookie();
-
- # precache all system level rights for the current user
- $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
-
- # If the user isn't privileged, they can only see SelfService
- unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
-
- # if the user is trying to access a ticket, redirect them
- if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
- RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
- }
-
- # otherwise, drop the user at the SelfService default page
- elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
- RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
- }
-
- # if user is in SelfService dir let him do anything
- else {
- $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
- }
- } else {
- $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
- }
-
-}
-
-sub AttemptExternalAuth {
- my $ARGS = shift;
-
- return unless ( RT->Config->Get('WebExternalAuth') );
-
- my $user = $ARGS->{user};
- my $m = $HTML::Mason::Commands::m;
-
- # If RT is configured for external auth, let's go through and get REMOTE_USER
-
- # do we actually have a REMOTE_USER equivlent?
- if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
- my $orig_user = $user;
-
- $user = RT::Interface::Web::WebCanonicalizeInfo();
- my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
-
- if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
- my $NodeName = Win32::NodeName();
- $user =~ s/^\Q$NodeName\E\\//i;
- }
-
- my $next = RemoveNextPage($ARGS->{'next'});
- $next = $next->{'url'} if ref $next;
- InstantiateNewSession() unless _UserLoggedIn;
- $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
- $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
-
- if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
-
- # Create users on-the-fly
- my $UserObj = RT::User->new(RT->SystemUser);
- my ( $val, $msg ) = $UserObj->Create(
- %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
- Name => $user,
- Gecos => $user,
- );
-
- if ($val) {
-
- # now get user specific information, to better create our user.
- my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
-
- # set the attributes that have been defined.
- foreach my $attribute ( $UserObj->WritableAttributes ) {
- $m->callback(
- Attribute => $attribute,
- User => $user,
- UserInfo => $new_user_info,
- CallbackName => 'NewUser',
- CallbackPage => '/autohandler'
- );
- my $method = "Set$attribute";
- $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
- }
- $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
- } else {
-
- # we failed to successfully create the user. abort abort abort.
- delete $HTML::Mason::Commands::session{'CurrentUser'};
-
- if (RT->Config->Get('WebFallbackToInternalAuth')) {
- TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
- } else {
- $m->abort();
- }
- }
- }
-
- if ( _UserLoggedIn() ) {
- $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
- # It is possible that we did a redirect to the login page,
- # if the external auth allows lack of auth through with no
- # REMOTE_USER set, instead of forcing a "permission
- # denied" message. Honor the $next.
- Redirect($next) if $next;
- # Unlike AttemptPasswordAuthentication below, we do not
- # force a redirect to / if $next is not set -- otherwise,
- # straight-up external auth would always redirect to /
- # when you first hit it.
- } else {
- delete $HTML::Mason::Commands::session{'CurrentUser'};
- $user = $orig_user;
-
- unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
- TangentForLoginWithError($ARGS, 'You are not an authorized user');
- }
- }
- } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
- unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
- # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
- TangentForLoginWithError($ARGS, 'You are not an authorized user');
- }
- } else {
-
- # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
- # XXX: we must return AUTH_REQUIRED status or we fallback to
- # internal auth here too.
- delete $HTML::Mason::Commands::session{'CurrentUser'}
- if defined $HTML::Mason::Commands::session{'CurrentUser'};
- }
-}
-
-sub AttemptPasswordAuthentication {
- my $ARGS = shift;
- return unless defined $ARGS->{user} && defined $ARGS->{pass};
-
- my $user_obj = RT::CurrentUser->new();
- $user_obj->Load( $ARGS->{user} );
-
- my $m = $HTML::Mason::Commands::m;
-
- unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
- $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
- $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
- return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
- }
- else {
- $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
-
- # It's important to nab the next page from the session before we blow
- # the session away
- my $next = RemoveNextPage($ARGS->{'next'});
- $next = $next->{'url'} if ref $next;
-
- InstantiateNewSession();
- $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
-
- $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
-
- # Really the only time we don't want to redirect here is if we were
- # passed user and pass as query params in the URL.
- if ($next) {
- Redirect($next);
- }
- elsif ($ARGS->{'next'}) {
- # Invalid hash, but still wants to go somewhere, take them to /
- Redirect(RT->Config->Get('WebURL'));
- }
-
- return (1, HTML::Mason::Commands::loc('Logged in'));
- }
-}
-
-=head2 LoadSessionFromCookie
-
-Load or setup a session cookie for the current user.
-
-=cut
-
-sub _SessionCookieName {
- my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
- $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
- return $cookiename;
-}
-
-sub LoadSessionFromCookie {
-
- my %cookies = CGI::Cookie->fetch;
- my $cookiename = _SessionCookieName();
- my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
- tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
- unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
- InstantiateNewSession();
- }
- if ( int RT->Config->Get('AutoLogoff') ) {
- my $now = int( time / 60 );
- my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
-
- if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
- InstantiateNewSession();
- }
-
- # save session on each request when AutoLogoff is turned on
- $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
- }
-}
-
-sub InstantiateNewSession {
- tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
- tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
- SendSessionCookie();
-}
-
-sub SendSessionCookie {
- my $cookie = CGI::Cookie->new(
- -name => _SessionCookieName(),
- -value => $HTML::Mason::Commands::session{_session_id},
- -path => RT->Config->Get('WebPath'),
- -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
- -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
- );
-
- $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
-}
-
-=head2 Redirect URL
-
-This routine ells the current user's browser to redirect to URL.
-Additionally, it unties the user's currently active session, helping to avoid
-A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
-a cached DBI statement handle twice at the same time.
-
-=cut
-
-sub Redirect {
- my $redir_to = shift;
- untie $HTML::Mason::Commands::session;
- my $uri = URI->new($redir_to);
- my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
-
- # Make relative URIs absolute from the server host and scheme
- $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
- if (not defined $uri->host) {
- $uri->host($server_uri->host);
- $uri->port($server_uri->port);
- }
-
- # If the user is coming in via a non-canonical
- # hostname, don't redirect them to the canonical host,
- # it will just upset them (and invalidate their credentials)
- # don't do this if $RT::CanonicalizeRedirectURLs is true
- if ( !RT->Config->Get('CanonicalizeRedirectURLs')
- && $uri->host eq $server_uri->host
- && $uri->port eq $server_uri->port )
- {
- if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
- $uri->scheme('https');
- } else {
- $uri->scheme('http');
- }
-
- # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
- $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
- $uri->port( $ENV{'SERVER_PORT'} );
- }
-
- # not sure why, but on some systems without this call mason doesn't
- # set status to 302, but 200 instead and people see blank pages
- $HTML::Mason::Commands::r->status(302);
-
- # Perlbal expects a status message, but Mason's default redirect status
- # doesn't provide one. See also rt.cpan.org #36689.
- $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
-
- $HTML::Mason::Commands::m->abort;
-}
-
-=head2 CacheControlExpiresHeaders
-
-set both Cache-Control and Expires http headers
-
-=cut
-
-sub CacheControlExpiresHeaders {
- my %args = @_;
-
- my $Visibility = 'private';
- if ( ! defined $args{Time} ) {
- $args{Time} = 0;
- } elsif ( $args{Time} eq 'no-cache' ) {
- $args{Time} = 0;
- } elsif ( $args{Time} eq 'forever' ) {
- $args{Time} = 30 * 24 * 60 * 60;
- $Visibility = 'public';
- }
-
- my $CacheControl = $args{Time}
- ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
- : 'no-cache'
- ;
- $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl;
-
- my $expires = RT::Date->new(RT->SystemUser);
- $expires->SetToNow;
- $expires->AddSeconds( $args{Time} ) if $args{Time};
-
- $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616;
-}
-
-=head2 StaticFileHeaders
-
-Send the browser a few headers to try to get it to (somewhat agressively)
-cache RT's static Javascript and CSS files.
-
-This routine could really use _accurate_ heuristics. (XXX TODO)
-
-=cut
-
-sub StaticFileHeaders {
- my $date = RT::Date->new(RT->SystemUser);
-
- # remove any cookie headers -- if it is cached publicly, it
- # shouldn't include anyone's cookie!
- delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
-
- # Expire things in a month.
- CacheControlExpiresHeaders( Time => 'forever' );
-
- # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
- # request, but we don't handle it and generate full reply again
- # Last modified at server start time
- # $date->Set( Value => $^T );
- # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
-}
-
-=head2 ComponentPathIsSafe PATH
-
-Takes C<PATH> and returns a boolean indicating that the user-specified partial
-component path is safe.
-
-Currently "safe" means that the path does not start with a dot (C<.>), does
-not contain a slash-dot C</.>, and does not contain any nulls.
-
-=cut
-
-sub ComponentPathIsSafe {
- my $self = shift;
- my $path = shift;
- return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
-}
-
-=head2 PathIsSafe
-
-Takes a C<< Path => path >> and returns a boolean indicating that
-the path is safely within RT's control or not. The path I<must> be
-relative.
-
-This function does not consult the filesystem at all; it is merely
-a logical sanity checking of the path. This explicitly does not handle
-symlinks; if you have symlinks in RT's webroot pointing outside of it,
-then we assume you know what you are doing.
-
-=cut
-
-sub PathIsSafe {
- my $self = shift;
- my %args = @_;
- my $path = $args{Path};
-
- # Get File::Spec to clean up extra /s, ./, etc
- my $cleaned_up = File::Spec->canonpath($path);
-
- if (!defined($cleaned_up)) {
- $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
- return 0;
- }
-
- # Forbid too many ..s. We can't just sum then check because
- # "../foo/bar/baz" should be illegal even though it has more
- # downdirs than updirs. So as soon as we get a negative score
- # (which means "breaking out" of the top level) we reject the path.
-
- my @components = split '/', $cleaned_up;
- my $score = 0;
- for my $component (@components) {
- if ($component eq '..') {
- $score--;
- if ($score < 0) {
- $RT::Logger->info("Rejecting unsafe path: $path");
- return 0;
- }
- }
- elsif ($component eq '.' || $component eq '') {
- # these two have no effect on $score
- }
- else {
- $score++;
- }
- }
-
- return 1;
-}
-
-=head2 SendStaticFile
-
-Takes a File => path and a Type => Content-type
-
-If Type isn't provided and File is an image, it will
-figure out a sane Content-type, otherwise it will
-send application/octet-stream
-
-Will set caching headers using StaticFileHeaders
-
-=cut
-
-sub SendStaticFile {
- my $self = shift;
- my %args = @_;
- my $file = $args{File};
- my $type = $args{Type};
- my $relfile = $args{RelativeFile};
-
- if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
- $HTML::Mason::Commands::r->status(400);
- $HTML::Mason::Commands::m->abort;
- }
-
- $self->StaticFileHeaders();
-
- unless ($type) {
- if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
- $type = "image/$1";
- $type =~ s/jpg/jpeg/gi;
- }
- $type ||= "application/octet-stream";
- }
- $HTML::Mason::Commands::r->content_type($type);
- open( my $fh, '<', $file ) or die "couldn't open file: $!";
- binmode($fh);
- {
- local $/ = \16384;
- $HTML::Mason::Commands::m->out($_) while (<$fh>);
- $HTML::Mason::Commands::m->flush_buffer;
- }
- close $fh;
-}
-
-
-
-sub MobileClient {
- my $self = shift;
-
-
-if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
- return 1;
-} else {
- return undef;
-}
-
-}
-
-
-sub StripContent {
- my %args = @_;
- my $content = $args{Content};
- return '' unless $content;
-
- # Make the content have no 'weird' newlines in it
- $content =~ s/\r+\n/\n/g;
-
- my $return_content = $content;
-
- my $html = $args{ContentType} && $args{ContentType} eq "text/html";
- my $sigonly = $args{StripSignature};
-
- # massage content to easily detect if there's any real content
- $content =~ s/\s+//g; # yes! remove all the spaces
- if ( $html ) {
- # remove html version of spaces and newlines
- $content =~ s! !!g;
- $content =~ s!<br/?>!!g;
- }
-
- # Filter empty content when type is text/html
- return '' if $html && $content !~ /\S/;
-
- # If we aren't supposed to strip the sig, just bail now.
- return $return_content unless $sigonly;
-
- # Find the signature
- my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
- $sig =~ s/\s+//g;
-
- # Check for plaintext sig
- return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
-
- # Check for html-formatted sig; we don't use EscapeUTF8 here
- # because we want to precisely match the escapting that FCKEditor
- # uses.
- $sig =~ s/&/&/g;
- $sig =~ s/</</g;
- $sig =~ s/>/>/g;
- $sig =~ s/"/"/g;
- $sig =~ s/'/'/g;
- return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
-
- # Pass it through
- return $return_content;
-}
-
-sub DecodeARGS {
- my $ARGS = shift;
-
- %{$ARGS} = map {
-
- # if they've passed multiple values, they'll be an array. if they've
- # passed just one, a scalar whatever they are, mark them as utf8
- my $type = ref($_);
- ( !$type )
- ? Encode::is_utf8($_)
- ? $_
- : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
- : ( $type eq 'ARRAY' )
- ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
- @$_ ]
- : ( $type eq 'HASH' )
- ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
- %$_ }
- : $_
- } %$ARGS;
-}
-
-sub PreprocessTimeUpdates {
- my $ARGS = shift;
-
- # Later in the code we use
- # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
- # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
- # The call_next method pass through original arguments and if you have
- # an argument with unicode key then in a next component you'll get two
- # records in the args hash: one with key without UTF8 flag and another
- # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
- # is copied from mason's source to get the same results as we get from
- # call_next method, this feature is not documented, so we just leave it
- # here to avoid possible side effects.
-
- # This code canonicalizes time inputs in hours into minutes
- foreach my $field ( keys %$ARGS ) {
- next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
- my $local = $1;
- $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
- {($1 || 0) + $3 ? $2 / $3 : 0}xe;
- if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
- $ARGS->{$local} *= 60;
- }
- delete $ARGS->{$field};
- }
-
-}
-
-sub MaybeEnableSQLStatementLog {
-
- my $log_sql_statements = RT->Config->Get('StatementLog');
-
- if ($log_sql_statements) {
- $RT::Handle->ClearSQLStatementLog;
- $RT::Handle->LogSQLStatements(1);
- }
-
-}
-
-sub LogRecordedSQLStatements {
- my %args = @_;
-
- my $log_sql_statements = RT->Config->Get('StatementLog');
-
- return unless ($log_sql_statements);
-
- my @log = $RT::Handle->SQLStatementLog;
- $RT::Handle->ClearSQLStatementLog;
-
- $RT::Handle->AddRequestToHistory({
- %{ $args{RequestData} },
- Queries => \@log,
- });
-
- for my $stmt (@log) {
- my ( $time, $sql, $bind, $duration ) = @{$stmt};
- my @bind;
- if ( ref $bind ) {
- @bind = @{$bind};
- } else {
-
- # Older DBIx-SB
- $duration = $bind;
- }
- $RT::Logger->log(
- level => $log_sql_statements,
- message => "SQL("
- . sprintf( "%.6f", $duration )
- . "s): $sql;"
- . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
- );
- }
-
-}
-
-my $_has_validated_web_config = 0;
-sub ValidateWebConfig {
- my $self = shift;
-
- # do this once per server instance, not once per request
- return if $_has_validated_web_config;
- $_has_validated_web_config = 1;
-
- my $port = $ENV{SERVER_PORT};
- my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
- || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
- ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
-
- if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
- $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
- ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
- ."otherwise your internal links may be broken.");
- }
-
- if ( $host ne RT->Config->Get('WebDomain') ) {
- $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
- ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
- ."otherwise your internal links may be broken.");
- }
-
- return; #next warning flooding our logs, doesn't seem applicable to our use
- # (SCRIPT_NAME is the full path, WebPath is just the beginning)
- #in vanilla RT does something eat the local part of SCRIPT_NAME 1st?
-
- # Unfortunately, there is no reliable way to get the _path_ that was
- # requested at the proxy level; simply disable this warning if we're
- # proxied and there's a mismatch.
- my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
- if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
- $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
- ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
- ."otherwise your internal links may be broken.");
- }
-}
-
-sub ComponentRoots {
- my $self = shift;
- my %args = ( Names => 0, @_ );
- my @roots;
- if (defined $HTML::Mason::Commands::m) {
- @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
- } else {
- @roots = (
- [ local => $RT::MasonLocalComponentRoot ],
- (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
- [ standard => $RT::MasonComponentRoot ]
- );
- }
- @roots = map { $_->[1] } @roots unless $args{Names};
- return @roots;
-}
-
-our %is_whitelisted_component = (
- # The RSS feed embeds an auth token in the path, but query
- # information for the search. Because it's a straight-up read, in
- # addition to embedding its own auth, it's fine.
- '/NoAuth/rss/dhandler' => 1,
-
- # While these can be used for denial-of-service against RT
- # (construct a very inefficient query and trick lots of users into
- # running them against RT) it's incredibly useful to be able to link
- # to a search result (or chart) or bookmark a result page.
- '/Search/Results.html' => 1,
- '/Search/Simple.html' => 1,
- '/m/tickets/search' => 1,
- '/Search/Chart.html' => 1,
-
- # This page takes Attachment and Transaction argument to figure
- # out what to show, but it's read only and will deny information if you
- # don't have ShowOutgoingEmail.
- '/Ticket/ShowEmailRecord.html' => 1,
-);
-
-# Components which are blacklisted from automatic, argument-based whitelisting.
-# These pages are not idempotent when called with just an id.
-our %is_blacklisted_component = (
- # Takes only id and toggles bookmark state
- '/Helpers/Toggle/TicketBookmark' => 1,
-);
-
-sub IsCompCSRFWhitelisted {
- my $comp = shift;
- my $ARGS = shift;
-
- return 1 if $is_whitelisted_component{$comp};
-
- my %args = %{ $ARGS };
-
- # If the user specifies a *correct* user and pass then they are
- # golden. This acts on the presumption that external forms may
- # hardcode a username and password -- if a malicious attacker knew
- # both already, CSRF is the least of your problems.
- my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
- if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
- my $user_obj = RT::CurrentUser->new();
- $user_obj->Load($args{user});
- return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
-
- delete $args{user};
- delete $args{pass};
- }
-
- # Some pages aren't idempotent even with safe args like id; blacklist
- # them from the automatic whitelisting below.
- return 0 if $is_blacklisted_component{$comp};
-
- # Eliminate arguments that do not indicate an effectful request.
- # For example, "id" is acceptable because that is how RT retrieves a
- # record.
- delete $args{id};
-
- # If they have a results= from MaybeRedirectForResults, that's also fine.
- delete $args{results};
-
- # The homepage refresh, which uses the Refresh header, doesn't send
- # a referer in most browsers; whitelist the one parameter it reloads
- # with, HomeRefreshInterval, which is safe
- delete $args{HomeRefreshInterval};
-
- # The NotMobile flag is fine for any page; it's only used to toggle a flag
- # in the session related to which interface you get.
- delete $args{NotMobile};
-
- # If there are no arguments, then it's likely to be an idempotent
- # request, which are not susceptible to CSRF
- return 1 if !%args;
-
- return 0;
-}
-
-sub IsRefererCSRFWhitelisted {
- my $referer = _NormalizeHost(shift);
- my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
- $base_url = $base_url->host_port;
-
- my $configs;
- for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
- push @$configs,$config;
-
- my $host_port = $referer->host_port;
- if ($config =~ /\*/) {
- # Turn a literal * into a domain component or partial component match.
- # Refer to http://tools.ietf.org/html/rfc2818#page-5
- my $regex = join "[a-zA-Z0-9\-]*",
- map { quotemeta($_) }
- split /\*/, $config;
-
- return 1 if $host_port =~ /^$regex$/i;
- } else {
- return 1 if $host_port eq $config;
- }
- }
-
- return (0,$referer,$configs);
-}
-
-=head3 _NormalizeHost
-
-Takes a URI and creates a URI object that's been normalized
-to handle common problems such as localhost vs 127.0.0.1
-
-=cut
-
-sub _NormalizeHost {
- my $s = shift;
- $s = "http://$s" unless $s =~ /^http/i;
- my $uri= URI->new($s);
- $uri->host('127.0.0.1') if $uri->host eq 'localhost';
-
- return $uri;
-
-}
-
-sub IsPossibleCSRF {
- my $ARGS = shift;
-
- # If first request on this session is to a REST endpoint, then
- # whitelist the REST endpoints -- and explicitly deny non-REST
- # endpoints. We do this because using a REST cookie in a browser
- # would open the user to CSRF attacks to the REST endpoints.
- my $path = $HTML::Mason::Commands::r->path_info;
- $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
- unless defined $HTML::Mason::Commands::session{'REST'};
-
- if ($HTML::Mason::Commands::session{'REST'}) {
- return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
- my $why = <<EOT;
-This login session belongs to a REST client, and cannot be used to
-access non-REST interfaces of RT for security reasons.
-EOT
- my $details = <<EOT;
-Please log out and back in to obtain a session for normal browsing. If
-you understand the security implications, disabling RT's CSRF protection
-will remove this restriction.
-EOT
- chomp $details;
- HTML::Mason::Commands::Abort( $why, Details => $details );
- }
-
- return 0 if IsCompCSRFWhitelisted(
- $HTML::Mason::Commands::m->request_comp->path,
- $ARGS
- );
-
- # if there is no Referer header then assume the worst
- return (1,
- "your browser did not supply a Referrer header", # loc
- ) if !$ENV{HTTP_REFERER};
-
- my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
- return 0 if $whitelisted;
-
- if ( @$configs > 1 ) {
- return (1,
- "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
- $browser->host_port,
- shift @$configs,
- join(', ', @$configs) );
- }
-
- return (1,
- "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
- $browser->host_port,
- $configs->[0]);
-}
-
-sub ExpandCSRFToken {
- my $ARGS = shift;
-
- my $token = delete $ARGS->{CSRF_Token};
- return unless $token;
-
- my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
- return unless $data;
- return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
-
- my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
- return unless $user->ValidateAuthString( $data->{auth}, $token );
-
- %{$ARGS} = %{$data->{args}};
- $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
-
- # We explicitly stored file attachments with the request, but not in
- # the session yet, as that would itself be an attack. Put them into
- # the session now, so they'll be visible.
- if ($data->{attach}) {
- my $filename = $data->{attach}{filename};
- my $mime = $data->{attach}{mime};
- $HTML::Mason::Commands::session{'Attachments'}{$filename}
- = $mime;
- }
-
- return 1;
-}
-
-sub StoreRequestToken {
- my $ARGS = shift;
-
- my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
- my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
- my $data = {
- auth => $user->GenerateAuthString( $token ),
- path => $HTML::Mason::Commands::r->path_info,
- args => $ARGS,
- };
- if ($ARGS->{Attach}) {
- my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
- my $file_path = delete $ARGS->{'Attach'};
- $data->{attach} = {
- filename => Encode::decode_utf8("$file_path"),
- mime => $attachment,
- };
- }
-
- $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
- $HTML::Mason::Commands::session{'i'}++;
- return $token;
-}
-
-sub MaybeShowInterstitialCSRFPage {
- my $ARGS = shift;
-
- return unless RT->Config->Get('RestrictReferrer');
-
- # Deal with the form token provided by the interstitial, which lets
- # browsers which never set referer headers still use RT, if
- # painfully. This blows values into ARGS
- return if ExpandCSRFToken($ARGS);
-
- my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
- return if !$is_csrf;
-
- $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
-
- my $token = StoreRequestToken($ARGS);
- $HTML::Mason::Commands::m->comp(
- '/Elements/CSRF',
- OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
- Reason => HTML::Mason::Commands::loc( $msg, @loc ),
- Token => $token,
- );
- # Calls abort, never gets here
-}
-
-our @POTENTIAL_PAGE_ACTIONS = (
- qr'/Ticket/Create.html' => "create a ticket", # loc
- qr'/Ticket/' => "update a ticket", # loc
- qr'/Admin/' => "modify RT's configuration", # loc
- qr'/Approval/' => "update an approval", # loc
- qr'/Articles/' => "update an article", # loc
- qr'/Dashboards/' => "modify a dashboard", # loc
- qr'/m/ticket/' => "update a ticket", # loc
- qr'Prefs' => "modify your preferences", # loc
- qr'/Search/' => "modify or access a search", # loc
- qr'/SelfService/Create' => "create a ticket", # loc
- qr'/SelfService/' => "update a ticket", # loc
-);
-
-sub PotentialPageAction {
- my $page = shift;
- my @potentials = @POTENTIAL_PAGE_ACTIONS;
- while (my ($pattern, $result) = splice @potentials, 0, 2) {
- return HTML::Mason::Commands::loc($result)
- if $page =~ $pattern;
- }
- return "";
-}
-
-package HTML::Mason::Commands;
-
-use vars qw/$r $m %session/;
-
-sub Menu {
- return $HTML::Mason::Commands::m->notes('menu');
-}
-
-sub PageMenu {
- return $HTML::Mason::Commands::m->notes('page-menu');
-}
-
-sub PageWidgets {
- return $HTML::Mason::Commands::m->notes('page-widgets');
-}
-
-
-
-=head2 loc ARRAY
-
-loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
-with whatever it's called with. If there is no $session{'CurrentUser'},
-it creates a temporary user, so we have something to get a localisation handle
-through
-
-=cut
-
-sub loc {
-
- if ( $session{'CurrentUser'}
- && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
- {
- return ( $session{'CurrentUser'}->loc(@_) );
- } elsif (
- my $u = eval {
- RT::CurrentUser->new();
- }
- )
- {
- return ( $u->loc(@_) );
- } else {
-
- # pathetic case -- SystemUser is gone.
- return $_[0];
- }
-}
-
-
-
-=head2 loc_fuzzy STRING
-
-loc_fuzzy is for handling localizations of messages that may already
-contain interpolated variables, typically returned from libraries
-outside RT's control. It takes the message string and extracts the
-variable array automatically by matching against the candidate entries
-inside the lexicon file.
-
-=cut
-
-sub loc_fuzzy {
- my $msg = shift;
-
- if ( $session{'CurrentUser'}
- && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
- {
- return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
- } else {
- my $u = RT::CurrentUser->new( RT->SystemUser->Id );
- return ( $u->loc_fuzzy($msg) );
- }
-}
-
-
-# Error - calls Error and aborts
-sub Abort {
- my $why = shift;
- my %args = @_;
-
- if ( $session{'ErrorDocument'}
- && $session{'ErrorDocumentType'} )
- {
- $r->content_type( $session{'ErrorDocumentType'} );
- $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
- $m->abort;
- } else {
- $m->comp( "/Elements/Error", Why => $why, %args );
- $m->abort;
- }
-}
-
-sub MaybeRedirectForResults {
- my %args = (
- Path => $HTML::Mason::Commands::m->request_comp->path,
- Arguments => {},
- Anchor => undef,
- Actions => undef,
- Force => 0,
- @_
- );
- my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
- return unless $has_actions || $args{'Force'};
-
- my %arguments = %{ $args{'Arguments'} };
-
- if ( $has_actions ) {
- my $key = Digest::MD5::md5_hex( rand(1024) );
- push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
- $session{'i'}++;
- $arguments{'results'} = $key;
- }
-
- $args{'Path'} =~ s!^/+!!;
- my $url = RT->Config->Get('WebURL') . $args{Path};
-
- if ( keys %arguments ) {
- $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
- }
- if ( $args{'Anchor'} ) {
- $url .= "#". $args{'Anchor'};
- }
- return RT::Interface::Web::Redirect($url);
-}
-
-=head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
-
-If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
-redirect to the approvals display page, preserving any arguments.
-
-C<Path>s matching C<Whitelist> are let through.
-
-This is a no-op if the C<ForceApprovalsView> option isn't enabled.
-
-=cut
-
-sub MaybeRedirectToApproval {
- my %args = (
- Path => $HTML::Mason::Commands::m->request_comp->path,
- ARGSRef => {},
- Whitelist => undef,
- @_
- );
-
- return unless $ENV{REQUEST_METHOD} eq 'GET';
-
- my $id = $args{ARGSRef}->{id};
-
- if ( $id
- and RT->Config->Get('ForceApprovalsView')
- and not $args{Path} =~ /$args{Whitelist}/)
- {
- my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
- $ticket->Load($id);
-
- if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
- MaybeRedirectForResults(
- Path => "/Approvals/Display.html",
- Force => 1,
- Anchor => $args{ARGSRef}->{Anchor},
- Arguments => $args{ARGSRef},
- );
- }
- }
-}
-
-=head2 CreateTicket ARGS
-
-Create a new ticket, using Mason's %ARGS. returns @results.
-
-=cut
-
-sub CreateTicket {
- my %ARGS = (@_);
-
- my (@Actions);
-
- my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
-
- my $Queue = RT::Queue->new( $session{'CurrentUser'} );
- unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
- Abort('Queue not found');
- }
-
- unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
- Abort('You have no permission to create tickets in that queue.');
- }
-
- my $due;
- if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
- $due = RT::Date->new( $session{'CurrentUser'} );
- $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
- }
- my $starts;
- if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
- $starts = RT::Date->new( $session{'CurrentUser'} );
- $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
- }
-
- my $sigless = RT::Interface::Web::StripContent(
- Content => $ARGS{Content},
- ContentType => $ARGS{ContentType},
- StripSignature => 1,
- CurrentUser => $session{'CurrentUser'},
- );
-
- my $MIMEObj = MakeMIMEEntity(
- Subject => $ARGS{'Subject'},
- From => $ARGS{'From'},
- Cc => $ARGS{'Cc'},
- Body => $sigless,
- Type => $ARGS{'ContentType'},
- Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
- );
-
- if ( $ARGS{'Attachments'} ) {
- my $rv = $MIMEObj->make_multipart;
- $RT::Logger->error("Couldn't make multipart message")
- if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
-
- foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) {
- unless ($_) {
- $RT::Logger->error("Couldn't add empty attachemnt");
- next;
- }
- $MIMEObj->add_part($_);
- }
- }
-
- for my $argument (qw(Encrypt Sign)) {
- $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
- }
-
- my %create_args = (
- Type => $ARGS{'Type'} || 'ticket',
- Queue => $ARGS{'Queue'},
- Owner => $ARGS{'Owner'},
-
- # note: name change
- Requestor => $ARGS{'Requestors'},
- Cc => $ARGS{'Cc'},
- AdminCc => $ARGS{'AdminCc'},
- InitialPriority => $ARGS{'InitialPriority'},
- FinalPriority => $ARGS{'FinalPriority'},
- TimeLeft => $ARGS{'TimeLeft'},
- TimeEstimated => $ARGS{'TimeEstimated'},
- TimeWorked => $ARGS{'TimeWorked'},
- Subject => $ARGS{'Subject'},
- Status => $ARGS{'Status'},
- Due => $due ? $due->ISO : undef,
- Starts => $starts ? $starts->ISO : undef,
- MIMEObj => $MIMEObj
- );
-
- my @txn_squelch;
- foreach my $type (qw(Requestor Cc AdminCc)) {
- push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
- if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
- }
- $create_args{TransSquelchMailTo} = \@txn_squelch
- if @txn_squelch;
-
- if ( $ARGS{'AttachTickets'} ) {
- require RT::Action::SendEmail;
- RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
- ref $ARGS{'AttachTickets'}
- ? @{ $ARGS{'AttachTickets'} }
- : ( $ARGS{'AttachTickets'} ) );
- }
-
- foreach my $arg ( keys %ARGS ) {
- next if $arg =~ /-(?:Magic|Category)$/;
-
- if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
- $create_args{$arg} = $ARGS{$arg};
- }
-
- # Object-RT::Ticket--CustomField-3-Values
- elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
- my $cfid = $1;
-
- my $cf = RT::CustomField->new( $session{'CurrentUser'} );
- $cf->SetContextObject( $Queue );
- $cf->Load($cfid);
- unless ( $cf->id ) {
- $RT::Logger->error( "Couldn't load custom field #" . $cfid );
- next;
- }
-
- if ( $arg =~ /-Upload$/ ) {
- $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
- next;
- }
-
- my $type = $cf->Type;
-
- my @values = ();
- if ( ref $ARGS{$arg} eq 'ARRAY' ) {
- @values = @{ $ARGS{$arg} };
- } elsif ( $type =~ /text/i ) {
- @values = ( $ARGS{$arg} );
- } else {
- no warnings 'uninitialized';
- @values = split /\r*\n/, $ARGS{$arg};
- }
- @values = grep length, map {
- s/\r+\n/\n/g;
- s/^\s+//;
- s/\s+$//;
- $_;
- }
- grep defined, @values;
-
- $create_args{"CustomField-$cfid"} = \@values;
- }
- }
-
- # turn new link lists into arrays, and pass in the proper arguments
- my %map = (
- 'new-DependsOn' => 'DependsOn',
- 'DependsOn-new' => 'DependedOnBy',
- 'new-MemberOf' => 'Parents',
- 'MemberOf-new' => 'Children',
- 'new-RefersTo' => 'RefersTo',
- 'RefersTo-new' => 'ReferredToBy',
- );
- foreach my $key ( keys %map ) {
- next unless $ARGS{$key};
- $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
-
- }
-
- my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
- unless ($id) {
- Abort($ErrMsg);
- }
-
- push( @Actions, split( "\n", $ErrMsg ) );
- unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
- Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
- }
- return ( $Ticket, @Actions );
-
-}
-
-
-
-=head2 LoadTicket id
-
-Takes a ticket id as its only variable. if it's handed an array, it takes
-the first value.
-
-Returns an RT::Ticket object as the current user.
-
-=cut
-
-sub LoadTicket {
- my $id = shift;
-
- if ( ref($id) eq "ARRAY" ) {
- $id = $id->[0];
- }
-
- unless ($id) {
- Abort("No ticket specified");
- }
-
- my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
- $Ticket->Load($id);
- unless ( $Ticket->id ) {
- Abort("Could not load ticket $id");
- }
- return $Ticket;
-}
-
-
-
-=head2 ProcessUpdateMessage
-
-Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
-
-Don't write message if it only contains current user's signature and
-SkipSignatureOnly argument is true. Function anyway adds attachments
-and updates time worked field even if skips message. The default value
-is true.
-
-=cut
-
-# change from stock: if txn custom fields are set but there's no content
-# or attachment, create a Touch txn instead of doing nothing
-
-sub ProcessUpdateMessage {
-
- my %args = (
- ARGSRef => undef,
- TicketObj => undef,
- SkipSignatureOnly => 1,
- @_
- );
-
- if ( $args{ARGSRef}->{'UpdateAttachments'}
- && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
- {
- delete $args{ARGSRef}->{'UpdateAttachments'};
- }
-
- # Strip the signature
- $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
- Content => $args{ARGSRef}->{UpdateContent},
- ContentType => $args{ARGSRef}->{UpdateContentType},
- StripSignature => $args{SkipSignatureOnly},
- CurrentUser => $args{'TicketObj'}->CurrentUser,
- );
-
- my %txn_customfields;
-
- foreach my $key ( keys %{ $args{ARGSRef} } ) {
- if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
- next if $key =~ /(TimeUnits|Magic)$/;
- $txn_customfields{$key} = $args{ARGSRef}->{$key};
- }
- }
-
- # If, after stripping the signature, we have no message, create a
- # Touch transaction if necessary
- if ( not $args{ARGSRef}->{'UpdateAttachments'}
- and not length $args{ARGSRef}->{'UpdateContent'} )
- {
- #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
- # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
- # delete $args{ARGSRef}->{'UpdateTimeWorked'};
- # }
-
- my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
- if ( $timetaken or grep {length $_} values %txn_customfields ) {
- my ( $Transaction, $Description, $Object ) =
- $args{TicketObj}->Touch(
- CustomFields => \%txn_customfields,
- TimeTaken => $timetaken
- );
- return $Description;
- }
- return;
- }
-
- if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
- $args{ARGSRef}->{'UpdateSubject'} = undef;
- }
-
- my $Message = MakeMIMEEntity(
- Subject => $args{ARGSRef}->{'UpdateSubject'},
- Body => $args{ARGSRef}->{'UpdateContent'},
- Type => $args{ARGSRef}->{'UpdateContentType'},
- Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
- );
-
- $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
- RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
- ) );
- my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
- if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
- $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
- } else {
- $old_txn = $args{TicketObj}->Transactions->First();
- }
-
- if ( my $msg = $old_txn->Message->First ) {
- RT::Interface::Email::SetInReplyTo(
- Message => $Message,
- InReplyTo => $msg
- );
- }
-
- if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
- $Message->make_multipart;
- $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_},
- sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
- }
-
- if ( $args{ARGSRef}->{'AttachTickets'} ) {
- require RT::Action::SendEmail;
- RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
- ref $args{ARGSRef}->{'AttachTickets'}
- ? @{ $args{ARGSRef}->{'AttachTickets'} }
- : ( $args{ARGSRef}->{'AttachTickets'} ) );
- }
-
- my %message_args = (
- Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
- Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
- MIMEObj => $Message,
- TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
- CustomFields => \%txn_customfields,
- );
-
- _ProcessUpdateMessageRecipients(
- MessageArgs => \%message_args,
- %args,
- );
-
- my @results;
- if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
- my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
- push( @results, $Description );
- $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
- } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
- my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
- push( @results, $Description );
- $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
- } else {
- push( @results,
- loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
- }
- return @results;
-}
-
-sub _ProcessUpdateMessageRecipients {
- my %args = (
- ARGSRef => undef,
- TicketObj => undef,
- MessageArgs => undef,
- @_,
- );
-
- my $bcc = $args{ARGSRef}->{'UpdateBcc'};
- my $cc = $args{ARGSRef}->{'UpdateCc'};
-
- my $message_args = $args{MessageArgs};
-
- $message_args->{CcMessageTo} = $cc;
- $message_args->{BccMessageTo} = $bcc;
-
- my @txn_squelch;
- foreach my $type (qw(Cc AdminCc)) {
- if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
- push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
- push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
- push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
- }
- }
- if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
- push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
- push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
- }
-
- push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
- $message_args->{SquelchMailTo} = \@txn_squelch
- if @txn_squelch;
-
- unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
- foreach my $key ( keys %{ $args{ARGSRef} } ) {
- next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
-
- my $var = ucfirst($1) . 'MessageTo';
- my $value = $2;
- if ( $message_args->{$var} ) {
- $message_args->{$var} .= ", $value";
- } else {
- $message_args->{$var} = $value;
- }
- }
- }
-}
-
-sub ProcessAttachments {
- my %args = (
- ARGSRef => {},
- @_
- );
-
- my $ARGSRef = $args{ARGSRef} || {};
- # deal with deleting uploaded attachments
- foreach my $key ( keys %$ARGSRef ) {
- if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
- delete $session{'Attachments'}{$1};
- }
- $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
- }
-
- # store the uploaded attachment in session
- if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
- { # attachment?
- my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
-
- my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
- $session{'Attachments'} =
- { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
- }
-
- # delete temporary storage entry to make WebUI clean
- unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
- {
- delete $session{'Attachments'};
- }
-}
-
-
-=head2 MakeMIMEEntity PARAMHASH
-
-Takes a paramhash Subject, Body and AttachmentFieldName.
-
-Also takes Form, Cc and Type as optional paramhash keys.
-
- Returns a MIME::Entity.
-
-=cut
-
-sub MakeMIMEEntity {
-
- #TODO document what else this takes.
- my %args = (
- Subject => undef,
- From => undef,
- Cc => undef,
- Body => undef,
- AttachmentFieldName => undef,
- Type => undef,
- Interface => 'API',
- @_,
- );
- my $Message = MIME::Entity->build(
- Type => 'multipart/mixed',
- "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
- "X-RT-Interface" => $args{Interface},
- map { $_ => Encode::encode_utf8( $args{ $_} ) }
- grep defined $args{$_}, qw(Subject From Cc)
- );
-
- if ( defined $args{'Body'} && length $args{'Body'} ) {
-
- # Make the update content have no 'weird' newlines in it
- $args{'Body'} =~ s/\r\n/\n/gs;
-
- $Message->attach(
- Type => $args{'Type'} || 'text/plain',
- Charset => 'UTF-8',
- Data => $args{'Body'},
- );
- }
-
- if ( $args{'AttachmentFieldName'} ) {
-
- my $cgi_object = $m->cgi_object;
- my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
- if ( defined $filehandle && length $filehandle ) {
-
- my ( @content, $buffer );
- while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
- push @content, $buffer;
- }
-
- my $uploadinfo = $cgi_object->uploadInfo($filehandle);
-
- my $filename = "$filehandle";
- $filename =~ s{^.*[\\/]}{};
-
- $Message->attach(
- Type => $uploadinfo->{'Content-Type'},
- Filename => $filename,
- Data => \@content,
- );
- if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
- $Message->head->set( 'Subject' => $filename );
- }
-
- # Attachment parts really shouldn't get a Message-ID or "interface"
- $Message->head->delete('Message-ID');
- $Message->head->delete('X-RT-Interface');
- }
- }
-
- $Message->make_singlepart;
-
- RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
-
- return ($Message);
-
-}
-
-
-
-=head2 ParseDateToISO
-
-Takes a date in an arbitrary format.
-Returns an ISO date and time in GMT
-
-=cut
-
-sub ParseDateToISO {
- my $date = shift;
-
- my $date_obj = RT::Date->new( $session{'CurrentUser'} );
- $date_obj->Set(
- Format => 'unknown',
- Value => $date
- );
- return ( $date_obj->ISO );
-}
-
-
-
-sub ProcessACLChanges {
- my $ARGSref = shift;
-
- my @results;
-
- foreach my $arg ( keys %$ARGSref ) {
- next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
-
- my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
-
- my @rights;
- if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
- @rights = @{ $ARGSref->{$arg} };
- } else {
- @rights = $ARGSref->{$arg};
- }
- @rights = grep $_, @rights;
- next unless @rights;
-
- my $principal = RT::Principal->new( $session{'CurrentUser'} );
- $principal->Load($principal_id);
-
- my $obj;
- if ( $object_type eq 'RT::System' ) {
- $obj = $RT::System;
- } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
- $obj = $object_type->new( $session{'CurrentUser'} );
- $obj->Load($object_id);
- unless ( $obj->id ) {
- $RT::Logger->error("couldn't load $object_type #$object_id");
- next;
- }
- } else {
- $RT::Logger->error("object type '$object_type' is incorrect");
- push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
- next;
- }
-
- foreach my $right (@rights) {
- my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
- push( @results, $msg );
- }
- }
-
- return (@results);
-}
-
-
-=head2 ProcessACLs
-
-ProcessACLs expects values from a series of checkboxes that describe the full
-set of rights a principal should have on an object.
-
-It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
-instead of with the prefixes Grant/RevokeRight. Each input should be an array
-listing the rights the principal should have, and ProcessACLs will modify the
-current rights to match. Additionally, the previously unused CheckACL input
-listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
-rights are removed from a principal and as such no SetRights input is
-submitted.
-
-=cut
-
-sub ProcessACLs {
- my $ARGSref = shift;
- my (%state, @results);
-
- my $CheckACL = $ARGSref->{'CheckACL'};
- my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
-
- # Check if we want to grant rights to a previously rights-less user
- for my $type (qw(user group)) {
- my $principal = _ParseACLNewPrincipal($ARGSref, $type)
- or next;
-
- unless ($principal->PrincipalId) {
- push @results, loc("Couldn't load the specified principal");
- next;
- }
-
- my $principal_id = $principal->PrincipalId;
-
- # Turn our addprincipal rights spec into a real one
- for my $arg (keys %$ARGSref) {
- next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
-
- my $tuple = "$principal_id-$1";
- my $key = "SetRights-$tuple";
-
- # If we have it already, that's odd, but merge them
- if (grep { $_ eq $tuple } @check) {
- $ARGSref->{$key} = [
- (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
- (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
- ];
- } else {
- $ARGSref->{$key} = $ARGSref->{$arg};
- push @check, $tuple;
- }
- }
- }
-
- # Build our rights state for each Principal-Object tuple
- foreach my $arg ( keys %$ARGSref ) {
- next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
-
- my $tuple = $1;
- my $value = $ARGSref->{$arg};
- my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
- next unless @rights;
-
- $state{$tuple} = { map { $_ => 1 } @rights };
- }
-
- foreach my $tuple (List::MoreUtils::uniq @check) {
- next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
-
- my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
-
- my $principal = RT::Principal->new( $session{'CurrentUser'} );
- $principal->Load($principal_id);
-
- my $obj;
- if ( $object_type eq 'RT::System' ) {
- $obj = $RT::System;
- } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
- $obj = $object_type->new( $session{'CurrentUser'} );
- $obj->Load($object_id);
- unless ( $obj->id ) {
- $RT::Logger->error("couldn't load $object_type #$object_id");
- next;
- }
- } else {
- $RT::Logger->error("object type '$object_type' is incorrect");
- push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
- next;
- }
-
- my $acls = RT::ACL->new($session{'CurrentUser'});
- $acls->LimitToObject( $obj );
- $acls->LimitToPrincipal( Id => $principal_id );
-
- while ( my $ace = $acls->Next ) {
- my $right = $ace->RightName;
-
- # Has right and should have right
- next if delete $state{$tuple}->{$right};
-
- # Has right and shouldn't have right
- my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
- push @results, $msg;
- }
-
- # For everything left, they don't have the right but they should
- for my $right (keys %{ $state{$tuple} || {} }) {
- delete $state{$tuple}->{$right};
- my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
- push @results, $msg;
- }
-
- # Check our state for leftovers
- if ( keys %{ $state{$tuple} || {} } ) {
- my $missed = join '|', %{$state{$tuple} || {}};
- $RT::Logger->warn(
- "Uh-oh, it looks like we somehow missed a right in "
- ."ProcessACLs. Here's what was leftover: $missed"
- );
- }
- }
-
- return (@results);
-}
-
-=head2 _ParseACLNewPrincipal
-
-Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
-for the presence of rights being added on a principal of the specified type,
-and returns undef if no new principal is being granted rights. Otherwise loads
-up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
-may not be successfully loaded, and you should check C<->id> yourself.
-
-=cut
-
-sub _ParseACLNewPrincipal {
- my $ARGSref = shift;
- my $type = lc shift;
- my $key = "AddPrincipalForRights-$type";
-
- return unless $ARGSref->{$key};
-
- my $principal;
- if ( $type eq 'user' ) {
- $principal = RT::User->new( $session{'CurrentUser'} );
- $principal->LoadByCol( Name => $ARGSref->{$key} );
- }
- elsif ( $type eq 'group' ) {
- $principal = RT::Group->new( $session{'CurrentUser'} );
- $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
- }
- return $principal;
-}
-
-
-=head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
-
-@attribs is a list of ticket fields to check and update if they differ from the B<Object>'s current values. ARGSRef is a ref to HTML::Mason's %ARGS.
-
-Returns an array of success/failure messages
-
-=cut
-
-sub UpdateRecordObject {
- my %args = (
- ARGSRef => undef,
- AttributesRef => undef,
- Object => undef,
- AttributePrefix => undef,
- @_
- );
-
- my $Object = $args{'Object'};
- my @results = $Object->Update(
- AttributesRef => $args{'AttributesRef'},
- ARGSRef => $args{'ARGSRef'},
- AttributePrefix => $args{'AttributePrefix'},
- );
-
- return (@results);
-}
-
-
-
-sub ProcessCustomFieldUpdates {
- my %args = (
- CustomFieldObj => undef,
- ARGSRef => undef,
- @_
- );
-
- my $Object = $args{'CustomFieldObj'};
- my $ARGSRef = $args{'ARGSRef'};
-
- my @attribs = qw(Name Type Description Queue SortOrder);
- my @results = UpdateRecordObject(
- AttributesRef => \@attribs,
- Object => $Object,
- ARGSRef => $ARGSRef
- );
-
- my $prefix = "CustomField-" . $Object->Id;
- if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
- my ( $addval, $addmsg ) = $Object->AddValue(
- Name => $ARGSRef->{"$prefix-AddValue-Name"},
- Description => $ARGSRef->{"$prefix-AddValue-Description"},
- SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
- );
- push( @results, $addmsg );
- }
-
- my @delete_values
- = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
- ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
- : ( $ARGSRef->{"$prefix-DeleteValue"} );
-
- foreach my $id (@delete_values) {
- next unless defined $id;
- my ( $err, $msg ) = $Object->DeleteValue($id);
- push( @results, $msg );
- }
-
- my $vals = $Object->Values();
- while ( my $cfv = $vals->Next() ) {
- if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
- if ( $cfv->SortOrder != $so ) {
- my ( $err, $msg ) = $cfv->SetSortOrder($so);
- push( @results, $msg );
- }
- }
- }
-
- return (@results);
-}
-
-
-
-=head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
-
-Returns an array of results messages.
-
-=cut
-
-sub ProcessTicketBasics {
-
- my %args = (
- TicketObj => undef,
- ARGSRef => undef,
- @_
- );
-
- my $TicketObj = $args{'TicketObj'};
- my $ARGSRef = $args{'ARGSRef'};
-
- my $OrigOwner = $TicketObj->Owner;
-
- # Set basic fields
- my @attribs = qw(
- Subject
- FinalPriority
- Priority
- TimeEstimated
- TimeWorked
- TimeLeft
- Type
- Status
- Queue
- );
-
- # Canonicalize Queue and Owner to their IDs if they aren't numeric
- for my $field (qw(Queue Owner)) {
- if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
- my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
- my $temp = $class->new(RT->SystemUser);
- $temp->Load( $ARGSRef->{$field} );
- if ( $temp->id ) {
- $ARGSRef->{$field} = $temp->id;
- }
- }
- }
-
- # Status isn't a field that can be set to a null value.
- # RT core complains if you try
- delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
-
- my @results = UpdateRecordObject(
- AttributesRef => \@attribs,
- Object => $TicketObj,
- ARGSRef => $ARGSRef,
- );
-
- # We special case owner changing, so we can use ForceOwnerChange
- if ( $ARGSRef->{'Owner'}
- && $ARGSRef->{'Owner'} !~ /\D/
- && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
- my ($ChownType);
- if ( $ARGSRef->{'ForceOwnerChange'} ) {
- $ChownType = "Force";
- }
- else {
- $ChownType = "Set";
- }
-
- my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
- push( @results, $msg );
- }
-
- # }}}
-
- return (@results);
-}
-
-sub ProcessTicketReminders {
- my %args = (
- TicketObj => undef,
- ARGSRef => undef,
- @_
- );
-
- my $Ticket = $args{'TicketObj'};
- my $args = $args{'ARGSRef'};
- my @results;
-
- my $reminder_collection = $Ticket->Reminders->Collection;
-
- if ( $args->{'update-reminders'} ) {
- while ( my $reminder = $reminder_collection->Next ) {
- my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
- if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
- my ($status, $msg) = $Ticket->Reminders->Resolve($reminder);
- push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
-
- }
- elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
- my ($status, $msg) = $Ticket->Reminders->Open($reminder);
- push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
- }
-
- if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
- my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
- push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
- }
-
- if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
- my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
- push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
- }
-
- if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
- my $DateObj = RT::Date->new( $session{'CurrentUser'} );
- $DateObj->Set(
- Format => 'unknown',
- Value => $args->{ 'Reminder-Due-' . $reminder->id }
- );
- if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
- my ($status, $msg) = $reminder->SetDue( $DateObj->ISO );
- push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
- }
- }
- }
- }
-
- if ( $args->{'NewReminder-Subject'} ) {
- my $due_obj = RT::Date->new( $session{'CurrentUser'} );
- $due_obj->Set(
- Format => 'unknown',
- Value => $args->{'NewReminder-Due'}
- );
- my ( $add_id, $msg ) = $Ticket->Reminders->Add(
- Subject => $args->{'NewReminder-Subject'},
- Owner => $args->{'NewReminder-Owner'},
- Due => $due_obj->ISO
- );
- if ( $add_id ) {
- push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
- }
- else {
- push @results, $msg;
- }
- }
- return @results;
-}
-
-sub ProcessTicketCustomFieldUpdates {
- my %args = @_;
- $args{'Object'} = delete $args{'TicketObj'};
- my $ARGSRef = { %{ $args{'ARGSRef'} } };
-
- # Build up a list of objects that we want to work with
- my %custom_fields_to_mod;
- foreach my $arg ( keys %$ARGSRef ) {
- if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
- $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
- } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
- $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
- } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
- delete $ARGSRef->{$arg}; # don't try to update transaction fields
- }
- }
-
- return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
-}
-
-sub ProcessObjectCustomFieldUpdates {
- my %args = @_;
- my $ARGSRef = $args{'ARGSRef'};
- my @results;
-
- # Build up a list of objects that we want to work with
- my %custom_fields_to_mod;
- foreach my $arg ( keys %$ARGSRef ) {
-
- # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
- next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
-
- # For each of those objects, find out what custom fields we want to work with.
- $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
- }
-
- # For each of those objects
- foreach my $class ( keys %custom_fields_to_mod ) {
- foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
- my $Object = $args{'Object'};
- $Object = $class->new( $session{'CurrentUser'} )
- unless $Object && ref $Object eq $class;
-
- $Object->Load($id) unless ( $Object->id || 0 ) == $id;
- unless ( $Object->id ) {
- $RT::Logger->warning("Couldn't load object $class #$id");
- next;
- }
-
- foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
- my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
- $CustomFieldObj->SetContextObject($Object);
- $CustomFieldObj->LoadById($cf);
- unless ( $CustomFieldObj->id ) {
- $RT::Logger->warning("Couldn't load custom field #$cf");
- next;
- }
- push @results,
- _ProcessObjectCustomFieldUpdates(
- Prefix => "Object-$class-$id-CustomField-$cf-",
- Object => $Object,
- CustomField => $CustomFieldObj,
- ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
- );
- }
- }
- }
- return @results;
-}
-
-sub _ProcessObjectCustomFieldUpdates {
- my %args = @_;
- my $cf = $args{'CustomField'};
- my $cf_type = $cf->Type || '';
-
- # Remove blank Values since the magic field will take care of this. Sometimes
- # the browser gives you a blank value which causes CFs to be processed twice
- if ( defined $args{'ARGS'}->{'Values'}
- && !length $args{'ARGS'}->{'Values'}
- && $args{'ARGS'}->{'Values-Magic'} )
- {
- delete $args{'ARGS'}->{'Values'};
- }
-
- my @results;
- foreach my $arg ( keys %{ $args{'ARGS'} } ) {
-
- # skip category argument
- next if $arg eq 'Category';
-
- # and TimeUnits
- next if $arg eq 'Value-TimeUnits';
-
- # since http won't pass in a form element with a null value, we need
- # to fake it
- if ( $arg eq 'Values-Magic' ) {
-
- # We don't care about the magic, if there's really a values element;
- next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
- next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
-
- # "Empty" values does not mean anything for Image and Binary fields
- next if $cf_type =~ /^(?:Image|Binary)$/;
-
- $arg = 'Values';
- $args{'ARGS'}->{'Values'} = undef;
- }
-
- my @values = ();
- if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
- @values = @{ $args{'ARGS'}->{$arg} };
- } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
- @values = ( $args{'ARGS'}->{$arg} );
- } else {
- @values = split /\r*\n/, $args{'ARGS'}->{$arg}
- if defined $args{'ARGS'}->{$arg};
- }
- @values = grep length, map {
- s/\r+\n/\n/g;
- s/^\s+//;
- s/\s+$//;
- $_;
- }
- grep defined, @values;
-
- if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
- foreach my $value (@values) {
- my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
- Field => $cf->id,
- Value => $value
- );
- push( @results, $msg );
- }
- } elsif ( $arg eq 'Upload' ) {
- my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
- my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
- push( @results, $msg );
- } elsif ( $arg eq 'DeleteValues' ) {
- foreach my $value (@values) {
- my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
- Field => $cf,
- Value => $value,
- );
- push( @results, $msg );
- }
- } elsif ( $arg eq 'DeleteValueIds' ) {
- foreach my $value (@values) {
- my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
- Field => $cf,
- ValueId => $value,
- );
- push( @results, $msg );
- }
- } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
- my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
-
- my %values_hash;
- foreach my $value (@values) {
- if ( my $entry = $cf_values->HasEntry($value) ) {
- $values_hash{ $entry->id } = 1;
- next;
- }
-
- my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
- Field => $cf,
- Value => $value
- );
- push( @results, $msg );
- $values_hash{$val} = 1 if $val;
- }
-
- # For Date Cfs, @values is empty when there is no changes (no datas in form input)
- return @results if ( $cf->Type eq 'Date' && ! @values );
-
- # For Date Cfs, @values is empty when there is no changes (no datas in form input)
- return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
-
- $cf_values->RedoSearch;
- while ( my $cf_value = $cf_values->Next ) {
- next if $values_hash{ $cf_value->id };
-
- my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
- Field => $cf,
- ValueId => $cf_value->id
- );
- push( @results, $msg );
- }
- } elsif ( $arg eq 'Values' ) {
- my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
-
- # keep everything up to the point of difference, delete the rest
- my $delete_flag;
- foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
- if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
- shift @values;
- next;
- }
-
- $delete_flag ||= 1;
- $old_cf->Delete;
- }
-
- # now add/replace extra things, if any
- foreach my $value (@values) {
- my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
- Field => $cf,
- Value => $value
- );
- push( @results, $msg );
- }
- } else {
- push(
- @results,
- loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
- $cf->Name, ref $args{'Object'},
- $args{'Object'}->id
- )
- );
- }
- }
- return @results;
-}
-
-
-=head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
-
-Returns an array of results messages.
-
-=cut
-
-sub ProcessTicketWatchers {
- my %args = (
- TicketObj => undef,
- ARGSRef => undef,
- @_
- );
- my (@results);
-
- my $Ticket = $args{'TicketObj'};
- my $ARGSRef = $args{'ARGSRef'};
-
- # Munge watchers
-
- foreach my $key ( keys %$ARGSRef ) {
-
- # Delete deletable watchers
- if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
- my ( $code, $msg ) = $Ticket->DeleteWatcher(
- PrincipalId => $2,
- Type => $1
- );
- push @results, $msg;
- }
-
- # Delete watchers in the simple style demanded by the bulk manipulator
- elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
- my ( $code, $msg ) = $Ticket->DeleteWatcher(
- Email => $ARGSRef->{$key},
- Type => $1
- );
- push @results, $msg;
- }
-
- # Add new wathchers by email address
- elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
- and $key =~ /^WatcherTypeEmail(\d*)$/ )
- {
-
- #They're in this order because otherwise $1 gets clobbered :/
- my ( $code, $msg ) = $Ticket->AddWatcher(
- Type => $ARGSRef->{$key},
- Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
- );
- push @results, $msg;
- }
-
- #Add requestors in the simple style demanded by the bulk manipulator
- elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
- my ( $code, $msg ) = $Ticket->AddWatcher(
- Type => $1,
- Email => $ARGSRef->{$key}
- );
- push @results, $msg;
- }
-
- # Add new watchers by owner
- elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
- my $principal_id = $1;
- my $form = $ARGSRef->{$key};
- foreach my $value ( ref($form) ? @{$form} : ($form) ) {
- next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
-
- my ( $code, $msg ) = $Ticket->AddWatcher(
- Type => $value,
- PrincipalId => $principal_id
- );
- push @results, $msg;
- }
- }
-
- }
- return (@results);
-}
-
-
-
-=head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
-
-Returns an array of results messages.
-
-=cut
-
-sub ProcessTicketDates {
- my %args = (
- TicketObj => undef,
- ARGSRef => undef,
- @_
- );
-
- my $Ticket = $args{'TicketObj'};
- my $ARGSRef = $args{'ARGSRef'};
-
- my (@results);
-
- # Set date fields
- my @date_fields = qw(
- Told
- Resolved
- Starts
- Started
- Due
- WillResolve
- );
-
- #Run through each field in this list. update the value if apropriate
- foreach my $field (@date_fields) {
- next unless exists $ARGSRef->{ $field . '_Date' };
- next if $ARGSRef->{ $field . '_Date' } eq '';
-
- my ( $code, $msg );
-
- my $DateObj = RT::Date->new( $session{'CurrentUser'} );
- $DateObj->Set(
- Format => 'unknown',
- Value => $ARGSRef->{ $field . '_Date' }
- );
-
- my $obj = $field . "Obj";
- if ( ( defined $DateObj->Unix )
- and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
- {
- my $method = "Set$field";
- my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
- push @results, "$msg";
- }
- }
-
- # }}}
- return (@results);
-}
-
-
-
-=head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
-
-Returns an array of results messages.
-
-=cut
-
-sub ProcessTicketLinks {
- my %args = (
- TicketObj => undef,
- ARGSRef => undef,
- @_
- );
-
- my $Ticket = $args{'TicketObj'};
- my $ARGSRef = $args{'ARGSRef'};
-
- my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
-
- #Merge if we need to
- if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
- $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
- my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
- push @results, $msg;
- }
-
- return (@results);
-}
-
-
-sub ProcessRecordLinks {
- my %args = (
- RecordObj => undef,
- ARGSRef => undef,
- @_
- );
-
- my $Record = $args{'RecordObj'};
- my $ARGSRef = $args{'ARGSRef'};
-
- my (@results);
-
- # Delete links that are gone gone gone.
- foreach my $arg ( keys %$ARGSRef ) {
- if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
- my $base = $1;
- my $type = $2;
- my $target = $3;
-
- my ( $val, $msg ) = $Record->DeleteLink(
- Base => $base,
- Type => $type,
- Target => $target
- );
-
- push @results, $msg;
-
- }
-
- }
-
- my @linktypes = qw( DependsOn MemberOf RefersTo );
-
- foreach my $linktype (@linktypes) {
- if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
- $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
- if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
-
- for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
- next unless $luri;
- $luri =~ s/\s+$//; # Strip trailing whitespace
- my ( $val, $msg ) = $Record->AddLink(
- Target => $luri,
- Type => $linktype
- );
- push @results, $msg;
- }
- }
- if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
- $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
- if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
-
- for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
- next unless $luri;
- my ( $val, $msg ) = $Record->AddLink(
- Base => $luri,
- Type => $linktype
- );
-
- push @results, $msg;
- }
- }
- }
-
- return (@results);
-}
-
-=head2 ProcessTransactionSquelching
-
-Takes a hashref of the submitted form arguments, C<%ARGS>.
-
-Returns a hash of squelched addresses.
-
-=cut
-
-sub ProcessTransactionSquelching {
- my $args = shift;
- my %checked = map { $_ => 1 } grep { defined }
- ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
- defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
- () );
- my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
- return %squelched;
-}
-
-=head2 _UploadedFile ( $arg );
-
-Takes a CGI parameter name; if a file is uploaded under that name,
-return a hash reference suitable for AddCustomFieldValue's use:
-C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
-
-Returns C<undef> if no files were uploaded in the C<$arg> field.
-
-=cut
-
-sub _UploadedFile {
- my $arg = shift;
- my $cgi_object = $m->cgi_object;
- my $fh = $cgi_object->upload($arg) or return undef;
- my $upload_info = $cgi_object->uploadInfo($fh);
-
- my $filename = "$fh";
- $filename =~ s#^.*[\\/]##;
- binmode($fh);
-
- return {
- Value => $filename,
- LargeContent => do { local $/; scalar <$fh> },
- ContentType => $upload_info->{'Content-Type'},
- };
-}
-
-sub GetColumnMapEntry {
- my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
-
- # deal with the simplest thing first
- if ( $args{'Map'}{ $args{'Name'} } ) {
- return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
- }
-
- # complex things
- elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
- $subkey =~ s/^\{(.*)\}$/$1/;
- return undef unless $args{'Map'}->{$mainkey};
- return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
- unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
-
- return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
- }
- return undef;
-}
-
-sub ProcessColumnMapValue {
- my $value = shift;
- my %args = ( Arguments => [], Escape => 1, @_ );
-
- if ( ref $value ) {
- if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
- my @tmp = $value->( @{ $args{'Arguments'} } );
- return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
- } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
- return join '', map ProcessColumnMapValue( $_, %args ), @$value;
- } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
- return $$value;
- }
- }
-
- return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
- return $value;
-}
-
-=head2 GetPrincipalsMap OBJECT, CATEGORIES
-
-Returns an array suitable for passing to /Admin/Elements/EditRights with the
-principal collections mapped from the categories given.
-
-=cut
-
-sub GetPrincipalsMap {
- my $object = shift;
- my @map;
- for (@_) {
- if (/System/) {
- my $system = RT::Groups->new($session{'CurrentUser'});
- $system->LimitToSystemInternalGroups();
- $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
- push @map, [
- 'System' => $system, # loc_left_pair
- 'Type' => 1,
- ];
- }
- elsif (/Groups/) {
- my $groups = RT::Groups->new($session{'CurrentUser'});
- $groups->LimitToUserDefinedGroups();
- $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
-
- # Only show groups who have rights granted on this object
- $groups->WithGroupRight(
- Right => '',
- Object => $object,
- IncludeSystemRights => 0,
- IncludeSubgroupMembers => 0,
- );
-
- push @map, [
- 'User Groups' => $groups, # loc_left_pair
- 'Name' => 0
- ];
- }
- elsif (/Roles/) {
- my $roles = RT::Groups->new($session{'CurrentUser'});
-
- if ($object->isa('RT::System')) {
- $roles->LimitToRolesForSystem();
- }
- elsif ($object->isa('RT::Queue')) {
- $roles->LimitToRolesForQueue($object->Id);
- }
- else {
- $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
- next;
- }
- $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
- push @map, [
- 'Roles' => $roles, # loc_left_pair
- 'Type' => 1
- ];
- }
- elsif (/Users/) {
- my $Users = RT->PrivilegedUsers->UserMembersObj();
- $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
-
- # Only show users who have rights granted on this object
- my $group_members = $Users->WhoHaveGroupRight(
- Right => '',
- Object => $object,
- IncludeSystemRights => 0,
- IncludeSubgroupMembers => 0,
- );
-
- # Limit to UserEquiv groups
- my $groups = $Users->NewAlias('Groups');
- $Users->Join(
- ALIAS1 => $groups,
- FIELD1 => 'id',
- ALIAS2 => $group_members,
- FIELD2 => 'GroupId'
- );
- $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
- $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
-
-
- my $display = sub {
- $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
- };
- push @map, [
- 'Users' => $Users, # loc_left_pair
- $display => 0
- ];
- }
- }
- return @map;
-}
-
-=head2 _load_container_object ( $type, $id );
-
-Instantiate container object for saving searches.
-
-=cut
-
-sub _load_container_object {
- my ( $obj_type, $obj_id ) = @_;
- return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
-}
-
-=head2 _parse_saved_search ( $arg );
-
-Given a serialization string for saved search, and returns the
-container object and the search id.
-
-=cut
-
-sub _parse_saved_search {
- my $spec = shift;
- return unless $spec;
- if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
- return;
- }
- my $obj_type = $1;
- my $obj_id = $2;
- my $search_id = $3;
-
- return ( _load_container_object( $obj_type, $obj_id ), $search_id );
-}
-
-=head2 ScrubHTML content
-
-Removes unsafe and undesired HTML from the passed content
-
-=cut
-
-my $SCRUBBER;
-sub ScrubHTML {
- my $Content = shift;
- $SCRUBBER = _NewScrubber() unless $SCRUBBER;
-
- $Content = '' if !defined($Content);
- return $SCRUBBER->scrub($Content);
-}
-
-=head2 _NewScrubber
-
-Returns a new L<HTML::Scrubber> object.
-
-If you need to be more lax about what HTML tags and attributes are allowed,
-create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
-following:
-
- package HTML::Mason::Commands;
- # Let tables through
- push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
- 1;
-
-=cut
-
-our @SCRUBBER_ALLOWED_TAGS = qw(
- A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
- H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
-);
-
-our %SCRUBBER_ALLOWED_ATTRIBUTES = (
- # Match http, https, ftp, mailto and relative urls
- # XXX: we also scrub format strings with this module then allow simple config options
- href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
- face => 1,
- size => 1,
- target => 1,
- style => qr{
- ^(?:\s*
- (?:(?:background-)?color: \s*
- (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
- \#[a-f0-9]{3,6} | # #fff or #ffffff
- [\w\-]+ # green, light-blue, etc.
- ) |
- text-align: \s* \w+ |
- font-size: \s* [\w.\-]+ |
- font-family: \s* [\w\s"',.\-]+ |
- font-weight: \s* [\w\-]+ |
-
- # MS Office styles, which are probably fine. If we don't, then any
- # associated styles in the same attribute get stripped.
- mso-[\w\-]+?: \s* [\w\s"',.\-]+
- )\s* ;? \s*)
- +$ # one or more of these allowed properties from here 'till sunset
- }ix,
- dir => qr/^(rtl|ltr)$/i,
- lang => qr/^\w+(-\w+)?$/,
-);
-
-our %SCRUBBER_RULES = ();
-
-sub _NewScrubber {
- require HTML::Scrubber;
- my $scrubber = HTML::Scrubber->new();
- $scrubber->default(
- 0,
- {
- %SCRUBBER_ALLOWED_ATTRIBUTES,
- '*' => 0, # require attributes be explicitly allowed
- },
- );
- $scrubber->deny(qw[*]);
- $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
- $scrubber->rules(%SCRUBBER_RULES);
-
- # Scrubbing comments is vital since IE conditional comments can contain
- # arbitrary HTML and we'd pass it right on through.
- $scrubber->comment(0);
-
- return $scrubber;
-}
-
-=head2 JSON
-
-Redispatches to L<RT::Interface::Web/EncodeJSON>
-
-=cut
-
-sub JSON {
- RT::Interface::Web::EncodeJSON(@_);
-}
-
-package RT::Interface::Web;
-RT::Base->_ImportOverlays();
-
-1;
projects / freeside.git / commitdiff