summaryrefslogtreecommitdiff
path: root/rt/lib/RT/Interface
diff options
context:
space:
mode:
Diffstat (limited to 'rt/lib/RT/Interface')
-rw-r--r--rt/lib/RT/Interface/CLI.pm60
-rwxr-xr-xrt/lib/RT/Interface/Email.pm1924
-rw-r--r--rt/lib/RT/Interface/Web.pm2250
-rw-r--r--rt/lib/RT/Interface/Web_Vendor.pm201
4 files changed, 1417 insertions, 3018 deletions
diff --git a/rt/lib/RT/Interface/CLI.pm b/rt/lib/RT/Interface/CLI.pm
index a910fb48a..ec0e877b4 100644
--- a/rt/lib/RT/Interface/CLI.pm
+++ b/rt/lib/RT/Interface/CLI.pm
@@ -1,14 +1,8 @@
-# BEGIN BPS TAGGED BLOCK {{{
+# BEGIN LICENSE BLOCK
#
-# COPYRIGHT:
+# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
#
-# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
-# <jesse@bestpractical.com>
-#
-# (Except where explicitly superseded by other copyright notices)
-#
-#
-# LICENSE:
+# (Except where explictly superceded by other copyright notices)
#
# 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
@@ -20,32 +14,13 @@
# 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.)
+# Unless otherwise specified, all modifications, corrections or
+# extensions to this work which alter its source code become the
+# property of Best Practical Solutions, LLC when submitted for
+# inclusion in the work.
#
-# 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 }}}
-
+# END LICENSE BLOCK
use strict;
use RT;
@@ -54,12 +29,14 @@ package RT::Interface::CLI;
BEGIN {
- use base 'Exporter';
- use vars qw ($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ use Exporter ();
+ use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
- $VERSION = do { my @r = (q$Revision: 1.1.1.8 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
-
+ $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
+
+ @ISA = qw(Exporter);
+
# your exported package globals go here,
# as well as any optionally exported functions
@EXPORT_OK = qw(&CleanEnv
@@ -99,6 +76,11 @@ BEGIN {
=head1 METHODS
+=begin testing
+
+ok(require RT::Interface::CLI);
+
+=end testing
=cut
@@ -220,7 +202,7 @@ sub GetMessageContent {
if ($edit) {
unless ($ENV{'EDITOR'}) {
- $RT::Logger->crit('No $EDITOR variable defined');
+ $RT::Logger->crit('No $EDITOR variable defined'. "\n");
return undef;
}
system ($ENV{'EDITOR'}, $filename);
@@ -243,7 +225,7 @@ sub debug {
my $val = shift;
my ($debug);
if ($val) {
- $RT::Logger->debug($val);
+ $RT::Logger->debug($val."\n");
if ($debug) {
print STDERR "$val\n";
}
diff --git a/rt/lib/RT/Interface/Email.pm b/rt/lib/RT/Interface/Email.pm
index b669b5b2f..7eec0502f 100755
--- a/rt/lib/RT/Interface/Email.pm
+++ b/rt/lib/RT/Interface/Email.pm
@@ -1,14 +1,8 @@
-# BEGIN BPS TAGGED BLOCK {{{
+# BEGIN LICENSE BLOCK
#
-# COPYRIGHT:
+# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
#
-# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
-# <jesse@bestpractical.com>
-#
-# (Except where explicitly superseded by other copyright notices)
-#
-#
-# LICENSE:
+# (Except where explictly superceded by other copyright notices)
#
# 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
@@ -20,72 +14,50 @@
# 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.
-#
+# Unless otherwise specified, all modifications, corrections or
+# extensions to this work which alter its source code become the
+# property of Best Practical Solutions, LLC when submitted for
+# inclusion in the work.
#
-# 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 }}}
-
+# END LICENSE BLOCK
package RT::Interface::Email;
use strict;
-use warnings;
-
-use Email::Address;
+use Mail::Address;
use MIME::Entity;
use RT::EmailParser;
-use File::Temp;
-use UNIVERSAL::require;
-use Mail::Mailer ();
-BEGIN {
- use base 'Exporter';
- use vars qw ( @EXPORT_OK);
+BEGIN {
+ use Exporter ();
+ use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
# set the version for version checking
- our $VERSION = 2.0;
-
+ $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
+
+ @ISA = qw(Exporter);
+
# 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);
+ @EXPORT_OK = qw(
+ &CreateUser
+ &GetMessageContent
+ &CheckForLoops
+ &CheckForSuspiciousSender
+ &CheckForAutoGenerated
+ &MailError
+ &ParseCcAddressesFromHead
+ &ParseSenderAddressFromHead
+ &ParseErrorsToAddressFromHead
+ &ParseAddressFromHeader
+ &Gateway);
}
=head1 NAME
- RT::Interface::Email - helper functions for parsing email sent to RT
+ RT::Interface::CLI - helper functions for creating a commandline RT interface
=head1 SYNOPSIS
@@ -97,1605 +69,425 @@ BEGIN {
=head1 DESCRIPTION
+=begin testing
+ok(require RT::Interface::Email);
-=head1 METHODS
+=end testing
-=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.
+=head1 METHODS
=cut
-sub CheckForLoops {
- my $head = shift;
- # If this instance of RT sent it our, we don't want to take it in
+# {{{ sub CheckForLoops
+
+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;
+ chomp ($RTLoop); #remove that newline
+ if ($RTLoop eq "$RT::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;
+ 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
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 ( ( $From =~ /^mailer-daemon\@/i )
- or ( $From =~ /^postmaster\@/i )
- or ( $From eq "" ))
- {
- return (1);
-
+ my ($From, $junk) = ParseSenderAddressFromHead($head);
+
+ if (($From =~ /^mailer-daemon/i) or
+ ($From =~ /^postmaster/i)){
+ return (1);
+
}
+
+ return (undef);
- 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
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);
+
+ my $Precedence = $head->get("Precedence") || "" ;
+ if ($Precedence =~ /^(bulk|junk)/i) {
+ return (1);
}
-
- # First Class mailer uses this as a clue.
- my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
- if ( $FCJunk =~ /^true/i ) {
- return (1);
+ else {
+ return (0);
}
-
- 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 explanation message into the
-log, by default we log it as critical.
-
-=back
-
-=cut
+# {{{ sub MailError
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{'Explanation'}
- ) if $args{'LogLevel'};
- # the colons are necessary to make ->build include non-standard headers
- my $entity = MIME::Entity->build(
- Type => "multipart/mixed",
- From => $args{'From'},
- Bcc => $args{'Bcc'},
- To => $args{'To'},
- Subject => $args{'Subject'},
- 'Precedence:' => 'bulk',
- 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
- );
- 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.
-
-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 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;
+ my %args = (To => $RT::OwnerEmail,
+ Bcc => undef,
+ From => $RT::CorrespondAddress,
+ Subject => 'There has been an error',
+ Explanation => 'Unexplained error',
+ MIMEObj => undef,
+ LogLevel => 'crit',
+ @_);
+
+
+ $RT::Logger->log(level => $args{'LogLevel'},
+ message => $args{'Explanation'}
+ );
+ my $entity = MIME::Entity->build( Type =>"multipart/mixed",
+ From => $args{'From'},
+ Bcc => $args{'Bcc'},
+ To => $args{'To'},
+ Subject => $args{'Subject'},
+ 'X-RT-Loop-Prevention' => $RT::rtname,
+ );
+
+ $entity->attach( Data => $args{'Explanation'}."\n");
- # 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 ( $TransactionObj && !$TicketObj
- && $TransactionObj->ObjectType eq 'RT::Ticket' )
- {
- $TicketObj = $TransactionObj->Object;
- }
-
- if ( RT->Config->Get('GnuPG')->{'Enable'} ) {
- my %crypt;
-
- my $attachment;
- $attachment = $TransactionObj->Attachments->First
- if $TransactionObj;
-
- foreach my $argument ( qw(Sign Encrypt) ) {
- next if defined $args{ $argument };
-
- if ( $attachment && defined $attachment->GetHeader("X-RT-$argument") ) {
- $crypt{$argument} = $attachment->GetHeader("X-RT-$argument");
- } elsif ( $TicketObj ) {
- $crypt{$argument} = $TicketObj->QueueObj->$argument();
- }
- }
-
- my $res = SignEncrypt( %args, %crypt );
- 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') {
- $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
- }
-
- # 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 = RT->Config->Get('SendmailArguments');
-
- # SetOutgoingMailFrom
- if ( RT->Config->Get('SetOutgoingMailFrom') ) {
- my $OutgoingMailAddress;
-
- if ($TicketObj) {
- my $QueueName = $TicketObj->QueueObj->Name;
- my $QueueAddressOverride = RT->Config->Get('OverrideOutgoingMailFrom')->{$QueueName};
-
- if ($QueueAddressOverride) {
- $OutgoingMailAddress = $QueueAddressOverride;
- } else {
- $OutgoingMailAddress = $TicketObj->QueueObj->CorrespondAddress;
- }
- }
-
- $OutgoingMailAddress ||= RT->Config->Get('OverrideOutgoingMailFrom')->{'Default'};
-
- $args .= " -f $OutgoingMailAddress"
- if $OutgoingMailAddress;
- }
-
- # Set Bounce Arguments
- $args .= ' '. RT->Config->Get('SendmailBounceArguments') if $args{'Bounce'};
-
- # 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;
- $args .= " -f $prefix$from\@$domain";
- }
-
- eval {
- # don't ignore CHLD signal to get proper exit code
- local $SIG{'CHLD'} = 'DEFAULT';
-
- open my $mail, "|$path $args" or die "couldn't execute program: $!";
-
- # if something wrong with $mail->print we will get PIPE signal, handle it
- local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
- $args{'Entity'}->print($mail);
-
- unless ( close $mail ) {
- die "close pipe failed: $!" if $!; # system error
- # sendmail exit statuses mostly errors with data not software
- # TODO: status parsing: core dump, exit on signal or EX_*
- my $msg = "$msgid: `$path $args` exitted with code ". ($?>>8);
- $msg = ", interrupted by signal ". ($?&127) if $?&127;
- $RT::Logger->error( $msg );
- }
- };
- if ( $@ ) {
- $RT::Logger->crit( "$msgid: Could not send mail with command `$path $args`: " . $@ );
- return 0;
- }
+ my $mimeobj = $args{'MIMEObj'};
+ if ($mimeobj) {
+ $mimeobj->sync_headers();
+ $entity->add_part($mimeobj);
}
- 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.");
- 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." );
- return 0;
- }
+
+ if ($RT::MailCommand eq 'sendmailpipe') {
+ open (MAIL, "|$RT::SendmailPath $RT::SendmailArguments") || return(0);
+ print MAIL $entity->as_string;
+ close(MAIL);
}
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." );
- 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,
- @_
- );
-
- 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;
+ $entity->send($RT::MailCommand, $RT::MailParams);
}
-
- $mail->head->set( $_ => $args{ $_ } )
- foreach grep defined $args{$_}, qw(To Cc Bcc From);
-
- 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;
-
- return SendForward( %args, Entity => $entity, Transaction => $txn );
-}
-
-=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',
- );
- $entity->add_part( $_ ) foreach
- map $_->ContentAsMIME,
- @{ $txns->ItemsArrayRef };
-
- return SendForward( %args, Entity => $entity, Ticket => $ticket, Template => 'Forward Ticket' );
-}
-
-=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->attach(
- Type => 'message/rfc822',
- Disposition => 'attachment',
- Description => 'forwarded message',
- Data => $entity->as_string,
- );
-
- my $from;
- my $subject = '';
- $subject = $txn->Subject if $txn;
- $subject ||= $ticket->Subject if $ticket;
- if ( RT->Config->Get('ForwardFromUser') ) {
- $from = ($txn || $ticket)->CurrentUser->UserObj->EmailAddress;
- } else {
- # XXX: what if want to forward txn of other object than ticket?
- $subject = AddSubjectTag( $subject, $ticket );
- $from = $ticket->QueueObj->CorrespondAddress
- || RT->Config->Get('CorrespondAddress');
- }
- $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) );
- $mail->head->set( From => EncodeToMIME( String => $from ) );
-
- 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("Send email successfully"));
-}
-
-=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) unless $value =~ /[^\x20-\x7e]/;
-
- $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);
-}
+# {{{ Create User
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',
- );
-
+ my ($Username, $Address, $Name, $ErrorsTo, $entity) = @_;
+ my $NewUser = RT::User->new($RT::SystemUser);
+
+ # This data is tainted by some Very Broken mailers.
+ # (Sometimes they send raw ISO 8859-1 data here. fear that.
+ require Encode;
+ $Username = Encode::encode(utf8 => $Username, Encode::FB_PERLQQ()) if defined $Username;
+ $Name = Encode::encode(utf8 => $Name, Encode::FB_PERLQQ()) if defined $Name;
+
+ 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 ) {
+
+ 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',
- );
+
+ 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 = new RT::CurrentUser;
- $CurrentUser->LoadByEmail( $Address );
+ 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'
- );
+ 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;
}
+# }}}
+# {{{ ParseCcAddressesFromHead
+=head2 ParseCcAddressesFromHead HASHREF
-
-=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
+Takes a hashref object 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 @recipients =
- map lc $_->address,
- map Email::Address->parse( $args{'Head'}->get( $_ ) ),
- qw(To Cc);
-
- my @res;
- foreach my $address ( @recipients ) {
- $address = $args{'CurrentUser'}->UserObj->CanonicalizeEmailAddress( $address );
- next if lc $args{'CurrentUser'}->EmailAddress eq $address;
- next if lc $args{'QueueObj'}->CorrespondAddress eq $address;
- next if lc $args{'QueueObj'}->CommentAddress eq $address;
- next if RT::EmailParser->IsRTAddress( $address );
-
- push @res, $address;
- }
- return @res;
+ my %args = ( Head => undef,
+ QueueObj => undef,
+ CurrentUser => undef,
+ @_ );
+
+ my (@Addresses);
+
+ my @ToObjs = Mail::Address->parse($args{'Head'}->get('To'));
+ my @CcObjs = Mail::Address->parse($args{'Head'}->get('Cc'));
+
+ foreach my $AddrObj (@ToObjs, @CcObjs) {
+ my $Address = $AddrObj->address;
+ $Address = $args{'CurrentUser'}->UserObj->CanonicalizeEmailAddress($Address);
+ next if ($args{'CurrentUser'}->EmailAddress =~ /^$Address$/i);
+ next if ($args{'QueueObj'}->CorrespondAddress =~ /^$Address$/i);
+ next if ($args{'QueueObj'}->CommentAddress =~ /^$Address$/i);
+ next if (RT::EmailParser::IsRTAddress(undef, $Address));
+
+ push (@Addresses, $Address);
+ }
+ return (@Addresses);
}
+# }}}
+
+# {{{ ParseSenderAdddressFromHead
-=head2 ParseSenderAddressFromHead HEAD
+=head2 ParseSenderAddressFromHead
-Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
+Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
of the From (evaluated in order of Reply-To:, From:, Sender)
=cut
sub ParseSenderAddressFromHead {
my $head = shift;
-
#Figure out who's sending this message.
- foreach my $header ('Reply-To', 'From', 'Sender') {
- my $addr_line = $head->get($header) || next;
- my ($addr, $name) = ParseAddressFromHeader( $addr_line );
- # only return if the address is not empty
- return ($addr, $name) if $addr;
- }
-
- return (undef, undef);
+ my $From = $head->get('Reply-To') ||
+ $head->get('From') ||
+ $head->get('Sender');
+ return (ParseAddressFromHeader($From));
}
+# }}}
+
+# {{{ ParseErrorsToAdddressFromHead
-=head2 ParseErrorsToAddressFromHead HEAD
+=head2 ParseErrorsToAddressFromHead
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)
+of the From (evaluated in order of 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);
- }
+ 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);
+ }
}
}
+# }}}
-
+# {{{ ParseAddressFromHeader
=head2 ParseAddressFromHeader ADDRESS
-Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
+Takes an address from $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);
+sub ParseAddressFromHeader{
+ my $Addr = shift;
+
+ my @Addresses = Mail::Address->parse($Addr);
+
+ my $AddrObj = $Addresses[0];
- my ($AddrObj) = grep ref $_, @Addresses;
- unless ( $AddrObj ) {
- return ( undef, undef );
+ unless (ref($AddrObj)) {
+ return(undef,undef);
}
-
- my $Name = ( $AddrObj->name || $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
-
+
+ my $Name = ($AddrObj->phrase || $AddrObj->comment || $AddrObj->address);
+
#Lets take the from and load a user object.
my $Address = $AddrObj->address;
- return ( $Address, $Name );
-}
-
-=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 .">" ;
+ return ($Address, $Name);
}
+# }}}
-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' => join ' ', @rtid? (@rtid) : (@id) ) if @id || @rtid;
- $mail->head->set( 'References' => join ' ', @references );
-}
-
-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)/ /gi;
- chomp $subject;
- return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
-}
-
-
-=head2 Gateway ARGSREF
-
-
-Takes parameters:
-
- action
- queue
- message
+=head2 Gateway
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::Interface::Email::/;
- $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;
+ my %args = ( message => undef,
+ queue => 1,
+ action => 'correspond',
+ ticket => undef,
+ @_ );
# Validate the action
- my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
- unless ($status) {
- return (
- -75,
- "Invalid 'action' parameter "
- . $actions[0]
- . " for queue "
- . $args{'queue'},
- undef
- );
+ unless ( $args{'action'} =~ /^(comment|correspond|action)$/ ) {
+
+ # Can't safely loc this. What object do we loc around?
+ return ( 0, "Invalid 'action' parameter", undef );
}
my $parser = RT::EmailParser->new();
- $parser->SmartParseMIMEEntityFromScalar(
- Message => $args{'message'},
- Decode => 0,
- Exact => 1,
- );
+ $parser->ParseMIMEEntityFromScalar( $args{'message'} );
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 $head = $Message->head;
- 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->_PostProcessNewEntity;
+ my ( $CurrentUser, $AuthStat, $status, $error );
- my $head = $Message->head;
- my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
+ my $ErrorsTo = ParseErrorsToAddressFromHead($head);
- my $MessageId = $head->get('Message-ID')
- || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
+ my $MessageId = $head->get('Message-Id')
+ || "<no-message-id-" . time . rand(2000) . "\@.$RT::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'} ||= ParseTicketId( $Subject );
- $SystemTicket = RT::Ticket->new( $RT::SystemUser );
- $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
- if ( $SystemTicket->id ) {
- $Right = 'ReplyToTicket';
- } else {
- $Right = 'CreateTicket';
+ $args{'ticket'} ||= $parser->ParseTicketId($Subject);
+
+ my $SystemTicket;
+ if ($args{'ticket'} ) {
+ $SystemTicket = RT::Ticket->new($RT::SystemUser);
+ $SystemTicket->Load($args{'ticket'});
}
#Set up a queue object
- my $SystemQueueObj = RT::Queue->new( $RT::SystemUser );
+ 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 ) {
+ # We can safely have no queue of we have a known-good ticket
+ unless ( $args{'ticket'} || $SystemQueueObj->id ) {
MailError(
- To => $ErrorsTo,
- Subject => "Permission Denied",
- Explanation =>
- "You do not have permission to communicate with RT",
- MIMEObj => $Message
- );
- return (
- 0,
- "$ErrorsTo tried to submit a message to "
- . $args{'Queue'}
- . " without permission.",
- undef
- );
- }
-
-
- unless ($should_store_machine_generated_message) {
- return ( 0, $result, undef );
+ To => $RT::OwnerEmail,
+ Subject => "RT Bounce: $Subject",
+ Explanation => "RT couldn't find the queue: " . $args{'queue'},
+ MIMEObj => $Message );
+ return ( 0, "RT couldn't find the queue: " . $args{'queue'}, 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
- );
- }
-
- my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
- Queue => $SystemQueueObj->Id,
- Subject => $Subject,
- 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 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: $Subject",
- Explanation => $msg,
- MIMEObj => $Message
- );
- return ( 0, "Message 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
+ # -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 = ();
-
+ push @RT::MailPlugins, "Auth::MailFrom" unless @RT::MailPlugins;
# Since this needs loading, no matter what
- foreach (@{ $args{MailPlugins} }) {
- my ($Code, $NewAuthStat);
+
+ for (@RT::MailPlugins) {
+ my $Code;
+ my $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;
+ else {
+ $_ = "RT::Interface::Email::$_" unless /^RT::Interface::Email::/;
+ eval "require $_;";
+ if ($@) {
+ die ("Couldn't load module $_: $@");
+ next;
+ }
+ no strict 'refs';
+ if ( !defined( $Code = *{ $_ . "::GetCurrentUser" }{CODE} ) ) {
+ die ("No GetCurrentUser code found in $_ module");
+ next;
+ }
}
- # strip actions we should skip
- @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
- if $AuthStat == -2;
- last unless @{$args{Actions}};
+ ( $CurrentUser, $NewAuthStat ) = $Code->( Message => $Message,
+ CurrentUser => $CurrentUser,
+ AuthLevel => $AuthStat,
+ Action => $args{'action'},
+ Ticket => $SystemTicket,
+ Queue => $SystemQueueObj );
+ # You get the highest level of authentication you were assigned.
last if $AuthStat == -1;
+ $AuthStat = $NewAuthStat if $NewAuthStat > $AuthStat;
}
- return $AuthStat if !wantarray;
-
- return ($AuthStat, $CurrentUser, $error);
-}
-
-sub _RunUnsafeAction {
- my %args = (
- Action => undef,
- ErrorsTo => undef,
- Message => undef,
- Ticket => undef,
- CurrentUser => undef,
- @_
- );
-
- 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" );
- }
- } elsif ( $args{'Action'} =~ /^resolve$/i ) {
- my ( $status, $msg ) = $args{'Ticket'}->SetStatus('resolved');
- 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" );
- }
- } else {
- return ( 0, "Not supported unsafe action $args{'Action'}", $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'}]}.
+ # {{{ If authentication fails and no new user was created, get out.
+ if ( !$CurrentUser or !$CurrentUser->Id or $AuthStat == -1 ) {
-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,
+ # If the plugins refused to create one, they lose.
+ MailError(
+ 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.
+Your RT administrator needs to grant 'Everyone' the right 'CreateTicket'
+for this queue.
+
EOT
- MIMEObj => $args{'Message'},
- LogLevel => 'error'
- );
+ MIMEObj => $Message,
+ LogLevel => 'error' )
+ unless $AuthStat == -1;
+ return ( 0, "Could not load a valid user", undef );
}
-}
-=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);
+ # }}}
+ # {{{ Lets check for mail loops of various sorts.
my $IsAutoGenerated = CheckForAutoGenerated($head);
my $IsSuspiciousSender = CheckForSuspiciousSender($head);
@@ -1704,77 +496,153 @@ sub _HandleMachineGeneratedMail {
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 ) {
+ if ( $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
$SquelchReplies = 1;
- $ErrorsTo = $owner_mail;
+ $ErrorsTo = $RT::OwnerEmail;
+ }
+
+ # }}}
+
+ # {{{ Drop it if it's disallowed
+ if ( $AuthStat == 0 ) {
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Permission Denied",
+ Explanation => "You do not have permission to communicate with RT",
+ MIMEObj => $Message );
}
+ # }}}
+ # {{{ Warn someone if it's a loop
+
# 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.");
+ $RT::Logger->crit("RT Recieved mail ($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}
- );
- }
+ if ($RT::LoopsToRTOwner) {
+ MailError( To => $RT::OwnerEmail,
+ Subject => "RT Bounce: $Subject",
+ Explanation => "RT thinks this message may be a bounce",
+ MIMEObj => $Message );
- #Do we actually want to store it?
- return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
- unless RT->Config->Get('StoreLoops');
+ #Do we actually want to store it?
+ return ( 0, "Message Bounced", undef ) unless ($RT::StoreLoops);
+ }
}
- # Squelch replies if necessary
+ # }}}
+
+ # {{{ Squelch replies if necessary
# Don't let the user stuff the RT-Squelch-Replies-To header.
if ( $head->get('RT-Squelch-Replies-To') ) {
- $head->add(
- 'RT-Relocated-Squelch-Replies-To',
- $head->get('RT-Squelch-Replies-To')
- );
+ $head->add( 'RT-Relocated-Squelch-Replies-To',
+ $head->get('RT-Squelch-Replies-To') );
$head->delete('RT-Squelch-Replies-To');
}
if ($SquelchReplies) {
+ ## TODO: This is a hack. It should be some other way to
+ ## indicate that the transaction should be "silent".
- # 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->add( 'RT-Squelch-Replies-To', $Sender );
- $head->add( 'RT-DetectedAutoGenerated', 'true' );
+ $head->add( 'RT-Squelch-Replies-To', $Sender );
}
- return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
-}
-=head2 IsCorrectAction
+ # }}}
+
+ my $Ticket = RT::Ticket->new($CurrentUser);
-Returns a list of valid actions we've found for this message
+ # {{{ If we don't have a ticket Id, we're creating a new ticket
+ if ( !$args{'ticket'} ) {
-=cut
+ # {{{ Create a new ticket
+
+ my @Cc;
+ my @Requestors = ( $CurrentUser->id );
-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)$/;
+ if ($RT::ParseNewMessageForTicketCcs) {
+ @Cc = ParseCcAddressesFromHead( Head => $head,
+ CurrentUser => $CurrentUser,
+ QueueObj => $SystemQueueObj );
+ }
+
+ my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
+ Queue => $SystemQueueObj->Id,
+ Subject => $Subject,
+ Requestor => \@Requestors,
+ Cc => \@Cc,
+ MIMEObj => $Message );
+ if ( $id == 0 ) {
+ MailError( To => $ErrorsTo,
+ Subject => "Ticket creation failed",
+ Explanation => $ErrStr,
+ MIMEObj => $Message );
+ $RT::Logger->error("Create failed: $id / $Transaction / $ErrStr ");
+ return ( 0, "Ticket creation failed", $Ticket );
+ }
+
+ # }}}
+ }
+
+ # }}}
+
+ # If the action is comment, add a comment.
+ elsif ( $args{'action'} =~ /^(comment|correspond)$/i ) {
+ $Ticket->Load($args{'ticket'});
+ unless ( $Ticket->Id ) {
+ my $message = "Could not find a ticket with id ".$args{'ticket'};
+ MailError( To => $ErrorsTo,
+ Subject => "Message not recorded",
+ Explanation => $message,
+ MIMEObj => $Message );
+
+ return ( 0, $message);
+ }
+
+ my ( $status, $msg );
+ if ( $args{'action'} =~ /^correspond$/ ) {
+ ( $status, $msg ) = $Ticket->Correspond( MIMEObj => $Message );
+ }
+ else {
+ ( $status, $msg ) = $Ticket->Comment( MIMEObj => $Message );
+ }
+ unless ($status) {
+
+ #Warn the sender that we couldn't actually submit the comment.
+ MailError( To => $ErrorsTo,
+ Subject => "Message not recorded",
+ Explanation => $msg,
+ MIMEObj => $Message );
+ return ( 0, "Message not recorded", $Ticket );
+ }
}
- return ( 1, @actions );
+
+ else {
+
+ #Return mail to the sender with an error
+ MailError( To => $ErrorsTo,
+ Subject => "RT Configuration error",
+ Explanation => "'"
+ . $args{'action'}
+ . "' not a recognized action."
+ . " Your RT administrator has misconfigured "
+ . "the mail aliases which invoke RT",
+ MIMEObj => $Message );
+ $RT::Logger->crit( $args{'action'} . " type unknown for $MessageId" );
+ return ( 0, "Configuration error: " . $args{'action'} . " not a recognized action", $Ticket );
+
+ }
+
+
+return ( 1, "Success", $Ticket );
}
eval "require RT::Interface::Email_Vendor";
-die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Vendor.pm} );
+die $@ if ($@ && $@ !~ qr{^Can't locate RT/Interface/Email_Vendor.pm});
eval "require RT::Interface::Email_Local";
-die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Local.pm} );
+die $@ if ($@ && $@ !~ qr{^Can't locate RT/Interface/Email_Local.pm});
1;
diff --git a/rt/lib/RT/Interface/Web.pm b/rt/lib/RT/Interface/Web.pm
index b4279fb4b..5097f54a4 100644
--- a/rt/lib/RT/Interface/Web.pm
+++ b/rt/lib/RT/Interface/Web.pm
@@ -1,734 +1,148 @@
-# BEGIN BPS TAGGED BLOCK {{{
-#
-# COPYRIGHT:
-#
-# This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
-# <jesse@bestpractical.com>
-#
-# (Except where explicitly superseded by other copyright notices)
-#
-#
-# LICENSE:
-#
+# BEGIN LICENSE BLOCK
+#
+# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+#
+# (Except where explictly superceded by other copyright notices)
+#
# 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 }}}
-
+#
+# Unless otherwise specified, all modifications, corrections or
+# extensions to this work which alter its source code become the
+# property of Best Practical Solutions, LLC when submitted for
+# inclusion in the work.
+#
+#
+# END LICENSE 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
+=begin testing
-=cut
-
-use strict;
-use warnings;
-
-package RT::Interface::Web;
-
-use RT::SavedSearches;
-use URI qw();
-use RT::Interface::Web::Session;
-use Digest::MD5 ();
-use Encode qw();
-
-# {{{ EscapeUTF8
-
-=head2 EscapeUTF8 SCALARREF
+use_ok(RT::Interface::Web);
-does a css-busting but minimalist escaping of whatever html you're passing in.
+=end testing
=cut
-sub EscapeUTF8 {
- my $ref = shift;
- return unless defined $$ref;
-
- $$ref =~ s/&/&#38;/g;
- $$ref =~ s/</&lt;/g;
- $$ref =~ s/>/&gt;/g;
- $$ref =~ s/\(/&#40;/g;
- $$ref =~ s/\)/&#41;/g;
- $$ref =~ s/"/&#34;/g;
- $$ref =~ s/'/&#39;/g;
-}
-
-# }}}
-
-# {{{ EscapeURI
-
-=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;
-}
-
-# }}}
+package RT::Interface::Web;
+use strict;
-# {{{ WebCanonicalizeInfo
-=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'};
-}
+# {{{ sub NewApacheHandler
-# }}}
+=head2 NewApacheHandler
-# {{{ WebExternalAutoInfo
-
-=head2 WebExternalAutoInfo($user);
-
-Returns a hash of user attributes, used when WebExternalAuto is set.
+ Takes extra options to pass to HTML::Mason::ApacheHandler->new
+ Returns a new Mason::ApacheHandler object
=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
- }
+sub NewApacheHandler {
+ require HTML::Mason::ApacheHandler;
+ my $ah = new HTML::Mason::ApacheHandler(
+
+ comp_root => [
+ [ local => $RT::MasonLocalComponentRoot ],
+ [ standard => $RT::MasonComponentRoot ]
+ ],
+ args_method => "CGI",
+ default_escape_flags => 'h',
+ allow_globals => [qw(%session)],
+ data_dir => "$RT::MasonDataDir",
+ @_
+ );
- # and return the wad of stuff
- return {%user_info};
+ $ah->interp->set_escape( h => \&RT::Interface::Web::EscapeUTF8 );
+
+ return ($ah);
}
# }}}
-sub HandleRequest {
- my $ARGS = shift;
-
- $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->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') );
-
- DecodeARGS($ARGS);
- PreprocessTimeUpdates($ARGS);
-
- MaybeShowInstallModePage();
-
- $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
- SendSessionCookie();
- $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
-
- 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' );
-
- unless ( _UserLoggedIn() ) {
- _ForceLogout();
-
- # If the user is logging in, let's authenticate
- if ( defined $ARGS->{user} && defined $ARGS->{pass} ) {
- AttemptPasswordAuthentication($ARGS);
- } else {
- # if no credentials then show him login page
- $HTML::Mason::Commands::m->comp( '/Elements/Login', %$ARGS );
- $HTML::Mason::Commands::m->abort;
- }
- }
-
- # 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();
-}
-
-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 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 !~ '^(/+)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');
-
- # If it's a noauth file, don't ask for auth.
- SendSessionCookie();
- $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
- $m->abort;
-}
-
-=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;
-
- SendSessionCookie();
-
- # 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 =~ '^(/+)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;
- }
-
- 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'};
- $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc( 'Cannot create user: [_1]', $msg ) )
- if RT->Config->Get('WebFallbackToInternalAuth');;
- $m->abort();
- }
- }
-
- if ( _UserLoggedIn() ) {
- $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
- } else {
- delete $HTML::Mason::Commands::session{'CurrentUser'};
- $user = $orig_user;
-
- if ( RT->Config->Get('WebExternalOnly') ) {
- $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('You are not an authorized user') );
- $m->abort();
- }
- }
- } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
- unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
- # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
- $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('You are not an authorized user') );
- $m->abort();
- }
- } 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 NewCGIHandler
-sub AttemptPasswordAuthentication {
- my $ARGS = shift;
- my $user_obj = RT::CurrentUser->new();
- $user_obj->Load( $ARGS->{user} );
+=head2 NewCGIHandler
- 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->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('Your username or password is incorrect'), );
- $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
- $m->abort;
- }
-
- $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
- InstantiateNewSession();
- $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
- $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
-}
-
-=head2 LoadSessionFromCookie
-
-Load or setup a session cookie for the current user.
+ Returns a new Mason::CGIHandler object
=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 ) {
- undef $cookies{$cookiename};
- }
- 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;
-}
-
-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 )
+sub NewCGIHandler {
+ my %args = (
+ @_
);
- $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( RT->Config->Get('WebURL') );
-
- # 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::CanoniaclRedirectURLs 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'} );
- $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 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
+ my $handler = HTML::Mason::CGIHandler->new(
+ comp_root => [
+ [ local => $RT::MasonLocalComponentRoot ],
+ [ standard => $RT::MasonComponentRoot ]
+ ],
+ data_dir => "$RT::MasonDataDir",
+ default_escape_flags => 'h',
+ allow_globals => [qw(%session)]
+ );
+
-sub StaticFileHeaders {
- my $date = RT::Date->new($RT::SystemUser);
+ $handler->interp->set_escape( h => \&RT::Interface::Web::EscapeUTF8 );
- # make cache public
- $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
- # Expire things in a month.
- $date->Set( Value => time + 30 * 24 * 60 * 60 );
- $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
+ return ($handler);
- # 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 SendStaticFile
-Takes a File => path and a Type => Content-type
+# {{{ EscapeUTF8
-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
+=head2 EscapeUTF8 SCALARREF
-Will set caching headers using StaticFileHeaders
+does a css-busting but minimalist escaping of whatever html you're passing in.
=cut
-sub SendStaticFile {
- my $self = shift;
- my %args = @_;
- my $file = $args{File};
- my $type = $args{Type};
-
- $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 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!&nbsp;!!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
- RT::Interface::Web::EscapeUTF8( \$sig );
- 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 EscapeUTF8 {
+ my $ref = shift;
+ my $val = $$ref;
+ use bytes;
+ $val =~ s/&/&#38;/g;
+ $val =~ s/</&lt;/g;
+ $val =~ s/>/&gt;/g;
+ $val =~ s/\(/&#40;/g;
+ $val =~ s/\)/&#41;/g;
+ $val =~ s/"/&#34;/g;
+ $val =~ s/'/&#39;/g;
+ $$ref = $val;
+ Encode::_utf8_on($$ref);
}
-sub LogRecordedSQLStatements {
- my $log_sql_statements = RT->Config->Get('StatementLog');
-
- return unless ($log_sql_statements);
-
- my @log = $RT::Handle->SQLStatementLog;
- $RT::Handle->ClearSQLStatementLog;
- 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{qq|'$_'|} @bind]} ]" : "" )
- );
- }
+# }}}
-}
package HTML::Mason::Commands;
-
+use strict;
use vars qw/$r $m %session/;
+
# {{{ loc
=head2 loc ARRAY
@@ -742,26 +156,19 @@ through
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];
+ if ($session{'CurrentUser'} &&
+ UNIVERSAL::can($session{'CurrentUser'}, 'loc')){
+ return($session{'CurrentUser'}->loc(@_));
+ }
+ else {
+ my $u = RT::CurrentUser->new($RT::SystemUser);
+ return ($u->loc(@_));
}
}
# }}}
+
# {{{ loc_fuzzy
=head2 loc_fuzzy STRING
@@ -775,41 +182,40 @@ 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) );
+ 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);
+ return ($u->loc_fuzzy($msg));
}
}
# }}}
+
# {{{ sub Abort
# 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 );
+ if ($session{'ErrorDocument'} &&
+ $session{'ErrorDocumentType'}) {
+ $r->content_type($session{'ErrorDocumentType'});
+ $m->comp($session{'ErrorDocument'} , Why => shift);
$m->abort;
- } else {
- $m->comp( "/Elements/Error", Why => $why, %args );
+ }
+ else {
+ $m->comp("/Elements/Error" , Why => shift);
$m->abort;
}
}
# }}}
-# {{{ sub CreateTicket
+# {{{ sub CreateTicket
=head2 CreateTicket ARGS
@@ -833,160 +239,80 @@ sub CreateTicket {
Abort('You have no permission to create tickets in that queue.');
}
- my $due;
- if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
- $due = new RT::Date( $session{'CurrentUser'} );
- $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
- }
- my $starts;
- if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
- $starts = new RT::Date( $session{'CurrentUser'} );
- $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
- }
+ my $due = new RT::Date( $session{'CurrentUser'} );
+ $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
+ my $starts = new RT::Date( $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 @Requestors = split ( /\s*,\s*/, $ARGS{'Requestors'} );
+ my @Cc = split ( /\s*,\s*/, $ARGS{'Cc'} );
+ my @AdminCc = split ( /\s*,\s*/, $ARGS{'AdminCc'} );
my $MIMEObj = MakeMIMEEntity(
- Subject => $ARGS{'Subject'},
- From => $ARGS{'From'},
- Cc => $ARGS{'Cc'},
- Body => $sigless,
- Type => $ARGS{'ContentType'},
+ Subject => $ARGS{'Subject'},
+ From => $ARGS{'From'},
+ Cc => $ARGS{'Cc'},
+ Body => $ARGS{'Content'},
);
- if ( $ARGS{'Attachments'} ) {
- my $rv = $MIMEObj->make_multipart;
- $RT::Logger->error("Couldn't make multipart message")
- if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
-
- foreach ( values %{ $ARGS{'Attachments'} } ) {
- unless ($_) {
- $RT::Logger->error("Couldn't add empty attachemnt");
- next;
- }
- $MIMEObj->add_part($_);
- }
- }
-
- foreach my $argument (qw(Encrypt Sign)) {
- $MIMEObj->head->add( "X-RT-$argument" => $ARGS{$argument} ) if defined $ARGS{$argument};
+ if ($ARGS{'Attachments'}) {
+ $MIMEObj->make_multipart;
+ $MIMEObj->add_part($_) foreach values %{$ARGS{'Attachments'}};
}
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'},
+ Queue => $ARGS{'Queue'},
+ Owner => $ARGS{'Owner'},
InitialPriority => $ARGS{'InitialPriority'},
FinalPriority => $ARGS{'FinalPriority'},
TimeLeft => $ARGS{'TimeLeft'},
- TimeEstimated => $ARGS{'TimeEstimated'},
+ TimeEstimated => $ARGS{'TimeEstimated'},
TimeWorked => $ARGS{'TimeWorked'},
+ Requestor => \@Requestors,
+ Cc => \@Cc,
+ AdminCc => \@AdminCc,
Subject => $ARGS{'Subject'},
Status => $ARGS{'Status'},
- Due => $due ? $due->ISO : undef,
- Starts => $starts ? $starts->ISO : undef,
+ Due => $due->ISO,
+ Starts => $starts->ISO,
MIMEObj => $MIMEObj
);
-
- my @temp_squelch;
- foreach my $type (qw(Requestor Cc AdminCc)) {
- push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
- if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
-
- }
-
- if (@temp_squelch) {
- require RT::Action::SendEmail;
- RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
+ foreach my $arg (%ARGS) {
+ if ($arg =~ /^CustomField-(\d+)(.*?)$/) {
+ next if ($arg =~ /-Magic$/);
+ $create_args{"CustomField-".$1} = $ARGS{"$arg"};
+ }
}
-
- if ( $ARGS{'AttachTickets'} ) {
- require RT::Action::SendEmail;
- RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
- ref $ARGS{'AttachTickets'}
- ? @{ $ARGS{'AttachTickets'} }
- : ( $ARGS{'AttachTickets'} ) );
+ my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
+ unless ( $id && $Trans ) {
+ Abort($ErrMsg);
}
+ my @linktypes = qw( DependsOn MemberOf RefersTo );
- foreach my $arg ( keys %ARGS ) {
- next if $arg =~ /-(?:Magic|Category)$/;
-
- if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
- $create_args{$arg} = $ARGS{$arg};
+ foreach my $linktype (@linktypes) {
+ foreach my $luri ( split ( / /, $ARGS{"new-$linktype"} ) ) {
+ $luri =~ s/\s*$//; # Strip trailing whitespace
+ my ( $val, $msg ) = $Ticket->AddLink(
+ Target => $luri,
+ Type => $linktype
+ );
+ push ( @Actions, $msg ) unless ($val);
}
- # Object-RT::Ticket--CustomField-3-Values
- elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
- my $cfid = $1;
-
- my $cf = RT::CustomField->new( $session{'CurrentUser'} );
- $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;
+ foreach my $luri ( split ( / /, $ARGS{"$linktype-new"} ) ) {
+ my ( $val, $msg ) = $Ticket->AddLink(
+ Base => $luri,
+ Type => $linktype
+ );
- $create_args{"CustomField-$cfid"} = \@values;
+ push ( @Actions, $msg ) unless ($val);
}
}
- # 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 ) );
+ push ( @Actions, split("\n", $ErrMsg) );
unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
- Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
+ Abort( "No permission to view newly created ticket #"
+ . $Ticket->id . "." );
}
return ( $Ticket, @Actions );
@@ -1028,130 +354,62 @@ sub LoadTicket {
# {{{ sub ProcessUpdateMessage
-=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
-
sub ProcessUpdateMessage {
+ #TODO document what else this takes.
my %args = (
- ARGSRef => undef,
- TicketObj => undef,
- SkipSignatureOnly => 1,
+ ARGSRef => undef,
+ Actions => undef,
+ TicketObj => undef,
@_
);
- if ( $args{ARGSRef}->{'UpdateAttachments'}
- && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
- {
- delete $args{ARGSRef}->{'UpdateAttachments'};
- }
+ #Make the update content have no 'weird' newlines in it
+ if ( $args{ARGSRef}->{'UpdateContent'} ) {
- # 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,
- );
-
- # If, after stripping the signature, we have no message, move the
- # UpdateTimeWorked into adjusted TimeWorked, so that a later
- # ProcessBasics can deal -- then bail out.
- 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'};
+ if (
+ $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject() )
+ {
+ $args{ARGSRef}->{'UpdateSubject'} = undef;
}
- 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'},
- );
- $Message->head->add( 'Message-ID' => 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
+ my $Message = MakeMIMEEntity(
+ Subject => $args{ARGSRef}->{'UpdateSubject'},
+ Body => $args{ARGSRef}->{'UpdateContent'},
);
- }
-
- if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
- $Message->make_multipart;
- $Message->add_part($_) foreach values %{ $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 $bcc = $args{ARGSRef}->{'UpdateBcc'};
- my $cc = $args{ARGSRef}->{'UpdateCc'};
-
- my %message_args = (
- CcMessageTo => $cc,
- BccMessageTo => $bcc,
- Sign => $args{ARGSRef}->{'Sign'},
- Encrypt => $args{ARGSRef}->{'Encrypt'},
- MIMEObj => $Message,
- TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
- );
-
- 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;
- }
+ if ($args{ARGSRef}->{'UpdateAttachments'}) {
+ $Message->make_multipart;
+ $Message->add_part($_) foreach values %{$args{ARGSRef}->{'UpdateAttachments'}};
}
- }
- 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.") );
+ ## TODO: Implement public comments
+ if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
+ my ( $Transaction, $Description ) = $args{TicketObj}->Comment(
+ CcMessageTo => $args{ARGSRef}->{'UpdateCc'},
+ BccMessageTo => $args{ARGSRef}->{'UpdateBcc'},
+ MIMEObj => $Message,
+ TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
+ );
+ push ( @{ $args{Actions} }, $Description );
+ }
+ elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
+ my ( $Transaction, $Description ) = $args{TicketObj}->Correspond(
+ CcMessageTo => $args{ARGSRef}->{'UpdateCc'},
+ BccMessageTo => $args{ARGSRef}->{'UpdateBcc'},
+ MIMEObj => $Message,
+ TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
+ );
+ push ( @{ $args{Actions} }, $Description );
+ }
+ else {
+ push ( @{ $args{'Actions'} },
+ loc("Update type was neither correspondence nor comment.").
+ " ".
+ loc("Update not recorded.")
+ );
+ }
}
- return @results;
}
# }}}
@@ -1162,8 +420,6 @@ sub ProcessUpdateMessage {
Takes a paramhash Subject, Body and AttachmentFieldName.
-Also takes Form, Cc and Type as optional paramhash keys.
-
Returns a MIME::Entity.
=cut
@@ -1177,66 +433,291 @@ sub MakeMIMEEntity {
Cc => undef,
Body => undef,
AttachmentFieldName => undef,
- Type => undef,
- @_,
- );
- my $Message = MIME::Entity->build(
- Type => 'multipart/mixed',
- Subject => $args{'Subject'} || "",
- From => $args{'From'},
- Cc => $args{'Cc'},
+ map Encode::encode_utf8($_), @_,
);
- if ( defined $args{'Body'} && length $args{'Body'} ) {
-
- # Make the update content have no 'weird' newlines in it
- $args{'Body'} =~ s/\r\n/\n/gs;
+ #Make the update content have no 'weird' newlines in it
+ $args{'Body'} =~ s/\r\n/\n/gs;
+ my $Message;
+ {
# MIME::Head is not happy in utf-8 domain. This only happens
# when processing an incoming email (so far observed).
no utf8;
use bytes;
- $Message->attach(
- Type => $args{'Type'} || 'text/plain',
- Charset => 'UTF-8',
- Data => $args{'Body'},
+ $Message = MIME::Entity->build(
+ Subject => $args{'Subject'} || "",
+ From => $args{'From'},
+ Cc => $args{'Cc'},
+ Data => [ $args{'Body'} ]
+ );
+ }
+
+ my $cgi_object = $m->cgi_object;
+
+ if (my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
+
+
+
+ use File::Temp qw(tempfile tempdir);
+
+ #foreach my $filehandle (@filenames) {
+
+ my ( $fh, $temp_file ) = tempfile();
+
+ binmode $fh; #thank you, windows
+ my ($buffer);
+ while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
+ print $fh $buffer;
+ }
+
+ my $uploadinfo = $cgi_object->uploadInfo($filehandle);
+
+ # Prefer the cached name first over CGI.pm stringification.
+ my $filename = $RT::Mason::CGI::Filename;
+ $filename = "$filehandle" unless defined($filename);
+
+ $filename =~ s#^.*[\\/]##;
+
+ $Message->attach(
+ Path => $temp_file,
+ Filename => $filename,
+ Type => $uploadinfo->{'Content-Type'},
+ );
+ close($fh);
+
+ # }
+
+ }
+
+ $Message->make_singlepart();
+ RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
+
+ return ($Message);
+
+}
+
+# }}}
+
+# {{{ sub ProcessSearchQuery
+
+=head2 ProcessSearchQuery
+
+ Takes a form such as the one filled out in webrt/Search/Elements/PickRestriction and turns it into something that RT::Tickets can understand.
+
+TODO Doc exactly what comes in the paramhash
+
+
+=cut
+
+sub ProcessSearchQuery {
+ my %args = @_;
+
+ ## TODO: The only parameter here is %ARGS. Maybe it would be
+ ## cleaner to load this parameter as $ARGS, and use $ARGS->{...}
+ ## instead of $args{ARGS}->{...} ? :)
+
+ #Searches are sticky.
+ if ( defined $session{'tickets'} ) {
+
+ # Reset the old search
+ $session{'tickets'}->GotoFirstItem;
+ }
+ else {
+
+ # Init a new search
+ $session{'tickets'} = RT::Tickets->new( $session{'CurrentUser'} );
+ }
+
+ #Import a bookmarked search if we have one
+ if ( defined $args{ARGS}->{'Bookmark'} ) {
+ $session{'tickets'}->ThawLimits( $args{ARGS}->{'Bookmark'} );
+ }
+
+ # {{{ Goto next/prev page
+ if ( $args{ARGS}->{'GotoPage'} eq 'Next' ) {
+ $session{'tickets'}->NextPage;
+ }
+ elsif ( $args{ARGS}->{'GotoPage'} eq 'Prev' ) {
+ $session{'tickets'}->PrevPage;
+ }
+ elsif ( $args{ARGS}->{'GotoPage'} > 0 ) {
+ $session{'tickets'}->GotoPage( $args{ARGS}->{GotoPage} - 1 );
+ }
+
+ # }}}
+
+ # {{{ Deal with limiting the search
+
+ if ( $args{ARGS}->{'RefreshSearchInterval'} ) {
+ $session{'tickets_refresh_interval'} =
+ $args{ARGS}->{'RefreshSearchInterval'};
+ }
+
+ if ( $args{ARGS}->{'TicketsSortBy'} ) {
+ $session{'tickets_sort_by'} = $args{ARGS}->{'TicketsSortBy'};
+ $session{'tickets_sort_order'} = $args{ARGS}->{'TicketsSortOrder'};
+ $session{'tickets'}->OrderBy(
+ FIELD => $args{ARGS}->{'TicketsSortBy'},
+ ORDER => $args{ARGS}->{'TicketsSortOrder'}
+ );
+ }
+
+ # }}}
+
+ # {{{ Set the query limit
+ if ( defined $args{ARGS}->{'RowsPerPage'} ) {
+ $RT::Logger->debug(
+ "limiting to " . $args{ARGS}->{'RowsPerPage'} . " rows" );
+
+ $session{'tickets_rows_per_page'} = $args{ARGS}->{'RowsPerPage'};
+ $session{'tickets'}->RowsPerPage( $args{ARGS}->{'RowsPerPage'} );
+ }
+
+ # }}}
+ # {{{ Limit priority
+ if ( $args{ARGS}->{'ValueOfPriority'} ne '' ) {
+ $session{'tickets'}->LimitPriority(
+ VALUE => $args{ARGS}->{'ValueOfPriority'},
+ OPERATOR => $args{ARGS}->{'PriorityOp'}
+ );
+ }
+
+ # }}}
+ # {{{ Limit owner
+ if ( $args{ARGS}->{'ValueOfOwner'} ne '' ) {
+ $session{'tickets'}->LimitOwner(
+ VALUE => $args{ARGS}->{'ValueOfOwner'},
+ OPERATOR => $args{ARGS}->{'OwnerOp'}
);
}
- if ( $args{'AttachmentFieldName'} ) {
+ # }}}
+ # {{{ Limit requestor email
- my $cgi_object = $m->cgi_object;
+ if ( $args{ARGS}->{'ValueOfRequestor'} ne '' ) {
+ my $alias = $session{'tickets'}->LimitRequestor(
+ VALUE => $args{ARGS}->{'ValueOfRequestor'},
+ OPERATOR => $args{ARGS}->{'RequestorOp'},
+ );
- if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
+ }
+
+ # }}}
+ # {{{ Limit Queue
+ if ( $args{ARGS}->{'ValueOfQueue'} ne '' ) {
+ $session{'tickets'}->LimitQueue(
+ VALUE => $args{ARGS}->{'ValueOfQueue'},
+ OPERATOR => $args{ARGS}->{'QueueOp'}
+ );
+ }
- my ( @content, $buffer );
- while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
- push @content, $buffer;
+ # }}}
+ # {{{ Limit Status
+ if ( $args{ARGS}->{'ValueOfStatus'} ne '' ) {
+ if ( ref( $args{ARGS}->{'ValueOfStatus'} ) ) {
+ foreach my $value ( @{ $args{ARGS}->{'ValueOfStatus'} } ) {
+ $session{'tickets'}->LimitStatus(
+ VALUE => $value,
+ OPERATOR => $args{ARGS}->{'StatusOp'},
+ );
}
+ }
+ else {
+ $session{'tickets'}->LimitStatus(
+ VALUE => $args{ARGS}->{'ValueOfStatus'},
+ OPERATOR => $args{ARGS}->{'StatusOp'},
+ );
+ }
+
+ }
- my $uploadinfo = $cgi_object->uploadInfo($filehandle);
+ # }}}
+ # {{{ Limit Subject
+ if ( $args{ARGS}->{'ValueOfSubject'} ne '' ) {
+ my $val = $args{ARGS}->{'ValueOfSubject'};
+ if ($args{ARGS}->{'SubjectOp'} =~ /like/) {
+ $val = "%".$val."%";
+ }
+ $session{'tickets'}->LimitSubject(
+ VALUE => $val,
+ OPERATOR => $args{ARGS}->{'SubjectOp'},
+ );
+ }
- # Prefer the cached name first over CGI.pm stringification.
- my $filename = $RT::Mason::CGI::Filename;
- $filename = "$filehandle" unless defined($filename);
- $filename = Encode::decode_utf8($filename);
- $filename =~ s{^.*[\\/]}{};
+ # }}}
+ # {{{ Limit Dates
+ if ( $args{ARGS}->{'ValueOfDate'} ne '' ) {
+ my $date = ParseDateToISO( $args{ARGS}->{'ValueOfDate'} );
+ $args{ARGS}->{'DateType'} =~ s/_Date$//;
- $Message->attach(
- Type => $uploadinfo->{'Content-Type'},
- Filename => $filename,
- Data => \@content,
+ if ( $args{ARGS}->{'DateType'} eq 'Updated' ) {
+ $session{'tickets'}->LimitTransactionDate(
+ VALUE => $date,
+ OPERATOR => $args{ARGS}->{'DateOp'},
);
- if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
- $Message->head->set( 'Subject' => $filename );
+ }
+ else {
+ $session{'tickets'}->LimitDate( FIELD => $args{ARGS}->{'DateType'},
+ VALUE => $date,
+ OPERATOR => $args{ARGS}->{'DateOp'},
+ );
+ }
+ }
+
+ # }}}
+ # {{{ Limit Content
+ if ( $args{ARGS}->{'ValueOfAttachmentField'} ne '' ) {
+ my $val = $args{ARGS}->{'ValueOfAttachmentField'};
+ if ($args{ARGS}->{'AttachmentFieldOp'} =~ /like/) {
+ $val = "%".$val."%";
+ }
+ $session{'tickets'}->Limit(
+ FIELD => $args{ARGS}->{'AttachmentField'},
+ VALUE => $val,
+ OPERATOR => $args{ARGS}->{'AttachmentFieldOp'},
+ );
+ }
+
+ # }}}
+
+ # {{{ Limit CustomFields
+
+ foreach my $arg ( keys %{ $args{ARGS} } ) {
+ my $id;
+ if ( $arg =~ /^CustomField(\d+)$/ ) {
+ $id = $1;
+ }
+ else {
+ next;
+ }
+ next unless ( $args{ARGS}->{$arg} );
+
+ my $form = $args{ARGS}->{$arg};
+ my $oper = $args{ARGS}->{ "CustomFieldOp" . $id };
+ foreach my $value ( ref($form) ? @{$form} : ($form) ) {
+ my $quote = 1;
+ if ($oper =~ /like/i) {
+ $value = "%".$value."%";
}
+ if ( $value =~ /^null$/i ) {
+
+ #Don't quote the string 'null'
+ $quote = 0;
+
+ # Convert the operator to something apropriate for nulls
+ $oper = 'IS' if ( $oper eq '=' );
+ $oper = 'IS NOT' if ( $oper eq '!=' );
+ }
+ $session{'tickets'}->LimitCustomField( CUSTOMFIELD => $id,
+ OPERATOR => $oper,
+ QUOTEVALUE => $quote,
+ VALUE => $value );
}
}
- $Message->make_singlepart;
- RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
+ # }}}
- return ($Message);
}
@@ -1254,7 +735,7 @@ Returns an ISO date and time in GMT
sub ParseDateToISO {
my $date = shift;
- my $date_obj = RT::Date->new( $session{'CurrentUser'} );
+ my $date_obj = RT::Date->new($session{'CurrentUser'});
$date_obj->Set(
Format => 'unknown',
Value => $date
@@ -1264,56 +745,98 @@ sub ParseDateToISO {
# }}}
+# {{{ sub Config
+# TODO: This might eventually read the cookies, user configuration
+# information from the DB, queue configuration information from the
+# DB, etc.
+
+sub Config {
+ my $args = shift;
+ my $key = shift;
+ return $args->{$key} || $RT::WebOptions{$key};
+}
+
+# }}}
+
# {{{ sub ProcessACLChanges
sub ProcessACLChanges {
my $ARGSref = shift;
- #XXX: why don't we get ARGSref like in other Process* subs?
+ my %ARGS = %$ARGSref;
- my @results;
+ my ( $ACL, @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 );
+ foreach my $arg (keys %ARGS) {
+ if ($arg =~ /GrantRight-(\d+)-(.*?)-(\d+)$/) {
+ my $principal_id = $1;
+ my $object_type = $2;
+ my $object_id = $3;
+ my $rights = $ARGS{$arg};
- my @rights;
- if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
- @rights = @{ $ARGSref->{$arg} };
- } else {
- @rights = $ARGSref->{$arg};
+ my $principal = RT::Principal->new($session{'CurrentUser'});
+ $principal->Load($principal_id);
+
+ my $obj;
+
+ if ($object_type eq 'RT::Queue') {
+ $obj = RT::Queue->new($session{'CurrentUser'});
+ $obj->Load($object_id);
+ } elsif ($object_type eq 'RT::Group') {
+ $obj = RT::Group->new($session{'CurrentUser'});
+ $obj->Load($object_id);
+
+ } elsif ($object_type eq 'RT::System') {
+ $obj = $RT::System;
+ } else {
+ push (@results, loc("System Error").
+ loc("Rights could not be granted for [_1]", $object_type));
+ next;
+ }
+
+ my @rights = ref($ARGS{$arg}) eq 'ARRAY' ? @{$ARGS{$arg}} : ($ARGS{$arg});
+ foreach my $right (@rights) {
+ next unless ($right);
+ my ($val, $msg) = $principal->GrantRight(Object => $obj, Right => $right);
+ push (@results, $msg);
+ }
}
- @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");
+ elsif ($arg =~ /RevokeRight-(\d+)-(.*?)-(\d+)-(.*?)$/) {
+ my $principal_id = $1;
+ my $object_type = $2;
+ my $object_id = $3;
+ my $right = $4;
+
+ my $principal = RT::Principal->new($session{'CurrentUser'});
+ $principal->Load($principal_id);
+ next unless ($right);
+ my $obj;
+
+ if ($object_type eq 'RT::Queue') {
+ $obj = RT::Queue->new($session{'CurrentUser'});
+ $obj->Load($object_id);
+ } elsif ($object_type eq 'RT::Group') {
+ $obj = RT::Group->new($session{'CurrentUser'});
+ $obj->Load($object_id);
+
+ } elsif ($object_type eq 'RT::System') {
+ $obj = $RT::System;
+ } else {
+ push (@results, loc("System Error").
+ loc("Rights could not be revoked for [_1]", $object_type));
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 ($val, $msg) = $principal->RevokeRight(Object => $obj, Right => $right);
+ push (@results, $msg);
}
- foreach my $right (@rights) {
- my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
- push( @results, $msg );
- }
+
}
return (@results);
-}
+
+ }
# }}}
@@ -1329,20 +852,59 @@ Returns an array of success/failure messages
sub UpdateRecordObject {
my %args = (
- ARGSRef => undef,
- AttributesRef => undef,
- Object => undef,
+ 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'},
- );
+ my (@results);
+
+ my $object = $args{'Object'};
+ my $attributes = $args{'AttributesRef'};
+ my $ARGSRef = $args{'ARGSRef'};
+ foreach my $attribute (@$attributes) {
+ my $value;
+ if ( defined $ARGSRef->{$attribute} ) {
+ $value = $ARGSRef->{$attribute};
+ }
+ elsif (
+ defined( $args{'AttributePrefix'} )
+ && defined(
+ $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
+ )
+ ) {
+ $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
+ } else {
+ next;
+ }
+
+ $value =~ s/\r\n/\n/gs;
+
+ if ($value ne $object->$attribute()){
+
+ my $method = "Set$attribute";
+ my ( $code, $msg ) = $object->$method($value);
+
+ push @results, loc($attribute) . ': ' . loc_fuzzy($msg);
+=for loc
+ "[_1] could not be set to [_2].", # loc
+ "That is already the current value", # loc
+ "No value sent to _Set!\n", # loc
+ "Illegal value for [_1]", # loc
+ "The new value has been set.", # loc
+ "No column specified", # loc
+ "Immutable field", # loc
+ "Nonexistant field?", # loc
+ "Invalid data", # loc
+ "Couldn't find row", # loc
+ "Missing a primary key?: [_1]", # loc
+ "Found Object", # loc
+=cut
+ };
+ }
return (@results);
}
@@ -1360,44 +922,37 @@ sub ProcessCustomFieldUpdates {
my $Object = $args{'CustomFieldObj'};
my $ARGSRef = $args{'ARGSRef'};
- my @attribs = qw(Name Type Description Queue SortOrder);
+ 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"} ) {
+ if ( $ARGSRef->{ "CustomField-" . $Object->Id . "-AddValue-Name" } ) {
+
my ( $addval, $addmsg ) = $Object->AddValue(
- Name => $ARGSRef->{"$prefix-AddValue-Name"},
- Description => $ARGSRef->{"$prefix-AddValue-Description"},
- SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
+ Name =>
+ $ARGSRef->{ "CustomField-" . $Object->Id . "-AddValue-Name" },
+ Description => $ARGSRef->{ "CustomField-"
+ . $Object->Id
+ . "-AddValue-Description" },
+ SortOrder => $ARGSRef->{ "CustomField-"
+ . $Object->Id
+ . "-AddValue-SortOrder" },
);
- push( @results, $addmsg );
+ push ( @results, $addmsg );
}
-
- my @delete_values
- = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
- ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
- : ( $ARGSRef->{"$prefix-DeleteValue"} );
-
+ my @delete_values = (
+ ref $ARGSRef->{ 'CustomField-' . $Object->Id . '-DeleteValue' } eq
+ 'ARRAY' )
+ ? @{ $ARGSRef->{ 'CustomField-' . $Object->Id . '-DeleteValue' } }
+ : ( $ARGSRef->{ 'CustomField-' . $Object->Id . '-DeleteValue' } );
foreach my $id (@delete_values) {
next unless defined $id;
my ( $err, $msg ) = $Object->DeleteValue($id);
- push( @results, $msg );
+ 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);
}
@@ -1422,35 +977,30 @@ sub ProcessTicketBasics {
my $TicketObj = $args{'TicketObj'};
my $ARGSRef = $args{'ARGSRef'};
- # {{{ Set basic fields
+ # {{{ Set basic fields
my @attribs = qw(
- Subject
- FinalPriority
- Priority
- TimeEstimated
- TimeWorked
- TimeLeft
- Type
- Status
- Queue
+ Subject
+ FinalPriority
+ Priority
+ TimeEstimated
+ TimeWorked
+ TimeLeft
+ Status
+ Queue
);
if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
my $tempqueue = RT::Queue->new($RT::SystemUser);
$tempqueue->Load( $ARGSRef->{'Queue'} );
if ( $tempqueue->id ) {
- $ARGSRef->{'Queue'} = $tempqueue->id;
+ $ARGSRef->{'Queue'} = $tempqueue->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,
+ ARGSRef => $ARGSRef
);
# We special case owner changing, so we can use ForceOwnerChange
@@ -1458,12 +1008,14 @@ sub ProcessTicketBasics {
my ($ChownType);
if ( $ARGSRef->{'ForceOwnerChange'} ) {
$ChownType = "Force";
- } else {
+ }
+ else {
$ChownType = "Give";
}
- my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
- push( @results, $msg );
+ my ( $val, $msg ) =
+ $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
+ push ( @results, $msg );
}
# }}}
@@ -1473,217 +1025,142 @@ sub ProcessTicketBasics {
# }}}
-sub ProcessTicketCustomFieldUpdates {
- my %args = @_;
- $args{'Object'} = delete $args{'TicketObj'};
- my $ARGSRef = { %{ $args{'ARGSRef'} } };
+# {{{ Sub ProcessTicketCustomFieldUpdates
- # 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};
- }
- }
+sub ProcessTicketCustomFieldUpdates {
+ my %args = (
+ ARGSRef => undef,
+ @_
+ );
- return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
-}
+ my @results;
-sub ProcessObjectCustomFieldUpdates {
- my %args = @_;
my $ARGSRef = $args{'ARGSRef'};
- my @results;
- # Build up a list of objects that we want to work with
+ # Build up a list of tickets that we want to work with
+ my %tickets_to_mod;
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+)-(.*)$/;
+ foreach my $arg ( keys %{$ARGSRef} ) {
+ if ( $arg =~ /^Ticket-(\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->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},
- );
- }
+ # For each of those tickets, find out what custom fields we want to work with.
+ $custom_fields_to_mod{$1}{$2} = 1;
}
}
- 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';
- # since http won't pass in a form element with a null value, we need
- # to fake it
- if ( $arg eq 'Values-Magic' ) {
+ # For each of those tickets
+ foreach my $tick ( keys %custom_fields_to_mod ) {
+ my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
+ $Ticket->Load($tick);
- # 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'};
+ # For each custom field
+ foreach my $cf ( keys %{ $custom_fields_to_mod{$tick} } ) {
- # "Empty" values does not mean anything for Image and Binary fields
- next if $cf_type =~ /^(?:Image|Binary)$/;
+ my $CustomFieldObj = RT::CustomField->new($session{'CurrentUser'});
+ $CustomFieldObj->LoadById($cf);
- $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;
+ foreach my $arg ( keys %{$ARGSRef} ) {
+ # since http won't pass in a form element with a null value, we need
+ # to fake it
+ if ($arg =~ /^(.*?)-Values-Magic$/ ) {
+ # We don't care about the magic, if there's really a values element;
+ next if (exists $ARGSRef->{$1.'-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;
+ $arg = $1."-Values";
+ $ARGSRef->{$1."-Values"} = undef;
+
}
-
- my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
- Field => $cf,
- Value => $value
- );
- push( @results, $msg );
- $values_hash{$val} = 1 if $val;
- }
-
- $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;
+ next unless ( $arg =~ /^Ticket-$tick-CustomField-$cf-/ );
+ my @values =
+ ( ref( $ARGSRef->{$arg} ) eq 'ARRAY' )
+ ? @{ $ARGSRef->{$arg} }
+ : ( $ARGSRef->{$arg} );
+ if ( ( $arg =~ /-AddValue$/ ) || ( $arg =~ /-Value$/ ) ) {
+ foreach my $value (@values) {
+ next unless ($value);
+ my ( $val, $msg ) = $Ticket->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+ }
+ elsif ( $arg =~ /-DeleteValues$/ ) {
+ foreach my $value (@values) {
+ next unless ($value);
+ my ( $val, $msg ) = $Ticket->DeleteCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+ }
+ elsif ( $arg =~ /-Values$/ and $CustomFieldObj->Type !~ /Entry/) {
+ my $cf_values = $Ticket->CustomFieldValues($cf);
+
+ my %values_hash;
+ foreach my $value (@values) {
+ next unless ($value);
+
+ # build up a hash of values that the new set has
+ $values_hash{$value} = 1;
+
+ unless ( $cf_values->HasEntry($value) ) {
+ my ( $val, $msg ) = $Ticket->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+
+ }
+ while ( my $cf_value = $cf_values->Next ) {
+ unless ( $values_hash{ $cf_value->Content } == 1 ) {
+ my ( $val, $msg ) = $Ticket->DeleteCustomFieldValue(
+ Field => $cf,
+ Value => $cf_value->Content
+ );
+ push ( @results, $msg);
+
+ }
+
+ }
+ }
+ elsif ( $arg =~ /-Values$/ ) {
+ my $cf_values = $Ticket->CustomFieldValues($cf);
+
+ # 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 ) = $Ticket->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+ }
+ else {
+ push ( @results, "User asked for an unknown update type for custom field " . $cf->Name . " for ticket " . $Ticket->id );
}
-
- $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);
}
- return @results;
}
+# }}}
+
# {{{ sub ProcessTicketWatchers
=head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
@@ -1703,31 +1180,29 @@ sub ProcessTicketWatchers {
my $Ticket = $args{'TicketObj'};
my $ARGSRef = $args{'ARGSRef'};
- # Munge watchers
+ # {{{ 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
- );
+ # {{{ Delete deletable watchers
+ if ( ( $key =~ /^Ticket-DelWatcher-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
- );
+ my ( $code, $msg ) = $Ticket->DeleteWatcher( Type => $ARGSRef->{$key}, PrincipalId => $1 );
push @results, $msg;
}
- # Add new wathchers by email address
- elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
- and $key =~ /^WatcherTypeEmail(\d*)$/ )
+ # }}}
+
+ # 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 :/
@@ -1748,21 +1223,18 @@ sub ProcessTicketWatchers {
}
# 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;
+ elsif ( ( $ARGSRef->{$key} =~ /^(AdminCc|Cc|Requestor)$/ )
+ and ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) ) {
- my ( $code, $msg ) = $Ticket->AddWatcher(
- Type => $value,
- PrincipalId => $principal_id
- );
- push @results, $msg;
- }
+ #They're in this order because otherwise $1 gets clobbered :/
+ my ( $code, $msg ) =
+ $Ticket->AddWatcher( Type => $ARGSRef->{$key}, PrincipalId => $1 );
+ push @results, $msg;
}
-
}
+
+ # }}}
+
return (@results);
}
@@ -1790,33 +1262,33 @@ sub ProcessTicketDates {
# {{{ Set date fields
my @date_fields = qw(
- Told
- Resolved
- Starts
- Started
- Due
+ Told
+ Resolved
+ Starts
+ Started
+ Due
);
#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";
+ #If it's something other than just whitespace
+ if ( $ARGSRef->{ $field . '_Date' } ne '' ) {
+ $DateObj->Set(
+ Format => 'unknown',
+ Value => $ARGSRef->{ $field . '_Date' }
+ );
+ my $obj = $field . "Obj";
+ if ( ( defined $DateObj->Unix )
+ and ( $DateObj->Unix ne $Ticket->$obj()->Unix() ) )
+ {
+ my $method = "Set$field";
+ my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
+ push @results, "$msg";
+ }
}
}
@@ -1835,39 +1307,13 @@ Returns an array of results messages.
=cut
sub ProcessTicketLinks {
- my %args = (
- TicketObj => undef,
- ARGSRef => undef,
- @_
- );
+ 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.
@@ -1877,11 +1323,11 @@ sub ProcessRecordLinks {
my $type = $2;
my $target = $3;
- my ( $val, $msg ) = $Record->DeleteLink(
- Base => $base,
- Type => $type,
- Target => $target
- );
+ push @results,
+ "Trying to delete: Base: $base Target: $target Type $type";
+ my ( $val, $msg ) = $Ticket->DeleteLink( Base => $base,
+ Type => $type,
+ Target => $target );
push @results, $msg;
@@ -1892,138 +1338,40 @@ sub ProcessRecordLinks {
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
- );
+ if ( $ARGSRef->{ $Ticket->Id . "-$linktype" } ) {
+ for my $luri ( split ( / /, $ARGSRef->{ $Ticket->Id . "-$linktype" } ) ) {
+ $luri =~ s/\s*$//; # Strip trailing whitespace
+ my ( $val, $msg ) = $Ticket->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
- );
+ if ( $ARGSRef->{ "$linktype-" . $Ticket->Id } ) {
+
+ for my $luri ( split ( / /, $ARGSRef->{ "$linktype-" . $Ticket->Id } ) ) {
+ my ( $val, $msg ) = $Ticket->AddLink( Base => $luri,
+ Type => $linktype );
push @results, $msg;
}
- }
+ }
}
- return (@results);
-}
-
-=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'} =~ /^(.*?)\.{(.+)}$/ ) {
- 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;
- }
+ #Merge if we need to
+ if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
+ my ( $val, $msg ) =
+ $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
+ push @results, $msg;
}
- return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
- return $value;
-}
-
-=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 );
+ return (@results);
}
-=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 );
-}
+# }}}
eval "require RT::Interface::Web_Vendor";
-die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
+die $@ if ($@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm});
eval "require RT::Interface::Web_Local";
-die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );
+die $@ if ($@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm});
1;
diff --git a/rt/lib/RT/Interface/Web_Vendor.pm b/rt/lib/RT/Interface/Web_Vendor.pm
new file mode 100644
index 000000000..1999096a7
--- /dev/null
+++ b/rt/lib/RT/Interface/Web_Vendor.pm
@@ -0,0 +1,201 @@
+# Copyright (c) 2004 Ivan Kohler <ivan-rt@420.am>
+# Copyright (c) 2008 Freeside Internet Services, Inc.
+#
+# 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.
+
+=head1 NAME
+
+RT::Interface::Web_Vendor
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Freeside vendor overlay for RT::Interface::Web.
+
+=begin testing
+
+use_ok(RT::Interface::Web_Vendor);
+
+=end testing
+
+=cut
+
+#package RT::Interface::Web;
+#use strict;
+
+package HTML::Mason::Commands;
+use strict;
+
+=head2 ProcessTicketCustomers
+
+=cut
+
+sub ProcessTicketCustomers {
+ my %args = (
+ TicketObj => undef,
+ ARGSRef => undef,
+ Debug => 0,
+ @_
+ );
+ my @results = ();
+
+ my $Ticket = $args{'TicketObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+ my $Debug = $args{'Debug'};
+ my $me = 'ProcessTicketCustomers';
+
+ ### false laziness w/RT::Interface::Web::ProcessTicketLinks
+ # 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;
+
+ push @results,
+ "Trying to delete: Base: $base Target: $target Type $type";
+ my ( $val, $msg ) = $Ticket->DeleteLink( Base => $base,
+ Type => $type,
+ Target => $target );
+
+ push @results, $msg;
+
+ }
+
+ }
+ ###
+
+ ###
+ #find new customers
+ ###
+
+ my @custnums = map { /^Ticket-AddCustomer-(\d+)$/; $1 }
+ grep { /^Ticket-AddCustomer-(\d+)$/ && $ARGSRef->{$_} }
+ keys %$ARGSRef;
+
+ #my @delete_custnums =
+ # map { /^Ticket-AddCustomer-(\d+)$/; $1 }
+ # grep { /^Ticket-AddCustomer-(\d+)$/ && $ARGSRef->{$_} }
+ # keys %$ARGSRef;
+
+ ###
+ #figure out if we're going to auto-link requestors, and find them if so
+ ###
+
+ my $num_cur_cust = $Ticket->Customers->Count;
+ my $num_new_cust = scalar(@custnums);
+ warn "$me: $num_cur_cust current customers / $num_new_cust new customers\n"
+ if $Debug;
+
+ #if we're linking the first ticket to one customer
+ my $link_requestors = ( $num_cur_cust == 0 && $num_new_cust == 1 );
+ warn "$me: adding a single customer to a previously customerless".
+ " ticket, so linking customers to requestor too\n"
+ if $Debug && $link_requestors;
+
+ my @Requestors = ();
+ if ( $link_requestors ) {
+
+ #find any requestors without customers
+ @Requestors =
+ grep { ! $_->Customers->Count }
+ @{ $Ticket->Requestors->UserMembersObj->ItemsArrayRef };
+
+ warn "$me: found ". scalar(@Requestors). " requestors without".
+ " customers; linking them\n"
+ if $Debug;
+
+ }
+
+ ###
+ #link ticket (and requestors) to customers
+ ###
+
+ foreach my $custnum ( @custnums ) {
+
+ my @link = ( 'Type' => 'MemberOf',
+ 'Target' => "freeside://freeside/cust_main/$custnum",
+ );
+
+ my( $val, $msg ) = $Ticket->AddLink(@link);
+ push @results, $msg;
+
+ #add customer links to requestors
+ foreach my $Requestor ( @Requestors ) {
+ my( $val, $msg ) = $Requestor->AddLink(@link);
+ push @results, $msg;
+ warn "$me: linking requestor to custnum $custnum: $msg\n"
+ if $Debug > 1;
+ }
+
+ }
+
+ return @results;
+
+}
+
+#false laziness w/above... eventually it should go away in favor of this
+sub ProcessObjectCustomers {
+ my %args = (
+ Object => undef,
+ ARGSRef => undef,
+ @_
+ );
+ my @results = ();
+
+ my $Object = $args{'Object'};
+ my $ARGSRef = $args{'ARGSRef'};
+
+ ### false laziness w/RT::Interface::Web::ProcessTicketLinks
+ # 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;
+
+ push @results,
+ "Trying to delete: Base: $base Target: $target Type $type";
+ my ( $val, $msg ) = $Object->DeleteLink( Base => $base,
+ Type => $type,
+ Target => $target );
+
+ push @results, $msg;
+
+ }
+
+ }
+ ###
+
+ #my @delete_custnums =
+ # map { /^Object-AddCustomer-(\d+)$/; $1 }
+ # grep { /^Object-AddCustomer-(\d+)$/ && $ARGSRef->{$_} }
+ # keys %$ARGSRef;
+
+ my @custnums = map { /^Object-AddCustomer-(\d+)$/; $1 }
+ grep { /^Object-AddCustomer-(\d+)$/ && $ARGSRef->{$_} }
+ keys %$ARGSRef;
+
+ foreach my $custnum ( @custnums ) {
+ my( $val, $msg ) =
+ $Object->AddLink( 'Type' => 'MemberOf',
+ 'Target' => "freeside://freeside/cust_main/$custnum",
+ );
+ push @results, $msg;
+ }
+
+ return @results;
+
+}
+
+1;
+
generated by cgit v1.2.1 (git 2.18.0) at 2025-06-15 04:12:00 +0000