diff options
author | Ivan Kohler <ivan@freeside.biz> | 2014-09-15 20:44:48 -0700 |
---|---|---|
committer | Ivan Kohler <ivan@freeside.biz> | 2014-09-15 20:44:48 -0700 |
commit | ed1f84b4e8f626245995ecda5afcf83092c153b2 (patch) | |
tree | 3f58bbef5fbf2502e65d29b37b5dbe537519e89d /rt/lib | |
parent | fe9ea9183e8a16616d6d04a7b5c7498d28e78248 (diff) |
RT 4.0.22
Diffstat (limited to 'rt/lib')
42 files changed, 23765 insertions, 297 deletions
diff --git a/rt/lib/.RT.pm.swp b/rt/lib/.RT.pm.swp Binary files differnew file mode 100644 index 000000000..55a25798e --- /dev/null +++ b/rt/lib/.RT.pm.swp diff --git a/rt/lib/RT.pm b/rt/lib/RT.pm index e71d6c926..ec18caf51 100644 --- a/rt/lib/RT.pm +++ b/rt/lib/RT.pm @@ -52,6 +52,7 @@ use warnings; package RT; +use Encode (); use File::Spec (); use Cwd (); @@ -263,6 +264,9 @@ sub InitLogging { $frame++ while caller($frame) && caller($frame) =~ /^Log::/; my ($package, $filename, $line) = caller($frame); + # Encode to bytes, so we don't send wide characters + $p{message} = Encode::encode("UTF-8", $p{message}); + $p{'message'} =~ s/(?:\r*\n)+$//; return "[$$] [". gmtime(time) ."] [". $p{'level'} ."]: " . $p{'message'} ." ($filename:$line)\n"; @@ -278,8 +282,8 @@ sub InitLogging { $frame++ while caller($frame) && caller($frame) =~ /^Log::/; my ($package, $filename, $line) = caller($frame); - # syswrite() cannot take utf8; turn it off here. - Encode::_utf8_off($p{message}); + # Encode to bytes, so we don't send wide characters + $p{message} = Encode::encode("UTF-8", $p{message}); $p{message} =~ s/(?:\r*\n)+$//; if ($p{level} eq 'debug') { @@ -382,19 +386,9 @@ sub InitSignalHandlers { ## mechanism (see above). $SIG{__WARN__} = sub { - # The 'wide character' warnings has to be silenced for now, at least - # until HTML::Mason offers a sane way to process both raw output and - # unicode strings. # use 'goto &foo' syntax to hide ANON sub from stack - if( index($_[0], 'Wide character in ') != 0 ) { - unshift @_, $RT::Logger, qw(level warning message); - goto &Log::Dispatch::log; - } - # Return value is used only by RT::Test to filter warnings from - # reaching the Test::NoWarnings catcher. If Log::Dispatch::log() ever - # starts returning 'IGNORE', we'll need to switch to something more - # clever. I don't expect that to happen. - return 'IGNORE'; + unshift @_, $RT::Logger, qw(level warning message); + goto &Log::Dispatch::log; }; #When we call die, trap it and log->crit with the value of the die. diff --git a/rt/lib/RT.pm.orig b/rt/lib/RT.pm.orig new file mode 100644 index 000000000..e71d6c926 --- /dev/null +++ b/rt/lib/RT.pm.orig @@ -0,0 +1,887 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +use strict; +use warnings; + +package RT; + + +use File::Spec (); +use Cwd (); + +use vars qw($Config $System $SystemUser $Nobody $Handle $Logger $_Privileged $_Unprivileged $_INSTALL_MODE); + +use vars qw($BasePath + $EtcPath + $BinPath + $SbinPath + $VarPath + $LexiconPath + $PluginPath + $LocalPath + $LocalEtcPath + $LocalLibPath + $LocalLexiconPath + $LocalPluginPath + $MasonComponentRoot + $MasonLocalComponentRoot + $MasonDataDir + $MasonSessionDir); + + +RT->LoadGeneratedData(); + +=head1 NAME + +RT - Request Tracker + +=head1 SYNOPSIS + +A fully featured request tracker package. + +This documentation describes the point-of-entry for RT's Perl API. To learn +more about what RT is and what it can do for you, visit +L<https://bestpractical.com/rt>. + +=head1 DESCRIPTION + +=head2 INITIALIZATION + +If you're using RT's Perl libraries, you need to initialize RT before using any +of the modules. + +You have the option of handling the timing of config loading and the actual +init sequence yourself with: + + use RT; + BEGIN { + RT->LoadConfig; + RT->Init; + } + +or you can let RT do it all: + + use RT -init; + +This second method is particular useful when writing one-liners to interact with RT: + + perl -MRT=-init -e '...' + +The first method is necessary if you need to delay or conditionalize +initialization or if you want to fiddle with C<< RT->Config >> between loading +the config files and initializing the RT environment. + +=cut + +{ + my $DID_IMPORT_INIT; + sub import { + my $class = shift; + my $action = shift || ''; + + if ($action eq "-init" and not $DID_IMPORT_INIT) { + $class->LoadConfig; + $class->Init; + $DID_IMPORT_INIT = 1; + } + } +} + +=head2 LoadConfig + +Load RT's config file. First, the site configuration file +(F<RT_SiteConfig.pm>) is loaded, in order to establish overall site +settings like hostname and name of RT instance. Then, the core +configuration file (F<RT_Config.pm>) is loaded to set fallback values +for all settings; it bases some values on settings from the site +configuration file. + +In order for the core configuration to not override the site's +settings, the function C<Set> is used; it only sets values if they +have not been set already. + +=cut + +sub LoadConfig { + require RT::Config; + $Config = RT::Config->new; + $Config->LoadConfigs; + require RT::I18N; + + # RT::Essentials mistakenly recommends that WebPath be set to '/'. + # If the user does that, do what they mean. + $RT::WebPath = '' if ($RT::WebPath eq '/'); + + # fix relative LogDir and GnuPG homedir + unless ( File::Spec->file_name_is_absolute( $Config->Get('LogDir') ) ) { + $Config->Set( LogDir => + File::Spec->catfile( $BasePath, $Config->Get('LogDir') ) ); + } + + my $gpgopts = $Config->Get('GnuPGOptions'); + unless ( File::Spec->file_name_is_absolute( $gpgopts->{homedir} ) ) { + $gpgopts->{homedir} = File::Spec->catfile( $BasePath, $gpgopts->{homedir} ); + } + + return $Config; +} + +=head2 Init + +L<Connects to the database|/ConnectToDatabase>, L<initilizes system +objects|/InitSystemObjects>, L<preloads classes|/InitClasses>, L<sets +up logging|/InitLogging>, and L<loads plugins|/InitPlugins>. + +=cut + +sub Init { + shift if @_%2; # code is inconsistent about calling as method + my %args = (@_); + + CheckPerlRequirements(); + + InitPluginPaths(); + + #Get a database connection + ConnectToDatabase(); + InitSystemObjects(); + InitClasses(%args); + InitLogging(%args); + InitPlugins(); + RT::I18N->Init; + RT->Config->PostLoadCheck; + +} + +=head2 ConnectToDatabase + +Get a database connection. See also L</Handle>. + +=cut + +sub ConnectToDatabase { + require RT::Handle; + $Handle = RT::Handle->new unless $Handle; + $Handle->Connect; + return $Handle; +} + +=head2 InitLogging + +Create the Logger object and set up signal handlers. + +=cut + +sub InitLogging { + + my %arg = @_; + + # We have to set the record separator ($, man perlvar) + # or Log::Dispatch starts getting + # really pissy, as some other module we use unsets it. + $, = ''; + use Log::Dispatch 1.6; + + my %level_to_num = ( + map( { $_ => } 0..7 ), + debug => 0, + info => 1, + notice => 2, + warning => 3, + error => 4, 'err' => 4, + critical => 5, crit => 5, + alert => 6, + emergency => 7, emerg => 7, + ); + + unless ( $RT::Logger ) { + + $RT::Logger = Log::Dispatch->new; + + my $stack_from_level; + if ( $stack_from_level = RT->Config->Get('LogStackTraces') ) { + # if option has old style '\d'(true) value + $stack_from_level = 0 if $stack_from_level =~ /^\d+$/; + $stack_from_level = $level_to_num{ $stack_from_level } || 0; + } else { + $stack_from_level = 99; # don't log + } + + my $simple_cb = sub { + # if this code throw any warning we can get segfault + no warnings; + my %p = @_; + + # skip Log::* stack frames + my $frame = 0; + $frame++ while caller($frame) && caller($frame) =~ /^Log::/; + my ($package, $filename, $line) = caller($frame); + + $p{'message'} =~ s/(?:\r*\n)+$//; + return "[$$] [". gmtime(time) ."] [". $p{'level'} ."]: " + . $p{'message'} ." ($filename:$line)\n"; + }; + + my $syslog_cb = sub { + # if this code throw any warning we can get segfault + no warnings; + my %p = @_; + + my $frame = 0; # stack frame index + # skip Log::* stack frames + $frame++ while caller($frame) && caller($frame) =~ /^Log::/; + my ($package, $filename, $line) = caller($frame); + + # syswrite() cannot take utf8; turn it off here. + Encode::_utf8_off($p{message}); + + $p{message} =~ s/(?:\r*\n)+$//; + if ($p{level} eq 'debug') { + return "[$$] $p{message} ($filename:$line)\n"; + } else { + return "[$$] $p{message}\n"; + } + }; + + my $stack_cb = sub { + no warnings; + my %p = @_; + return $p{'message'} unless $level_to_num{ $p{'level'} } >= $stack_from_level; + + require Devel::StackTrace; + my $trace = Devel::StackTrace->new( ignore_class => [ 'Log::Dispatch', 'Log::Dispatch::Base' ] ); + return $p{'message'} . $trace->as_string; + + # skip calling of the Log::* subroutins + my $frame = 0; + $frame++ while caller($frame) && caller($frame) =~ /^Log::/; + $frame++ while caller($frame) && (caller($frame))[3] =~ /^Log::/; + + $p{'message'} .= "\nStack trace:\n"; + while( my ($package, $filename, $line, $sub) = caller($frame++) ) { + $p{'message'} .= "\t$sub(...) called at $filename:$line\n"; + } + return $p{'message'}; + }; + + if ( $Config->Get('LogToFile') ) { + my ($filename, $logdir) = ( + $Config->Get('LogToFileNamed') || 'rt.log', + $Config->Get('LogDir') || File::Spec->catdir( $VarPath, 'log' ), + ); + if ( $filename =~ m![/\\]! ) { # looks like an absolute path. + ($logdir) = $filename =~ m{^(.*[/\\])}; + } + else { + $filename = File::Spec->catfile( $logdir, $filename ); + } + + unless ( -d $logdir && ( ( -f $filename && -w $filename ) || -w $logdir ) ) { + # localizing here would be hard when we don't have a current user yet + die "Log file '$filename' couldn't be written or created.\n RT can't run."; + } + + require Log::Dispatch::File; + $RT::Logger->add( Log::Dispatch::File->new + ( name=>'file', + min_level=> $Config->Get('LogToFile'), + filename=> $filename, + mode=>'append', + callbacks => [ $simple_cb, $stack_cb ], + )); + } + if ( $Config->Get('LogToScreen') ) { + require Log::Dispatch::Screen; + $RT::Logger->add( Log::Dispatch::Screen->new + ( name => 'screen', + min_level => $Config->Get('LogToScreen'), + callbacks => [ $simple_cb, $stack_cb ], + stderr => 1, + )); + } + if ( $Config->Get('LogToSyslog') ) { + require Log::Dispatch::Syslog; + $RT::Logger->add(Log::Dispatch::Syslog->new + ( name => 'syslog', + ident => 'RT', + min_level => $Config->Get('LogToSyslog'), + callbacks => [ $syslog_cb, $stack_cb ], + stderr => 1, + $Config->Get('LogToSyslogConf'), + )); + } + } + InitSignalHandlers(%arg); +} + +{ # Work around bug in Log::Dispatch < 2.30, wherein the short forms + # of ->warn, ->err, and ->crit do not usefully propagate out, unlike + # ->warning, ->error, and ->critical + package Log::Dispatch; + no warnings 'redefine'; + sub warn { shift->warning(@_) } + sub err { shift->error(@_) } + sub crit { shift->critical(@_) } +} + +sub InitSignalHandlers { + + my %arg = @_; + return if $arg{'NoSignalHandlers'}; + +# Signal handlers +## This is the default handling of warnings and die'ings in the code +## (including other used modules - maybe except for errors catched by +## Mason). It will log all problems through the standard logging +## mechanism (see above). + + $SIG{__WARN__} = sub { + # The 'wide character' warnings has to be silenced for now, at least + # until HTML::Mason offers a sane way to process both raw output and + # unicode strings. + # use 'goto &foo' syntax to hide ANON sub from stack + if( index($_[0], 'Wide character in ') != 0 ) { + unshift @_, $RT::Logger, qw(level warning message); + goto &Log::Dispatch::log; + } + # Return value is used only by RT::Test to filter warnings from + # reaching the Test::NoWarnings catcher. If Log::Dispatch::log() ever + # starts returning 'IGNORE', we'll need to switch to something more + # clever. I don't expect that to happen. + return 'IGNORE'; + }; + +#When we call die, trap it and log->crit with the value of the die. + + $SIG{__DIE__} = sub { + # if we are not in eval and perl is not parsing code + # then rollback transactions and log RT error + unless ($^S || !defined $^S ) { + $RT::Handle->Rollback(1) if $RT::Handle; + $RT::Logger->crit("$_[0]") if $RT::Logger; + } + die $_[0]; + }; +} + + +sub CheckPerlRequirements { + if ($^V < 5.008003) { + die sprintf "RT requires Perl v5.8.3 or newer. Your current Perl is v%vd\n", $^V; + } + + # use $error here so the following "die" can still affect the global $@ + my $error; + { + local $@; + eval { + my $x = ''; + my $y = \$x; + require Scalar::Util; + Scalar::Util::weaken($y); + }; + $error = $@; + } + + if ($error) { + die <<"EOF"; + +RT requires the Scalar::Util module be built with support for the 'weaken' +function. + +It is sometimes the case that operating system upgrades will replace +a working Scalar::Util with a non-working one. If your system was working +correctly up until now, this is likely the cause of the problem. + +Please reinstall Scalar::Util, being careful to let it build with your C +compiler. Usually this is as simple as running the following command as +root. + + perl -MCPAN -e'install Scalar::Util' + +EOF + + } +} + +=head2 InitClasses + +Load all modules that define base classes. + +=cut + +sub InitClasses { + shift if @_%2; # so we can call it as a function or method + my %args = (@_); + require RT::Tickets; + require RT::Transactions; + require RT::Attachments; + require RT::Users; + require RT::Principals; + require RT::CurrentUser; + require RT::Templates; + require RT::Queues; + require RT::ScripActions; + require RT::ScripConditions; + require RT::Scrips; + require RT::Groups; + require RT::GroupMembers; + require RT::CustomFields; + require RT::CustomFieldValues; + require RT::ObjectCustomFields; + require RT::ObjectCustomFieldValues; + require RT::Attributes; + require RT::Dashboard; + require RT::Approval; + require RT::Lifecycle; + require RT::Link; + require RT::Links; + require RT::Article; + require RT::Articles; + require RT::Class; + require RT::Classes; + require RT::ObjectClass; + require RT::ObjectClasses; + require RT::ObjectTopic; + require RT::ObjectTopics; + require RT::Topic; + require RT::Topics; + + # on a cold server (just after restart) people could have an object + # in the session, as we deserialize it so we never call constructor + # of the class, so the list of accessible fields is empty and we die + # with "Method xxx is not implemented in RT::SomeClass" + + # without this, we also can never call _ClassAccessible, because we + # won't have filled RT::Record::_TABLE_ATTR + $_->_BuildTableAttributes foreach qw( + RT::Ticket + RT::Transaction + RT::Attachment + RT::User + RT::Principal + RT::Template + RT::Queue + RT::ScripAction + RT::ScripCondition + RT::Scrip + RT::Group + RT::GroupMember + RT::CustomField + RT::CustomFieldValue + RT::ObjectCustomField + RT::ObjectCustomFieldValue + RT::Attribute + RT::ACE + RT::Link + RT::Article + RT::Class + RT::ObjectClass + RT::ObjectTopic + RT::Topic + ); + + if ( $args{'Heavy'} ) { + # load scrips' modules + my $scrips = RT::Scrips->new(RT->SystemUser); + $scrips->Limit( FIELD => 'Stage', OPERATOR => '!=', VALUE => 'Disabled' ); + while ( my $scrip = $scrips->Next ) { + local $@; + eval { $scrip->LoadModules } or + $RT::Logger->error("Invalid Scrip ".$scrip->Id.". Unable to load the Action or Condition. ". + "You should delete or repair this Scrip in the admin UI.\n$@\n"); + } + + foreach my $class ( grep $_, RT->Config->Get('CustomFieldValuesSources') ) { + local $@; + eval "require $class; 1" or $RT::Logger->error( + "Class '$class' is listed in CustomFieldValuesSources option" + ." in the config, but we failed to load it:\n$@\n" + ); + } + + } +} + +=head2 InitSystemObjects + +Initializes system objects: C<$RT::System>, C<< RT->SystemUser >> +and C<< RT->Nobody >>. + +=cut + +sub InitSystemObjects { + + #RT's system user is a genuine database user. its id lives here + require RT::CurrentUser; + $SystemUser = RT::CurrentUser->new; + $SystemUser->LoadByName('RT_System'); + + #RT's "nobody user" is a genuine database user. its ID lives here. + $Nobody = RT::CurrentUser->new; + $Nobody->LoadByName('Nobody'); + + require RT::System; + $System = RT::System->new( $SystemUser ); +} + +=head1 CLASS METHODS + +=head2 Config + +Returns the current L<config object|RT::Config>, but note that +you must L<load config|/LoadConfig> first otherwise this method +returns undef. + +Method can be called as class method. + +=cut + +sub Config { return $Config || shift->LoadConfig(); } + +=head2 DatabaseHandle + +Returns the current L<database handle object|RT::Handle>. + +See also L</ConnectToDatabase>. + +=cut + +sub DatabaseHandle { return $Handle } + +=head2 Logger + +Returns the logger. See also L</InitLogging>. + +=cut + +sub Logger { return $Logger } + +=head2 System + +Returns the current L<system object|RT::System>. See also +L</InitSystemObjects>. + +=cut + +sub System { return $System } + +=head2 SystemUser + +Returns the system user's object, it's object of +L<RT::CurrentUser> class that represents the system. See also +L</InitSystemObjects>. + +=cut + +sub SystemUser { return $SystemUser } + +=head2 Nobody + +Returns object of Nobody. It's object of L<RT::CurrentUser> class +that represents a user who can own ticket and nothing else. See +also L</InitSystemObjects>. + +=cut + +sub Nobody { return $Nobody } + +sub PrivilegedUsers { + if (!$_Privileged) { + $_Privileged = RT::Group->new(RT->SystemUser); + $_Privileged->LoadSystemInternalGroup('Privileged'); + } + return $_Privileged; +} + +sub UnprivilegedUsers { + if (!$_Unprivileged) { + $_Unprivileged = RT::Group->new(RT->SystemUser); + $_Unprivileged->LoadSystemInternalGroup('Unprivileged'); + } + return $_Unprivileged; +} + + +=head2 Plugins + +Returns a listref of all Plugins currently configured for this RT instance. +You can define plugins by adding them to the @Plugins list in your RT_SiteConfig + +=cut + +our @PLUGINS = (); +sub Plugins { + my $self = shift; + unless (@PLUGINS) { + $self->InitPluginPaths; + @PLUGINS = $self->InitPlugins; + } + return \@PLUGINS; +} + +=head2 PluginDirs + +Takes an optional subdir (e.g. po, lib, etc.) and returns a list of +directories from plugins where that subdirectory exists. + +This code does not check plugin names, plugin validitity, or load +plugins (see L</InitPlugins>) in any way, and requires that RT's +configuration have been already loaded. + +=cut + +sub PluginDirs { + my $self = shift; + my $subdir = shift; + + require RT::Plugin; + + my @res; + foreach my $plugin (grep $_, RT->Config->Get('Plugins')) { + my $path = RT::Plugin->new( name => $plugin )->Path( $subdir ); + next unless -d $path; + push @res, $path; + } + return @res; +} + +=head2 InitPluginPaths + +Push plugins' lib paths into @INC right after F<local/lib>. +In case F<local/lib> isn't in @INC, append them to @INC + +=cut + +sub InitPluginPaths { + my $self = shift || __PACKAGE__; + + my @lib_dirs = $self->PluginDirs('lib'); + + my @tmp_inc; + my $added; + for (@INC) { + my $realpath = Cwd::realpath($_); + next unless defined $realpath; + if ( $realpath eq $RT::LocalLibPath) { + push @tmp_inc, $_, @lib_dirs; + $added = 1; + } else { + push @tmp_inc, $_; + } + } + + # append @lib_dirs in case $RT::LocalLibPath isn't in @INC + push @tmp_inc, @lib_dirs unless $added; + + my %seen; + @INC = grep !$seen{$_}++, @tmp_inc; +} + +=head2 InitPlugins + +Initialize all Plugins found in the RT configuration file, setting up +their lib and L<HTML::Mason> component roots. + +=cut + +sub InitPlugins { + my $self = shift; + my @plugins; + require RT::Plugin; + foreach my $plugin (grep $_, RT->Config->Get('Plugins')) { + $plugin->require; + die $UNIVERSAL::require::ERROR if ($UNIVERSAL::require::ERROR); + push @plugins, RT::Plugin->new(name =>$plugin); + } + return @plugins; +} + + +sub InstallMode { + my $self = shift; + if (@_) { + my ($integrity, $state, $msg) = RT::Handle->CheckIntegrity; + if ($_[0] and $integrity) { + # Trying to turn install mode on but we have a good DB! + require Carp; + $RT::Logger->error( + Carp::longmess("Something tried to turn on InstallMode but we have DB integrity!") + ); + } + else { + $_INSTALL_MODE = shift; + if($_INSTALL_MODE) { + require RT::CurrentUser; + $SystemUser = RT::CurrentUser->new(); + } + } + } + return $_INSTALL_MODE; +} + +sub LoadGeneratedData { + my $class = shift; + my $pm_path = ( File::Spec->splitpath( $INC{'RT.pm'} ) )[1]; + + require "$pm_path/RT/Generated.pm" || die "Couldn't load RT::Generated: $@"; + $class->CanonicalizeGeneratedPaths(); +} + +sub CanonicalizeGeneratedPaths { + my $class = shift; + unless ( File::Spec->file_name_is_absolute($EtcPath) ) { + + # if BasePath exists and is absolute, we won't infer it from $INC{'RT.pm'}. + # otherwise RT.pm will make the source dir(where we configure RT) be the + # BasePath instead of the one specified by --prefix + unless ( -d $BasePath + && File::Spec->file_name_is_absolute($BasePath) ) + { + my $pm_path = ( File::Spec->splitpath( $INC{'RT.pm'} ) )[1]; + + # need rel2abs here is to make sure path is absolute, since $INC{'RT.pm'} + # is not always absolute + $BasePath = File::Spec->rel2abs( + File::Spec->catdir( $pm_path, File::Spec->updir ) ); + } + + $BasePath = Cwd::realpath($BasePath); + + for my $path ( + qw/EtcPath BinPath SbinPath VarPath LocalPath LocalEtcPath + LocalLibPath LexiconPath LocalLexiconPath PluginPath + LocalPluginPath MasonComponentRoot MasonLocalComponentRoot + MasonDataDir MasonSessionDir/ + ) + { + no strict 'refs'; + + # just change relative ones + $$path = File::Spec->catfile( $BasePath, $$path ) + unless File::Spec->file_name_is_absolute($$path); + } + } + +} + +=head2 AddJavaScript + +helper method to add js files to C<JSFiles> config. +to add extra js files, you can add the following line +in the plugin's main file: + + RT->AddJavaScript( 'foo.js', 'bar.js' ); + +=cut + +sub AddJavaScript { + my $self = shift; + + my @old = RT->Config->Get('JSFiles'); + RT->Config->Set( 'JSFiles', @old, @_ ); + return RT->Config->Get('JSFiles'); +} + +=head2 AddStyleSheets + +helper method to add css files to C<CSSFiles> config + +to add extra css files, you can add the following line +in the plugin's main file: + + RT->AddStyleSheets( 'foo.css', 'bar.css' ); + +=cut + +sub AddStyleSheets { + my $self = shift; + my @old = RT->Config->Get('CSSFiles'); + RT->Config->Set( 'CSSFiles', @old, @_ ); + return RT->Config->Get('CSSFiles'); +} + +=head2 JavaScript + +helper method of RT->Config->Get('JSFiles') + +=cut + +sub JavaScript { + return RT->Config->Get('JSFiles'); +} + +=head2 StyleSheets + +helper method of RT->Config->Get('CSSFiles') + +=cut + +sub StyleSheets { + return RT->Config->Get('CSSFiles'); +} + +=head1 BUGS + +Please report them to rt-bugs@bestpractical.com, if you know what's +broken and have at least some idea of what needs to be fixed. + +If you're not sure what's going on, report them rt-devel@lists.bestpractical.com. + +=head1 SEE ALSO + +L<RT::StyleGuide> +L<DBIx::SearchBuilder> + +=cut + +require RT::Base; +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/.Handle.pm.swp b/rt/lib/RT/.Handle.pm.swp Binary files differnew file mode 100644 index 000000000..5ae85734d --- /dev/null +++ b/rt/lib/RT/.Handle.pm.swp diff --git a/rt/lib/RT/.Ticket.pm.swp b/rt/lib/RT/.Ticket.pm.swp Binary files differnew file mode 100644 index 000000000..7088d1bcf --- /dev/null +++ b/rt/lib/RT/.Ticket.pm.swp diff --git a/rt/lib/RT/Action/CreateTickets.pm b/rt/lib/RT/Action/CreateTickets.pm index e3c7b53e0..542cbd27b 100644 --- a/rt/lib/RT/Action/CreateTickets.pm +++ b/rt/lib/RT/Action/CreateTickets.pm @@ -579,15 +579,11 @@ sub _ParseMultilineTemplate { my %args = (@_); my $template_id; - require Encode; - require utf8; my ( $queue, $requestor ); $RT::Logger->debug("Line: ==="); foreach my $line ( split( /\n/, $args{'Content'} ) ) { $line =~ s/\r$//; - $RT::Logger->debug( "Line: " . utf8::is_utf8($line) - ? Encode::encode_utf8($line) - : $line ); + $RT::Logger->debug( "Line: $line" ); if ( $line =~ /^===/ ) { if ( $template_id && !$queue && $args{'Queue'} ) { $self->{'templates'}->{$template_id} @@ -790,10 +786,10 @@ sub ParseLines { ); if ( $args{content} ) { - my $mimeobj = MIME::Entity->new(); - $mimeobj->build( - Type => $args{'contenttype'} || 'text/plain', - Data => $args{'content'} + my $mimeobj = MIME::Entity->build( + Type => $args{'contenttype'} || 'text/plain', + Charset => 'UTF-8', + Data => [ map {Encode::encode( "UTF-8", $_ )} @{$args{'content'}} ], ); $ticketargs{MIMEObj} = $mimeobj; $ticketargs{UpdateType} = $args{'updatetype'} || 'correspond'; diff --git a/rt/lib/RT/Action/CreateTickets.pm.orig b/rt/lib/RT/Action/CreateTickets.pm.orig new file mode 100644 index 000000000..e3c7b53e0 --- /dev/null +++ b/rt/lib/RT/Action/CreateTickets.pm.orig @@ -0,0 +1,1292 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +package RT::Action::CreateTickets; +use base 'RT::Action'; + +use strict; +use warnings; + +use MIME::Entity; + +=head1 NAME + +RT::Action::CreateTickets - Create one or more tickets according to an externally supplied template + +=head1 SYNOPSIS + + ===Create-Ticket: codereview + Subject: Code review for {$Tickets{'TOP'}->Subject} + Depended-On-By: TOP + Content: Someone has created a ticket. you should review and approve it, + so they can finish their work + ENDOFCONTENT + +=head1 DESCRIPTION + +The CreateTickets ScripAction allows you to create automated workflows in RT, +creating new tickets in response to actions and conditions from other +tickets. + +=head2 Format + +CreateTickets uses the RT template configured in the scrip as a template +for an ordered set of tickets to create. The basic format is as follows: + + ===Create-Ticket: identifier + Param: Value + Param2: Value + Param3: Value + Content: Blah + blah + blah + ENDOFCONTENT + ===Create-Ticket: id2 + Param: Value + Content: Blah + ENDOFCONTENT + +As shown, you can put one or more C<===Create-Ticket:> sections in +a template. Each C<===Create-Ticket:> section is evaluated as its own +L<Text::Template> object, which means that you can embed snippets +of Perl inside the L<Text::Template> using C<{}> delimiters, but that +such sections absolutely can not span a C<===Create-Ticket:> boundary. + +Note that each C<Value> must come right after the C<Param> on the same +line. The C<Content:> param can extend over multiple lines, but the text +of the first line must start right after C<Content:>. Don't try to start +your C<Content:> section with a newline. + +After each ticket is created, it's stuffed into a hash called C<%Tickets> +making it available during the creation of other tickets during the +same ScripAction. The hash key for each ticket is C<create-[identifier]>, +where C<[identifier]> is the value you put after C<===Create-Ticket:>. The hash +is prepopulated with the ticket which triggered the ScripAction as +C<$Tickets{'TOP'}>. You can also access that ticket using the shorthand +C<TOP>. + +A simple example: + + ===Create-Ticket: codereview + Subject: Code review for {$Tickets{'TOP'}->Subject} + Depended-On-By: TOP + Content: Someone has created a ticket. you should review and approve it, + so they can finish their work + ENDOFCONTENT + +A convoluted example: + + ===Create-Ticket: approval + { # Find out who the administrators of the group called "HR" + # of which the creator of this ticket is a member + my $name = "HR"; + + my $groups = RT::Groups->new(RT->SystemUser); + $groups->LimitToUserDefinedGroups(); + $groups->Limit(FIELD => "Name", OPERATOR => "=", VALUE => "$name"); + $groups->WithMember($TransactionObj->CreatorObj->Id); + + my $groupid = $groups->First->Id; + + my $adminccs = RT::Users->new(RT->SystemUser); + $adminccs->WhoHaveRight( + Right => "AdminGroup", + Object =>$groups->First, + IncludeSystemRights => undef, + IncludeSuperusers => 0, + IncludeSubgroupMembers => 0, + ); + + our @admins; + while (my $admin = $adminccs->Next) { + push (@admins, $admin->EmailAddress); + } + } + Queue: ___Approvals + Type: approval + AdminCc: {join ("\nAdminCc: ",@admins) } + Depended-On-By: TOP + Refers-To: TOP + Subject: Approval for ticket: {$Tickets{"TOP"}->Id} - {$Tickets{"TOP"}->Subject} + Due: {time + 86400} + Content-Type: text/plain + Content: Your approval is requested for the ticket {$Tickets{"TOP"}->Id}: {$Tickets{"TOP"}->Subject} + Blah + Blah + ENDOFCONTENT + ===Create-Ticket: two + Subject: Manager approval + Type: approval + Depended-On-By: TOP + Refers-To: {$Tickets{"create-approval"}->Id} + Queue: ___Approvals + Content-Type: text/plain + Content: Your approval is requred for this ticket, too. + ENDOFCONTENT + +As shown above, you can include a block with Perl code to set up some +values for the new tickets. If you want to access a variable in the +template section after the block, you must scope it with C<our> rather +than C<my>. Just as with other RT templates, you can also include +Perl code in the template sections using C<{}>. + +=head2 Acceptable Fields + +A complete list of acceptable fields: + + * Queue => Name or id# of a queue + Subject => A text string + ! Status => A valid status. Defaults to 'new' + Due => Dates can be specified in seconds since the epoch + to be handled literally or in a semi-free textual + format which RT will attempt to parse. + Starts => + Started => + Resolved => + Owner => Username or id of an RT user who can and should own + this ticket; forces the owner if necessary + + Requestor => Email address + + Cc => Email address + + AdminCc => Email address + + RequestorGroup => Group name + + CcGroup => Group name + + AdminCcGroup => Group name + TimeWorked => + TimeEstimated => + TimeLeft => + InitialPriority => + FinalPriority => + Type => + +! DependsOn => + +! DependedOnBy => + +! RefersTo => + +! ReferredToBy => + +! Members => + +! MemberOf => + Content => Content. Can extend to multiple lines. Everything + within a template after a Content: header is treated + as content until we hit a line containing only + ENDOFCONTENT + ContentType => the content-type of the Content field. Defaults to + 'text/plain' + UpdateType => 'correspond' or 'comment'; used in conjunction with + 'content' if this is an update. Defaults to + 'correspond' + + CustomField-<id#> => custom field value + CF-name => custom field value + CustomField-name => custom field value + +Fields marked with an C<*> are required. + +Fields marked with a C<+> may have multiple values, simply +by repeating the fieldname on a new line with an additional value. + +Fields marked with a C<!> have processing postponed until after all +tickets in the same actions are created. Except for C<Status>, those +fields can also take a ticket name within the same action (i.e. +the identifiers after C<===Create-Ticket:>), instead of raw ticket ID +numbers. + +When parsed, field names are converted to lowercase and have hyphens stripped. +C<Refers-To>, C<RefersTo>, C<refersto>, C<refers-to> and C<r-e-f-er-s-tO> will +all be treated as the same thing. + +=head1 METHODS + +=cut + +my %LINKTYPEMAP = ( + MemberOf => { + Type => 'MemberOf', + Mode => 'Target', + }, + Parents => { + Type => 'MemberOf', + Mode => 'Target', + }, + Members => { + Type => 'MemberOf', + Mode => 'Base', + }, + Children => { + Type => 'MemberOf', + Mode => 'Base', + }, + HasMember => { + Type => 'MemberOf', + Mode => 'Base', + }, + RefersTo => { + Type => 'RefersTo', + Mode => 'Target', + }, + ReferredToBy => { + Type => 'RefersTo', + Mode => 'Base', + }, + DependsOn => { + Type => 'DependsOn', + Mode => 'Target', + }, + DependedOnBy => { + Type => 'DependsOn', + Mode => 'Base', + }, + +); + + +#Do what we need to do and send it out. +sub Commit { + my $self = shift; + + # Create all the tickets we care about + return (1) unless $self->TicketObj->Type eq 'ticket'; + + $self->CreateByTemplate( $self->TicketObj ); + $self->UpdateByTemplate( $self->TicketObj ); + return (1); +} + + + +sub Prepare { + my $self = shift; + + unless ( $self->TemplateObj ) { + $RT::Logger->warning("No template object handed to $self"); + } + + unless ( $self->TransactionObj ) { + $RT::Logger->warning("No transaction object handed to $self"); + + } + + unless ( $self->TicketObj ) { + $RT::Logger->warning("No ticket object handed to $self"); + + } + + my $active = 0; + if ( $self->TemplateObj->Type eq 'Perl' ) { + $active = 1; + } else { + RT->Logger->info(sprintf( + "Template #%d is type %s. You most likely want to use a Perl template instead.", + $self->TemplateObj->id, $self->TemplateObj->Type + )); + } + + $self->Parse( + Content => $self->TemplateObj->Content, + _ActiveContent => $active, + ); + return 1; + +} + + + +sub CreateByTemplate { + my $self = shift; + my $top = shift; + + $RT::Logger->debug("In CreateByTemplate"); + + my @results; + + # XXX: cargo cult programming that works. i'll be back. + + local %T::Tickets = %T::Tickets; + local $T::TOP = $T::TOP; + local $T::ID = $T::ID; + $T::Tickets{'TOP'} = $T::TOP = $top if $top; + local $T::TransactionObj = $self->TransactionObj; + + my $ticketargs; + my ( @links, @postponed ); + foreach my $template_id ( @{ $self->{'create_tickets'} } ) { + $RT::Logger->debug("Workflow: processing $template_id of $T::TOP") + if $T::TOP; + + $T::ID = $template_id; + @T::AllID = @{ $self->{'create_tickets'} }; + + ( $T::Tickets{$template_id}, $ticketargs ) + = $self->ParseLines( $template_id, \@links, \@postponed ); + + # Now we have a %args to work with. + # Make sure we have at least the minimum set of + # reasonable data and do our thang + + my ( $id, $transid, $msg ) + = $T::Tickets{$template_id}->Create(%$ticketargs); + + foreach my $res ( split( '\n', $msg ) ) { + push @results, + $T::Tickets{$template_id} + ->loc( "Ticket [_1]", $T::Tickets{$template_id}->Id ) . ': ' + . $res; + } + if ( !$id ) { + if ( $self->TicketObj ) { + $msg = "Couldn't create related ticket $template_id for " + . $self->TicketObj->Id . " " + . $msg; + } else { + $msg = "Couldn't create ticket $template_id " . $msg; + } + + $RT::Logger->error($msg); + next; + } + + $RT::Logger->debug("Assigned $template_id with $id"); + $T::Tickets{$template_id}->SetOriginObj( $self->TicketObj ) + if $self->TicketObj + && $T::Tickets{$template_id}->can('SetOriginObj'); + + } + + $self->PostProcess( \@links, \@postponed ); + + return @results; +} + +sub UpdateByTemplate { + my $self = shift; + my $top = shift; + + # XXX: cargo cult programming that works. i'll be back. + + my @results; + local %T::Tickets = %T::Tickets; + local $T::ID = $T::ID; + + my $ticketargs; + my ( @links, @postponed ); + foreach my $template_id ( @{ $self->{'update_tickets'} } ) { + $RT::Logger->debug("Update Workflow: processing $template_id"); + + $T::ID = $template_id; + @T::AllID = @{ $self->{'update_tickets'} }; + + ( $T::Tickets{$template_id}, $ticketargs ) + = $self->ParseLines( $template_id, \@links, \@postponed ); + + # Now we have a %args to work with. + # Make sure we have at least the minimum set of + # reasonable data and do our thang + + my @attribs = qw( + Subject + FinalPriority + Priority + TimeEstimated + TimeWorked + TimeLeft + Status + Queue + Due + Starts + Started + Resolved + ); + + my $id = $template_id; + $id =~ s/update-(\d+).*/$1/; + my ($loaded, $msg) = $T::Tickets{$template_id}->LoadById($id); + + unless ( $loaded ) { + $RT::Logger->error("Couldn't update ticket $template_id: " . $msg); + push @results, $self->loc( "Couldn't load ticket '[_1]'", $id ); + next; + } + + my $current = $self->GetBaseTemplate( $T::Tickets{$template_id} ); + + $template_id =~ m/^update-(.*)/; + my $base_id = "base-$1"; + my $base = $self->{'templates'}->{$base_id}; + if ($base) { + $base =~ s/\r//g; + $base =~ s/\n+$//; + $current =~ s/\n+$//; + + # If we have no base template, set what we can. + if ( $base ne $current ) { + push @results, + "Could not update ticket " + . $T::Tickets{$template_id}->Id + . ": Ticket has changed"; + next; + } + } + push @results, $T::Tickets{$template_id}->Update( + AttributesRef => \@attribs, + ARGSRef => $ticketargs + ); + + if ( $ticketargs->{'Owner'} ) { + ($id, $msg) = $T::Tickets{$template_id}->SetOwner($ticketargs->{'Owner'}, "Force"); + push @results, $msg unless $msg eq $self->loc("That user already owns that ticket"); + } + + push @results, + $self->UpdateWatchers( $T::Tickets{$template_id}, $ticketargs ); + + push @results, + $self->UpdateCustomFields( $T::Tickets{$template_id}, $ticketargs ); + + next unless $ticketargs->{'MIMEObj'}; + if ( $ticketargs->{'UpdateType'} =~ /^(private|comment)$/i ) { + my ( $Transaction, $Description, $Object ) + = $T::Tickets{$template_id}->Comment( + BccMessageTo => $ticketargs->{'Bcc'}, + MIMEObj => $ticketargs->{'MIMEObj'}, + TimeTaken => $ticketargs->{'TimeWorked'} + ); + push( @results, + $T::Tickets{$template_id} + ->loc( "Ticket [_1]", $T::Tickets{$template_id}->id ) + . ': ' + . $Description ); + } elsif ( $ticketargs->{'UpdateType'} =~ /^(public|response|correspond)$/i ) { + my ( $Transaction, $Description, $Object ) + = $T::Tickets{$template_id}->Correspond( + BccMessageTo => $ticketargs->{'Bcc'}, + MIMEObj => $ticketargs->{'MIMEObj'}, + TimeTaken => $ticketargs->{'TimeWorked'} + ); + push( @results, + $T::Tickets{$template_id} + ->loc( "Ticket [_1]", $T::Tickets{$template_id}->id ) + . ': ' + . $Description ); + } else { + push( + @results, + $T::Tickets{$template_id}->loc( + "Update type was neither correspondence nor comment.") + . " " + . $T::Tickets{$template_id}->loc("Update not recorded.") + ); + } + } + + $self->PostProcess( \@links, \@postponed ); + + return @results; +} + +=head2 Parse + +Takes (in order) template content, a default queue, a default requestor, and +active (a boolean flag). + +Parses a template in the template content, defaulting queue and requestor if +unspecified in the template to the values provided as arguments. + +If the active flag is true, then we'll use L<Text::Template> to parse the +templates, allowing you to embed active Perl in your templates. + +=cut + +sub Parse { + my $self = shift; + my %args = ( + Content => undef, + Queue => undef, + Requestor => undef, + _ActiveContent => undef, + @_ + ); + + if ( $args{'_ActiveContent'} ) { + $self->{'UsePerlTextTemplate'} = 1; + } else { + + $self->{'UsePerlTextTemplate'} = 0; + } + + if ( substr( $args{'Content'}, 0, 3 ) eq '===' ) { + $self->_ParseMultilineTemplate(%args); + } elsif ( $args{'Content'} =~ /(?:\t|,)/i ) { + $self->_ParseXSVTemplate(%args); + } else { + RT->Logger->error("Invalid Template Content (Couldn't find ===, and is not a csv/tsv template) - unable to parse: $args{Content}"); + } +} + +=head2 _ParseMultilineTemplate + +Parses mulitline templates. Things like: + + ===Create-Ticket: ... + +Takes the same arguments as L</Parse>. + +=cut + +sub _ParseMultilineTemplate { + my $self = shift; + my %args = (@_); + + my $template_id; + require Encode; + require utf8; + my ( $queue, $requestor ); + $RT::Logger->debug("Line: ==="); + foreach my $line ( split( /\n/, $args{'Content'} ) ) { + $line =~ s/\r$//; + $RT::Logger->debug( "Line: " . utf8::is_utf8($line) + ? Encode::encode_utf8($line) + : $line ); + if ( $line =~ /^===/ ) { + if ( $template_id && !$queue && $args{'Queue'} ) { + $self->{'templates'}->{$template_id} + .= "Queue: $args{'Queue'}\n"; + } + if ( $template_id && !$requestor && $args{'Requestor'} ) { + $self->{'templates'}->{$template_id} + .= "Requestor: $args{'Requestor'}\n"; + } + $queue = 0; + $requestor = 0; + } + if ( $line =~ /^===Create-Ticket: (.*)$/ ) { + $template_id = "create-$1"; + $RT::Logger->debug("**** Create ticket: $template_id"); + push @{ $self->{'create_tickets'} }, $template_id; + } elsif ( $line =~ /^===Update-Ticket: (.*)$/ ) { + $template_id = "update-$1"; + $RT::Logger->debug("**** Update ticket: $template_id"); + push @{ $self->{'update_tickets'} }, $template_id; + } elsif ( $line =~ /^===Base-Ticket: (.*)$/ ) { + $template_id = "base-$1"; + $RT::Logger->debug("**** Base ticket: $template_id"); + push @{ $self->{'base_tickets'} }, $template_id; + } elsif ( $line =~ /^===#.*$/ ) { # a comment + next; + } else { + if ( $line =~ /^Queue:(.*)/i ) { + $queue = 1; + my $value = $1; + $value =~ s/^\s//; + $value =~ s/\s$//; + if ( !$value && $args{'Queue'} ) { + $value = $args{'Queue'}; + $line = "Queue: $value"; + } + } + if ( $line =~ /^Requestors?:(.*)/i ) { + $requestor = 1; + my $value = $1; + $value =~ s/^\s//; + $value =~ s/\s$//; + if ( !$value && $args{'Requestor'} ) { + $value = $args{'Requestor'}; + $line = "Requestor: $value"; + } + } + $self->{'templates'}->{$template_id} .= $line . "\n"; + } + } + if ( $template_id && !$queue && $args{'Queue'} ) { + $self->{'templates'}->{$template_id} .= "Queue: $args{'Queue'}\n"; + } + } + +sub ParseLines { + my $self = shift; + my $template_id = shift; + my $links = shift; + my $postponed = shift; + + my $content = $self->{'templates'}->{$template_id}; + + if ( $self->{'UsePerlTextTemplate'} ) { + + $RT::Logger->debug( + "Workflow: evaluating\n$self->{templates}{$template_id}"); + + my $template = Text::Template->new( + TYPE => 'STRING', + SOURCE => $content + ); + + my $err; + $content = $template->fill_in( + PACKAGE => 'T', + BROKEN => sub { + $err = {@_}->{error}; + } + ); + + $RT::Logger->debug("Workflow: yielding $content"); + + if ($err) { + $RT::Logger->error( "Ticket creation failed: " . $err ); + while ( my ( $k, $v ) = each %T::X ) { + $RT::Logger->debug( + "Eliminating $template_id from ${k}'s parents."); + delete $v->{$template_id}; + } + next; + } + } + + my $TicketObj ||= RT::Ticket->new( $self->CurrentUser ); + + my %args; + my %original_tags; + my @lines = ( split( /\n/, $content ) ); + while ( defined( my $line = shift @lines ) ) { + if ( $line =~ /^(.*?):(?:\s+)(.*?)(?:\s*)$/ ) { + my $value = $2; + my $original_tag = $1; + my $tag = lc($original_tag); + $tag =~ s/-//g; + $tag =~ s/^(requestor|cc|admincc)s?$/$1/i; + + $original_tags{$tag} = $original_tag; + + if ( ref( $args{$tag} ) ) + { #If it's an array, we want to push the value + push @{ $args{$tag} }, $value; + } elsif ( defined( $args{$tag} ) ) + { #if we're about to get a second value, make it an array + $args{$tag} = [ $args{$tag}, $value ]; + } else { #if there's nothing there, just set the value + $args{$tag} = $value; + } + + if ( $tag =~ /^content$/i ) { #just build up the content + # convert it to an array + $args{$tag} = defined($value) ? [ $value . "\n" ] : []; + while ( defined( my $l = shift @lines ) ) { + last if ( $l =~ /^ENDOFCONTENT\s*$/ ); + push @{ $args{'content'} }, $l . "\n"; + } + } else { + # if it's not content, strip leading and trailing spaces + if ( $args{$tag} ) { + $args{$tag} =~ s/^\s+//g; + $args{$tag} =~ s/\s+$//g; + } + if ( + ($tag =~ /^(requestor|cc|admincc)(group)?$/i + or grep {lc $_ eq $tag} keys %LINKTYPEMAP) + and $args{$tag} =~ /,/ + ) { + $args{$tag} = [ split /,\s*/, $args{$tag} ]; + } + } + } + } + + foreach my $date (qw(due starts started resolved)) { + my $dateobj = RT::Date->new( $self->CurrentUser ); + next unless $args{$date}; + if ( $args{$date} =~ /^\d+$/ ) { + $dateobj->Set( Format => 'unix', Value => $args{$date} ); + } else { + eval { + $dateobj->Set( Format => 'iso', Value => $args{$date} ); + }; + if ($@ or $dateobj->Unix <= 0) { + $dateobj->Set( Format => 'unknown', Value => $args{$date} ); + } + } + $args{$date} = $dateobj->ISO; + } + + foreach my $role (qw(requestor cc admincc)) { + next unless my $value = $args{ $role . 'group' }; + + my $group = RT::Group->new( $self->CurrentUser ); + $group->LoadUserDefinedGroup( $value ); + unless ( $group->id ) { + $RT::Logger->error("Couldn't load group '$value'"); + next; + } + + $args{ $role } = $args{ $role } ? [$args{ $role }] : [] + unless ref $args{ $role }; + push @{ $args{ $role } }, $group->PrincipalObj->id; + } + + $args{'requestor'} ||= $self->TicketObj->Requestors->MemberEmailAddresses + if $self->TicketObj; + + $args{'type'} ||= 'ticket'; + + my %ticketargs = ( + Queue => $args{'queue'}, + Subject => $args{'subject'}, + Status => $args{'status'} || 'new', + Due => $args{'due'}, + Starts => $args{'starts'}, + Started => $args{'started'}, + Resolved => $args{'resolved'}, + Owner => $args{'owner'}, + Requestor => $args{'requestor'}, + Cc => $args{'cc'}, + AdminCc => $args{'admincc'}, + TimeWorked => $args{'timeworked'}, + TimeEstimated => $args{'timeestimated'}, + TimeLeft => $args{'timeleft'}, + InitialPriority => $args{'initialpriority'} || 0, + FinalPriority => $args{'finalpriority'} || 0, + SquelchMailTo => $args{'squelchmailto'}, + Type => $args{'type'}, + $self->Rules + ); + + if ( $args{content} ) { + my $mimeobj = MIME::Entity->new(); + $mimeobj->build( + Type => $args{'contenttype'} || 'text/plain', + Data => $args{'content'} + ); + $ticketargs{MIMEObj} = $mimeobj; + $ticketargs{UpdateType} = $args{'updatetype'} || 'correspond'; + } + + foreach my $tag ( keys(%args) ) { + # if the tag was added later, skip it + my $orig_tag = $original_tags{$tag} or next; + if ( $orig_tag =~ /^customfield-?(\d+)$/i ) { + $ticketargs{ "CustomField-" . $1 } = $args{$tag}; + } elsif ( $orig_tag =~ /^(?:customfield|cf)-?(.+)$/i ) { + my $cf = RT::CustomField->new( $self->CurrentUser ); + $cf->LoadByName( Name => $1, Queue => $ticketargs{Queue} ); + $cf->LoadByName( Name => $1, Queue => 0 ) unless $cf->id; + next unless $cf->id; + $ticketargs{ "CustomField-" . $cf->id } = $args{$tag}; + } elsif ($orig_tag) { + my $cf = RT::CustomField->new( $self->CurrentUser ); + $cf->LoadByName( Name => $orig_tag, Queue => $ticketargs{Queue} ); + $cf->LoadByName( Name => $orig_tag, Queue => 0 ) unless $cf->id; + next unless $cf->id; + $ticketargs{ "CustomField-" . $cf->id } = $args{$tag}; + + } + } + + $self->GetDeferred( \%args, $template_id, $links, $postponed ); + + return $TicketObj, \%ticketargs; +} + + +=head2 _ParseXSVTemplate + +Parses a tab or comma delimited template. Should only ever be called by +L</Parse>. + +=cut + +sub _ParseXSVTemplate { + my $self = shift; + my %args = (@_); + + use Regexp::Common qw(delimited); + my($first, $content) = split(/\r?\n/, $args{'Content'}, 2); + + my $delimiter; + if ( $first =~ /\t/ ) { + $delimiter = "\t"; + } else { + $delimiter = ','; + } + my @fields = split( /$delimiter/, $first ); + + my $delimiter_re = qr[$delimiter]; + my $justquoted = qr[$RE{quoted}]; + + # Used to generate automatic template ids + my $autoid = 1; + + LINE: + while ($content) { + $content =~ s/^(\s*\r?\n)+//; + + # Keep track of Queue and Requestor, so we can provide defaults + my $queue; + my $requestor; + + # The template for this line + my $template; + + # What column we're on + my $i = 0; + + # If the last iteration was the end of the line + my $EOL = 0; + + # The template id + my $template_id; + + COLUMN: + while (not $EOL and length $content and $content =~ s/^($justquoted|.*?)($delimiter_re|$)//smix) { + $EOL = not $2; + + # Strip off quotes, if they exist + my $value = $1; + if ( $value =~ /^$RE{delimited}{-delim=>qq{\'\"}}$/ ) { + substr( $value, 0, 1 ) = ""; + substr( $value, -1, 1 ) = ""; + } + + # What column is this? + my $field = $fields[$i++]; + next COLUMN unless $field =~ /\S/; + $field =~ s/^\s//; + $field =~ s/\s$//; + + if ( $field =~ /^id$/i ) { + # Special case if this is the ID column + if ( $value =~ /^\d+$/ ) { + $template_id = 'update-' . $value; + push @{ $self->{'update_tickets'} }, $template_id; + } elsif ( $value =~ /^#base-(\d+)$/ ) { + $template_id = 'base-' . $1; + push @{ $self->{'base_tickets'} }, $template_id; + } elsif ( $value =~ /\S/ ) { + $template_id = 'create-' . $value; + push @{ $self->{'create_tickets'} }, $template_id; + } + } else { + # Some translations + if ( $field =~ /^Body$/i + || $field =~ /^Data$/i + || $field =~ /^Message$/i ) + { + $field = 'Content'; + } elsif ( $field =~ /^Summary$/i ) { + $field = 'Subject'; + } elsif ( $field =~ /^Queue$/i ) { + # Note that we found a queue + $queue = 1; + $value ||= $args{'Queue'}; + } elsif ( $field =~ /^Requestors?$/i ) { + $field = 'Requestor'; # Remove plural + # Note that we found a requestor + $requestor = 1; + $value ||= $args{'Requestor'}; + } + + # Tack onto the end of the template + $template .= $field . ": "; + $template .= (defined $value ? $value : ""); + $template .= "\n"; + $template .= "ENDOFCONTENT\n" + if $field =~ /^Content$/i; + } + } + + # Ignore blank lines + next unless $template; + + # If we didn't find a queue of requestor, tack on the defaults + if ( !$queue && $args{'Queue'} ) { + $template .= "Queue: $args{'Queue'}\n"; + } + if ( !$requestor && $args{'Requestor'} ) { + $template .= "Requestor: $args{'Requestor'}\n"; + } + + # If we never found an ID, come up with one + unless ($template_id) { + $autoid++ while exists $self->{'templates'}->{"create-auto-$autoid"}; + $template_id = "create-auto-$autoid"; + # Also, it's a ticket to create + push @{ $self->{'create_tickets'} }, $template_id; + } + + # Save the template we generated + $self->{'templates'}->{$template_id} = $template; + + } +} + +sub GetDeferred { + my $self = shift; + my $args = shift; + my $id = shift; + my $links = shift; + my $postponed = shift; + + # Deferred processing + push @$links, + ( + $id, + { DependsOn => $args->{'dependson'}, + DependedOnBy => $args->{'dependedonby'}, + RefersTo => $args->{'refersto'}, + ReferredToBy => $args->{'referredtoby'}, + Children => $args->{'children'}, + Parents => $args->{'parents'}, + } + ); + + push @$postponed, ( + + # Status is postponed so we don't violate dependencies + $id, { Status => $args->{'status'}, } + ); +} + +sub GetUpdateTemplate { + my $self = shift; + my $t = shift; + + my $string; + $string .= "Queue: " . $t->QueueObj->Name . "\n"; + $string .= "Subject: " . $t->Subject . "\n"; + $string .= "Status: " . $t->Status . "\n"; + $string .= "UpdateType: correspond\n"; + $string .= "Content: \n"; + $string .= "ENDOFCONTENT\n"; + $string .= "Due: " . $t->DueObj->AsString . "\n"; + $string .= "Starts: " . $t->StartsObj->AsString . "\n"; + $string .= "Started: " . $t->StartedObj->AsString . "\n"; + $string .= "Resolved: " . $t->ResolvedObj->AsString . "\n"; + $string .= "Owner: " . $t->OwnerObj->Name . "\n"; + $string .= "Requestor: " . $t->RequestorAddresses . "\n"; + $string .= "Cc: " . $t->CcAddresses . "\n"; + $string .= "AdminCc: " . $t->AdminCcAddresses . "\n"; + $string .= "TimeWorked: " . $t->TimeWorked . "\n"; + $string .= "TimeEstimated: " . $t->TimeEstimated . "\n"; + $string .= "TimeLeft: " . $t->TimeLeft . "\n"; + $string .= "InitialPriority: " . $t->Priority . "\n"; + $string .= "FinalPriority: " . $t->FinalPriority . "\n"; + + foreach my $type ( sort keys %LINKTYPEMAP ) { + + # don't display duplicates + if ( $type eq "HasMember" + || $type eq "Members" + || $type eq "MemberOf" ) + { + next; + } + $string .= "$type: "; + + my $mode = $LINKTYPEMAP{$type}->{Mode}; + my $method = $LINKTYPEMAP{$type}->{Type}; + + my $links = ''; + while ( my $link = $t->$method->Next ) { + $links .= ", " if $links; + + my $object = $mode . "Obj"; + my $member = $link->$object; + $links .= $member->Id if $member; + } + $string .= $links; + $string .= "\n"; + } + + return $string; +} + +sub GetBaseTemplate { + my $self = shift; + my $t = shift; + + my $string; + $string .= "Queue: " . $t->Queue . "\n"; + $string .= "Subject: " . $t->Subject . "\n"; + $string .= "Status: " . $t->Status . "\n"; + $string .= "Due: " . $t->DueObj->Unix . "\n"; + $string .= "Starts: " . $t->StartsObj->Unix . "\n"; + $string .= "Started: " . $t->StartedObj->Unix . "\n"; + $string .= "Resolved: " . $t->ResolvedObj->Unix . "\n"; + $string .= "Owner: " . $t->Owner . "\n"; + $string .= "Requestor: " . $t->RequestorAddresses . "\n"; + $string .= "Cc: " . $t->CcAddresses . "\n"; + $string .= "AdminCc: " . $t->AdminCcAddresses . "\n"; + $string .= "TimeWorked: " . $t->TimeWorked . "\n"; + $string .= "TimeEstimated: " . $t->TimeEstimated . "\n"; + $string .= "TimeLeft: " . $t->TimeLeft . "\n"; + $string .= "InitialPriority: " . $t->Priority . "\n"; + $string .= "FinalPriority: " . $t->FinalPriority . "\n"; + + return $string; +} + +sub GetCreateTemplate { + my $self = shift; + + my $string; + + $string .= "Queue: General\n"; + $string .= "Subject: \n"; + $string .= "Status: new\n"; + $string .= "Content: \n"; + $string .= "ENDOFCONTENT\n"; + $string .= "Due: \n"; + $string .= "Starts: \n"; + $string .= "Started: \n"; + $string .= "Resolved: \n"; + $string .= "Owner: \n"; + $string .= "Requestor: \n"; + $string .= "Cc: \n"; + $string .= "AdminCc:\n"; + $string .= "TimeWorked: \n"; + $string .= "TimeEstimated: \n"; + $string .= "TimeLeft: \n"; + $string .= "InitialPriority: \n"; + $string .= "FinalPriority: \n"; + + foreach my $type ( keys %LINKTYPEMAP ) { + + # don't display duplicates + if ( $type eq "HasMember" + || $type eq 'Members' + || $type eq 'MemberOf' ) + { + next; + } + $string .= "$type: \n"; + } + return $string; +} + +sub UpdateWatchers { + my $self = shift; + my $ticket = shift; + my $args = shift; + + my @results; + + foreach my $type (qw(Requestor Cc AdminCc)) { + my $method = $type . 'Addresses'; + my $oldaddr = $ticket->$method; + + # Skip unless we have a defined field + next unless defined $args->{$type}; + my $newaddr = $args->{$type}; + + my @old = split( /,\s*/, $oldaddr ); + my @new; + for (ref $newaddr ? @{$newaddr} : split( /,\s*/, $newaddr )) { + # Sometimes these are email addresses, sometimes they're + # users. Try to guess which is which, as we want to deal + # with email addresses if at all possible. + if (/^\S+@\S+$/) { + push @new, $_; + } else { + # It doesn't look like an email address. Try to load it. + my $user = RT::User->new($self->CurrentUser); + $user->Load($_); + if ($user->Id) { + push @new, $user->EmailAddress; + } else { + push @new, $_; + } + } + } + + my %oldhash = map { $_ => 1 } @old; + my %newhash = map { $_ => 1 } @new; + + my @add = grep( !defined $oldhash{$_}, @new ); + my @delete = grep( !defined $newhash{$_}, @old ); + + foreach (@add) { + my ( $val, $msg ) = $ticket->AddWatcher( + Type => $type, + Email => $_ + ); + + push @results, + $ticket->loc( "Ticket [_1]", $ticket->Id ) . ': ' . $msg; + } + + foreach (@delete) { + my ( $val, $msg ) = $ticket->DeleteWatcher( + Type => $type, + Email => $_ + ); + push @results, + $ticket->loc( "Ticket [_1]", $ticket->Id ) . ': ' . $msg; + } + } + return @results; +} + +sub UpdateCustomFields { + my $self = shift; + my $ticket = shift; + my $args = shift; + + my @results; + foreach my $arg (keys %{$args}) { + next unless $arg =~ /^CustomField-(\d+)$/; + my $cf = $1; + + my $CustomFieldObj = RT::CustomField->new($self->CurrentUser); + $CustomFieldObj->SetContextObject( $ticket ); + $CustomFieldObj->LoadById($cf); + + my @values; + if ($CustomFieldObj->Type =~ /text/i) { # Both Text and Wikitext + @values = ($args->{$arg}); + } else { + @values = split /\n/, $args->{$arg}; + } + + if ( ($CustomFieldObj->Type eq 'Freeform' + && ! $CustomFieldObj->SingleValue) || + $CustomFieldObj->Type =~ /text/i) { + foreach my $val (@values) { + $val =~ s/\r//g; + } + } + + foreach my $value (@values) { + next unless length($value); + my ( $val, $msg ) = $ticket->AddCustomFieldValue( + Field => $cf, + Value => $value + ); + push ( @results, $msg ); + } + } + return @results; +} + +sub PostProcess { + my $self = shift; + my $links = shift; + my $postponed = shift; + + # postprocessing: add links + + while ( my $template_id = shift(@$links) ) { + my $ticket = $T::Tickets{$template_id}; + $RT::Logger->debug( "Handling links for " . $ticket->Id ); + my %args = %{ shift(@$links) }; + + foreach my $type ( keys %LINKTYPEMAP ) { + next unless ( defined $args{$type} ); + foreach my $link ( + ref( $args{$type} ) ? @{ $args{$type} } : ( $args{$type} ) ) + { + next unless $link; + + if ( $link =~ /^TOP$/i ) { + $RT::Logger->debug( "Building $type link for $link: " + . $T::Tickets{TOP}->Id ); + $link = $T::Tickets{TOP}->Id; + + } elsif ( $link !~ m/^\d+$/ ) { + my $key = "create-$link"; + if ( !exists $T::Tickets{$key} ) { + $RT::Logger->debug( + "Skipping $type link for $key (non-existent)"); + next; + } + $RT::Logger->debug( "Building $type link for $link: " + . $T::Tickets{$key}->Id ); + $link = $T::Tickets{$key}->Id; + } else { + $RT::Logger->debug("Building $type link for $link"); + } + + my ( $wval, $wmsg ) = $ticket->AddLink( + Type => $LINKTYPEMAP{$type}->{'Type'}, + $LINKTYPEMAP{$type}->{'Mode'} => $link, + Silent => 1 + ); + + $RT::Logger->warning("AddLink thru $link failed: $wmsg") + unless $wval; + + # push @non_fatal_errors, $wmsg unless ($wval); + } + + } + } + + # postponed actions -- Status only, currently + while ( my $template_id = shift(@$postponed) ) { + my $ticket = $T::Tickets{$template_id}; + $RT::Logger->debug( "Handling postponed actions for " . $ticket->id ); + my %args = %{ shift(@$postponed) }; + $ticket->SetStatus( $args{Status} ) if defined $args{Status}; + } + +} + +sub Options { + my $self = shift; + my $queues = RT::Queues->new($self->CurrentUser); + $queues->UnLimit; + my @names; + while (my $queue = $queues->Next) { + push @names, $queue->Id, $queue->Name; + } + return ( + { + 'name' => 'Queue', + 'label' => 'In queue', + 'type' => 'select', + 'options' => \@names + } + ) +} + +RT::Base->_ImportOverlays(); + +1; + diff --git a/rt/lib/RT/Action/SendEmail.pm b/rt/lib/RT/Action/SendEmail.pm index 0f11cc141..a483fba9f 100755 --- a/rt/lib/RT/Action/SendEmail.pm +++ b/rt/lib/RT/Action/SendEmail.pm @@ -258,7 +258,7 @@ sub Bcc { sub AddressesFromHeader { my $self = shift; my $field = shift; - my $header = $self->TemplateObj->MIMEObj->head->get($field); + my $header = Encode::decode("UTF-8",$self->TemplateObj->MIMEObj->head->get($field)); my @addresses = Email::Address->parse($header); return (@addresses); @@ -277,7 +277,7 @@ sub SendMessage { # ability to pass @_ to a 'post' routine. my ( $self, $MIMEObj ) = @_; - my $msgid = $MIMEObj->head->get('Message-ID'); + my $msgid = Encode::decode( "UTF-8", $MIMEObj->head->get('Message-ID') ); chomp $msgid; $self->ScripActionObj->{_Message_ID}++; @@ -300,7 +300,7 @@ sub SendMessage { my $success = $msgid . " sent "; foreach (@EMAIL_RECIPIENT_HEADERS) { - my $recipients = $MIMEObj->head->get($_); + my $recipients = Encode::decode( "UTF-8", $MIMEObj->head->get($_) ); $success .= " $_: " . $recipients if $recipients; } @@ -531,7 +531,7 @@ sub RecordOutgoingMailTransaction { $type = 'EmailRecord'; } - my $msgid = $MIMEObj->head->get('Message-ID'); + my $msgid = Encode::decode( "UTF-8", $MIMEObj->head->get('Message-ID') ); chomp $msgid; my ( $id, $msg ) = $transaction->Create( @@ -649,7 +649,7 @@ sub DeferDigestRecipients { # Have to get the list of addresses directly from the MIME header # at this point. - $RT::Logger->debug( $self->TemplateObj->MIMEObj->head->as_string ); + $RT::Logger->debug( Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->as_string ) ); foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) { next unless $rcpt; my $user_obj = RT::User->new(RT->SystemUser); @@ -746,7 +746,7 @@ sub RemoveInappropriateRecipients { # If there are no recipients, don't try to send the message. # If the transaction has content and has the header RT-Squelch-Replies-To - my $msgid = $self->TemplateObj->MIMEObj->head->get('Message-Id'); + my $msgid = Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->get('Message-Id') ); if ( my $attachment = $self->TransactionObj->Attachments->First ) { if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) { @@ -922,7 +922,8 @@ sub GetFriendlyName { =head2 SetHeader FIELD, VALUE -Set the FIELD of the current MIME object into VALUE. +Set the FIELD of the current MIME object into VALUE, which should be in +characters, not bytes. Returns the new header, in bytes. =cut @@ -935,7 +936,7 @@ sub SetHeader { chomp $field; my $head = $self->TemplateObj->MIMEObj->head; $head->fold_length( $field, 10000 ); - $head->replace( $field, $val ); + $head->replace( $field, Encode::encode( "UTF-8", $val ) ); return $head->get($field); } @@ -976,7 +977,7 @@ sub SetSubject { $subject =~ s/(\r\n|\n|\s)/ /g; - $self->SetHeader( 'Subject', Encode::encode_utf8( $subject ) ); + $self->SetHeader( 'Subject', $subject ); } @@ -992,11 +993,9 @@ sub SetSubjectToken { my $head = $self->TemplateObj->MIMEObj->head; $self->SetHeader( Subject => - Encode::encode_utf8( - RT::Interface::Email::AddSubjectTag( - Encode::decode_utf8( $head->get('Subject') ), - $self->TicketObj, - ), + RT::Interface::Email::AddSubjectTag( + Encode::decode( "UTF-8", $head->get('Subject') ), + $self->TicketObj, ), ); } @@ -1090,7 +1089,8 @@ sub PseudoReference { =head2 SetHeaderAsEncoding($field_name, $charset_encoding) -This routine converts the field into specified charset encoding. +This routine converts the field into specified charset encoding, then +applies the MIME-Header transfer encoding. =cut @@ -1101,12 +1101,12 @@ sub SetHeaderAsEncoding { my $head = $self->TemplateObj->MIMEObj->head; if ( lc($field) eq 'from' and RT->Config->Get('SMTPFrom') ) { - $head->replace( $field, RT->Config->Get('SMTPFrom') ); + $head->replace( $field, Encode::encode( "UTF-8", RT->Config->Get('SMTPFrom') ) ); return; } - my $value = $head->get( $field ); - $value = $self->MIMEEncodeString( $value, $enc ); + my $value = Encode::decode("UTF-8", $head->get( $field )); + $value = $self->MIMEEncodeString( $value, $enc ); # Returns bytes $head->replace( $field, $value ); } @@ -1116,7 +1116,8 @@ sub SetHeaderAsEncoding { Takes a perl string and optional encoding pass it over L<RT::Interface::Email/EncodeToMIME>. -Basicly encode a string using B encoding according to RFC2047. +Basicly encode a string using B encoding according to RFC2047, returning +bytes. =cut diff --git a/rt/lib/RT/Action/SendEmail.pm.orig b/rt/lib/RT/Action/SendEmail.pm.orig new file mode 100755 index 000000000..0f11cc141 --- /dev/null +++ b/rt/lib/RT/Action/SendEmail.pm.orig @@ -0,0 +1,1131 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +# Portions Copyright 2000 Tobias Brox <tobix@cpan.org> + +package RT::Action::SendEmail; + +use strict; +use warnings; + +use base qw(RT::Action); + +use RT::EmailParser; +use RT::Interface::Email; +use Email::Address; +our @EMAIL_RECIPIENT_HEADERS = qw(To Cc Bcc); + + +=head1 NAME + +RT::Action::SendEmail - An Action which users can use to send mail +or can subclassed for more specialized mail sending behavior. +RT::Action::AutoReply is a good example subclass. + +=head1 SYNOPSIS + + use base 'RT::Action::SendEmail'; + +=head1 DESCRIPTION + +Basically, you create another module RT::Action::YourAction which ISA +RT::Action::SendEmail. + +=head1 METHODS + +=head2 CleanSlate + +Cleans class-wide options, like L</AttachTickets>. + +=cut + +sub CleanSlate { + my $self = shift; + $self->AttachTickets(undef); +} + +=head2 Commit + +Sends the prepared message and writes outgoing record into DB if the feature is +activated in the config. + +=cut + +sub Commit { + my $self = shift; + + return abs $self->SendMessage( $self->TemplateObj->MIMEObj ) + unless RT->Config->Get('RecordOutgoingEmail'); + + $self->DeferDigestRecipients(); + my $message = $self->TemplateObj->MIMEObj; + + my $orig_message; + $orig_message = $message->dup if RT::Interface::Email::WillSignEncrypt( + Attachment => $self->TransactionObj->Attachments->First, + Ticket => $self->TicketObj, + ); + + my ($ret) = $self->SendMessage($message); + return abs( $ret ) if $ret <= 0; + + if ($orig_message) { + $message->attach( + Type => 'application/x-rt-original-message', + Disposition => 'inline', + Data => $orig_message->as_string, + ); + } + $self->RecordOutgoingMailTransaction($message); + $self->RecordDeferredRecipients(); + return 1; +} + +=head2 Prepare + +Builds an outgoing email we're going to send using scrip's template. + +=cut + +sub Prepare { + my $self = shift; + + my ( $result, $message ) = $self->TemplateObj->Parse( + Argument => $self->Argument, + TicketObj => $self->TicketObj, + TransactionObj => $self->TransactionObj + ); + if ( !$result ) { + return (undef); + } + + my $MIMEObj = $self->TemplateObj->MIMEObj; + + # Header + $self->SetRTSpecialHeaders(); + + my %seen; + foreach my $type (@EMAIL_RECIPIENT_HEADERS) { + @{ $self->{$type} } + = grep defined && length && !$seen{ lc $_ }++, + @{ $self->{$type} }; + } + + $self->RemoveInappropriateRecipients(); + + # Go add all the Tos, Ccs and Bccs that we need to to the message to + # make it happy, but only if we actually have values in those arrays. + +# TODO: We should be pulling the recipients out of the template and shove them into To, Cc and Bcc + + for my $header (@EMAIL_RECIPIENT_HEADERS) { + + $self->SetHeader( $header, join( ', ', @{ $self->{$header} } ) ) + if (!$MIMEObj->head->get($header) + && $self->{$header} + && @{ $self->{$header} } ); + } + # PseudoTo (fake to headers) shouldn't get matched for message recipients. + # If we don't have any 'To' header (but do have other recipients), drop in + # the pseudo-to header. + $self->SetHeader( 'To', join( ', ', @{ $self->{'PseudoTo'} } ) ) + if $self->{'PseudoTo'} + && @{ $self->{'PseudoTo'} } + && !$MIMEObj->head->get('To') + && ( $MIMEObj->head->get('Cc') or $MIMEObj->head->get('Bcc') ); + + # We should never have to set the MIME-Version header + $self->SetHeader( 'MIME-Version', '1.0' ); + + # fsck.com #5959: Since RT sends 8bit mail, we should say so. + $self->SetHeader( 'Content-Transfer-Encoding', '8bit' ); + + # For security reasons, we only send out textual mails. + foreach my $part ( grep !$_->is_multipart, $MIMEObj->parts_DFS ) { + my $type = $part->mime_type || 'text/plain'; + $type = 'text/plain' unless RT::I18N::IsTextualContentType($type); + $part->head->mime_attr( "Content-Type" => $type ); + # utf-8 here is for _FindOrGuessCharset in I18N.pm + # it's not the final charset/encoding sent + $part->head->mime_attr( "Content-Type.charset" => 'utf-8' ); + } + + RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, + RT->Config->Get('EmailOutputEncoding'), + 'mime_words_ok', ); + + # Build up a MIME::Entity that looks like the original message. + $self->AddAttachments if ( $MIMEObj->head->get('RT-Attach-Message') + && ( $MIMEObj->head->get('RT-Attach-Message') !~ /^(n|no|0|off|false)$/i ) ); + + $self->AddTickets; + + my $attachment = $self->TransactionObj->Attachments->First; + if ($attachment + && !( + $attachment->GetHeader('X-RT-Encrypt') + || $self->TicketObj->QueueObj->Encrypt + ) + ) + { + $attachment->SetHeader( 'X-RT-Encrypt' => 1 ) + if ( $attachment->GetHeader("X-RT-Incoming-Encryption") || '' ) eq + 'Success'; + } + + return $result; +} + +=head2 To + +Returns an array of L<Email::Address> objects containing all the To: recipients for this notification + +=cut + +sub To { + my $self = shift; + return ( $self->AddressesFromHeader('To') ); +} + +=head2 Cc + +Returns an array of L<Email::Address> objects containing all the Cc: recipients for this notification + +=cut + +sub Cc { + my $self = shift; + return ( $self->AddressesFromHeader('Cc') ); +} + +=head2 Bcc + +Returns an array of L<Email::Address> objects containing all the Bcc: recipients for this notification + +=cut + +sub Bcc { + my $self = shift; + return ( $self->AddressesFromHeader('Bcc') ); + +} + +sub AddressesFromHeader { + my $self = shift; + my $field = shift; + my $header = $self->TemplateObj->MIMEObj->head->get($field); + my @addresses = Email::Address->parse($header); + + return (@addresses); +} + +=head2 SendMessage MIMEObj + +sends the message using RT's preferred API. +TODO: Break this out to a separate module + +=cut + +sub SendMessage { + + # DO NOT SHIFT @_ in this subroutine. It breaks Hook::LexWrap's + # ability to pass @_ to a 'post' routine. + my ( $self, $MIMEObj ) = @_; + + my $msgid = $MIMEObj->head->get('Message-ID'); + chomp $msgid; + + $self->ScripActionObj->{_Message_ID}++; + + $RT::Logger->info( $msgid . " #" + . $self->TicketObj->id . "/" + . $self->TransactionObj->id + . " - Scrip " + . ($self->ScripObj->id || '#rule'). " " + . ( $self->ScripObj->Description || '' ) ); + + my $status = RT::Interface::Email::SendEmail( + Entity => $MIMEObj, + Ticket => $self->TicketObj, + Transaction => $self->TransactionObj, + ); + + + return $status unless ($status > 0 || exists $self->{'Deferred'}); + + my $success = $msgid . " sent "; + foreach (@EMAIL_RECIPIENT_HEADERS) { + my $recipients = $MIMEObj->head->get($_); + $success .= " $_: " . $recipients if $recipients; + } + + if( exists $self->{'Deferred'} ) { + for (qw(daily weekly susp)) { + $success .= "\nBatched email $_ for: ". join(", ", keys %{ $self->{'Deferred'}{ $_ } } ) + if exists $self->{'Deferred'}{ $_ }; + } + } + + $success =~ s/\n//g; + + $RT::Logger->info($success); + + return (1); +} + +=head2 AddAttachments + +Takes any attachments to this transaction and attaches them to the message +we're building. + +=cut + +sub AddAttachments { + my $self = shift; + + my $MIMEObj = $self->TemplateObj->MIMEObj; + + $MIMEObj->head->delete('RT-Attach-Message'); + + my $attachments = RT::Attachments->new( RT->SystemUser ); + $attachments->Limit( + FIELD => 'TransactionId', + VALUE => $self->TransactionObj->Id + ); + + # Don't attach anything blank + $attachments->LimitNotEmpty; + $attachments->OrderBy( FIELD => 'id' ); + + # We want to make sure that we don't include the attachment that's + # being used as the "Content" of this message" unless that attachment's + # content type is not like text/... + my $transaction_content_obj = $self->TransactionObj->ContentObj; + + if ( $transaction_content_obj + && $transaction_content_obj->ContentType =~ m{text/}i ) + { + # If this was part of a multipart/alternative, skip all of the kids + my $parent = $transaction_content_obj->ParentObj; + if ($parent and $parent->Id and $parent->ContentType eq "multipart/alternative") { + $attachments->Limit( + ENTRYAGGREGATOR => 'AND', + FIELD => 'parent', + OPERATOR => '!=', + VALUE => $parent->Id, + ); + } else { + $attachments->Limit( + ENTRYAGGREGATOR => 'AND', + FIELD => 'id', + OPERATOR => '!=', + VALUE => $transaction_content_obj->Id, + ); + } + } + + # attach any of this transaction's attachments + my $seen_attachment = 0; + while ( my $attach = $attachments->Next ) { + if ( !$seen_attachment ) { + $MIMEObj->make_multipart( 'mixed', Force => 1 ); + $seen_attachment = 1; + } + $self->AddAttachment($attach); + } +} + +=head2 AddAttachment $attachment + +Takes one attachment object of L<RT::Attachment> class and attaches it to the message +we're building. + +=cut + +sub AddAttachment { + my $self = shift; + my $attach = shift; + my $MIMEObj = shift || $self->TemplateObj->MIMEObj; + + # $attach->TransactionObj may not always be $self->TransactionObj + return unless $attach->Id + and $attach->TransactionObj->CurrentUserCanSee; + + # ->attach expects just the disposition type; extract it if we have the header + # or default to "attachment" + my $disp = ($attach->GetHeader('Content-Disposition') || '') + =~ /^\s*(inline|attachment)/i ? $1 : "attachment"; + + $MIMEObj->attach( + Type => $attach->ContentType, + Charset => $attach->OriginalEncoding, + Data => $attach->OriginalContent, + Disposition => $disp, + Filename => $self->MIMEEncodeString( $attach->Filename ), + 'RT-Attachment:' => $self->TicketObj->Id . "/" + . $self->TransactionObj->Id . "/" + . $attach->id, + Encoding => '-SUGGEST', + ); +} + +=head2 AttachTickets [@IDs] + +Returns or set list of ticket's IDs that should be attached to an outgoing message. + +B<Note> this method works as a class method and setup things global, so you have to +clean list by passing undef as argument. + +=cut + +{ + my $list = []; + + sub AttachTickets { + my $self = shift; + $list = [ grep defined, @_ ] if @_; + return @$list; + } +} + +=head2 AddTickets + +Attaches tickets to the current message, list of tickets' ids get from +L</AttachTickets> method. + +=cut + +sub AddTickets { + my $self = shift; + $self->AddTicket($_) foreach $self->AttachTickets; + return; +} + +=head2 AddTicket $ID + +Attaches a ticket with ID to the message. + +Each ticket is attached as multipart entity and all its messages and attachments +are attached as sub entities in order of creation, but only if transaction type +is Create or Correspond. + +=cut + +sub AddTicket { + my $self = shift; + my $tid = shift; + + my $attachs = RT::Attachments->new( $self->TransactionObj->CreatorObj ); + my $txn_alias = $attachs->TransactionAlias; + $attachs->Limit( ALIAS => $txn_alias, FIELD => 'Type', VALUE => 'Create' ); + $attachs->Limit( + ALIAS => $txn_alias, + FIELD => 'Type', + VALUE => 'Correspond' + ); + $attachs->LimitByTicket($tid); + $attachs->LimitNotEmpty; + $attachs->OrderBy( FIELD => 'Created' ); + + my $ticket_mime = MIME::Entity->build( + Type => 'multipart/mixed', + Top => 0, + Description => "ticket #$tid", + ); + while ( my $attachment = $attachs->Next ) { + $self->AddAttachment( $attachment, $ticket_mime ); + } + if ( $ticket_mime->parts ) { + my $email_mime = $self->TemplateObj->MIMEObj; + $email_mime->make_multipart; + $email_mime->add_part($ticket_mime); + } + return; +} + +=head2 RecordOutgoingMailTransaction MIMEObj + +Record a transaction in RT with this outgoing message for future record-keeping purposes + +=cut + +sub RecordOutgoingMailTransaction { + my $self = shift; + my $MIMEObj = shift; + + my @parts = $MIMEObj->parts; + my @attachments; + my @keep; + foreach my $part (@parts) { + my $attach = $part->head->get('RT-Attachment'); + if ($attach) { + $RT::Logger->debug( + "We found an attachment. we want to not record it."); + push @attachments, $attach; + } else { + $RT::Logger->debug("We found a part. we want to record it."); + push @keep, $part; + } + } + $MIMEObj->parts( \@keep ); + foreach my $attachment (@attachments) { + $MIMEObj->head->add( 'RT-Attachment', $attachment ); + } + + RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, 'utf-8', 'mime_words_ok' ); + + my $transaction + = RT::Transaction->new( $self->TransactionObj->CurrentUser ); + +# XXX: TODO -> Record attachments as references to things in the attachments table, maybe. + + my $type; + if ( $self->TransactionObj->Type eq 'Comment' ) { + $type = 'CommentEmailRecord'; + } else { + $type = 'EmailRecord'; + } + + my $msgid = $MIMEObj->head->get('Message-ID'); + chomp $msgid; + + my ( $id, $msg ) = $transaction->Create( + Ticket => $self->TicketObj->Id, + Type => $type, + Data => $msgid, + MIMEObj => $MIMEObj, + ActivateScrips => 0 + ); + + if ($id) { + $self->{'OutgoingMailTransaction'} = $id; + } else { + $RT::Logger->warning( + "Could not record outgoing message transaction: $msg"); + } + return $id; +} + +=head2 SetRTSpecialHeaders + +This routine adds all the random headers that RT wants in a mail message +that don't matter much to anybody else. + +=cut + +sub SetRTSpecialHeaders { + my $self = shift; + + $self->SetSubject(); + $self->SetSubjectToken(); + $self->SetHeaderAsEncoding( 'Subject', + RT->Config->Get('EmailOutputEncoding') ) + if ( RT->Config->Get('EmailOutputEncoding') ); + $self->SetReturnAddress(); + $self->SetReferencesHeaders(); + + unless ( $self->TemplateObj->MIMEObj->head->get('Message-ID') ) { + + # Get Message-ID for this txn + my $msgid = ""; + if ( my $msg = $self->TransactionObj->Message->First ) { + $msgid = $msg->GetHeader("RT-Message-ID") + || $msg->GetHeader("Message-ID"); + } + + # If there is one, and we can parse it, then base our Message-ID on it + if ( $msgid + and $msgid + =~ s/<(rt-.*?-\d+-\d+)\.(\d+)-\d+-\d+\@\QRT->Config->Get('Organization')\E>$/ + "<$1." . $self->TicketObj->id + . "-" . $self->ScripObj->id + . "-" . $self->ScripActionObj->{_Message_ID} + . "@" . RT->Config->Get('Organization') . ">"/eg + and $2 == $self->TicketObj->id + ) + { + $self->SetHeader( "Message-ID" => $msgid ); + } else { + $self->SetHeader( + 'Message-ID' => RT::Interface::Email::GenMessageId( + Ticket => $self->TicketObj, + Scrip => $self->ScripObj, + ScripAction => $self->ScripActionObj + ), + ); + } + } + + if (my $precedence = RT->Config->Get('DefaultMailPrecedence') + and !$self->TemplateObj->MIMEObj->head->get("Precedence") + ) { + $self->SetHeader( 'Precedence', $precedence ); + } + + $self->SetHeader( 'X-RT-Loop-Prevention', RT->Config->Get('rtname') ); + $self->SetHeader( 'RT-Ticket', + RT->Config->Get('rtname') . " #" . $self->TicketObj->id() ); + $self->SetHeader( 'Managed-by', + "RT $RT::VERSION (http://www.bestpractical.com/rt/)" ); + +# XXX, TODO: use /ShowUser/ShowUserEntry(or something like that) when it would be +# refactored into user's method. + if ( my $email = $self->TransactionObj->CreatorObj->EmailAddress + and RT->Config->Get('UseOriginatorHeader') + ) { + $self->SetHeader( 'RT-Originator', $email ); + } + +} + + +sub DeferDigestRecipients { + my $self = shift; + $RT::Logger->debug( "Calling SetRecipientDigests for transaction " . $self->TransactionObj . ", id " . $self->TransactionObj->id ); + + # The digest attribute will be an array of notifications that need to + # be sent for this transaction. The array will have the following + # format for its objects. + # $digest_hash -> {daily|weekly|susp} -> address -> {To|Cc|Bcc} + # -> sent -> {true|false} + # The "sent" flag will be used by the cron job to indicate that it has + # run on this transaction. + # In a perfect world we might move this hash construction to the + # extension module itself. + my $digest_hash = {}; + + foreach my $mailfield (@EMAIL_RECIPIENT_HEADERS) { + # If we have a "PseudoTo", the "To" contains it, so we don't need to access it + next if ( ( $self->{'PseudoTo'} && @{ $self->{'PseudoTo'} } ) && ( $mailfield eq 'To' ) ); + $RT::Logger->debug( "Working on mailfield $mailfield; recipients are " . join( ',', @{ $self->{$mailfield} } ) ); + + # Store the 'daily digest' folk in an array. + my ( @send_now, @daily_digest, @weekly_digest, @suspended ); + + # Have to get the list of addresses directly from the MIME header + # at this point. + $RT::Logger->debug( $self->TemplateObj->MIMEObj->head->as_string ); + foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) { + next unless $rcpt; + my $user_obj = RT::User->new(RT->SystemUser); + $user_obj->LoadByEmail($rcpt); + if ( ! $user_obj->id ) { + # If there's an email address in here without an associated + # RT user, pass it on through. + $RT::Logger->debug( "User $rcpt is not associated with an RT user object. Send mail."); + push( @send_now, $rcpt ); + next; + } + + my $mailpref = RT->Config->Get( 'EmailFrequency', $user_obj ) || ''; + $RT::Logger->debug( "Got user mail preference '$mailpref' for user $rcpt"); + + if ( $mailpref =~ /daily/i ) { push( @daily_digest, $rcpt ) } + elsif ( $mailpref =~ /weekly/i ) { push( @weekly_digest, $rcpt ) } + elsif ( $mailpref =~ /suspend/i ) { push( @suspended, $rcpt ) } + else { push( @send_now, $rcpt ) } + } + + # Reset the relevant mail field. + $RT::Logger->debug( "Removing deferred recipients from $mailfield: line"); + if (@send_now) { + $self->SetHeader( $mailfield, join( ', ', @send_now ) ); + } else { # No recipients! Remove the header. + $self->TemplateObj->MIMEObj->head->delete($mailfield); + } + + # Push the deferred addresses into the appropriate field in + # our attribute hash, with the appropriate mail header. + $RT::Logger->debug( + "Setting deferred recipients for attribute creation"); + $digest_hash->{'daily'}->{$_} = {'header' => $mailfield , _sent => 0} for (@daily_digest); + $digest_hash->{'weekly'}->{$_} ={'header' => $mailfield, _sent => 0} for (@weekly_digest); + $digest_hash->{'susp'}->{$_} = {'header' => $mailfield, _sent =>0 } for (@suspended); + } + + if ( scalar keys %$digest_hash ) { + + # Save the hash so that we can add it as an attribute to the + # outgoing email transaction. + $self->{'Deferred'} = $digest_hash; + } else { + $RT::Logger->debug( "No recipients found for deferred delivery on " + . "transaction #" + . $self->TransactionObj->id ); + } +} + + + +sub RecordDeferredRecipients { + my $self = shift; + return unless exists $self->{'Deferred'}; + + my $txn_id = $self->{'OutgoingMailTransaction'}; + return unless $txn_id; + + my $txn_obj = RT::Transaction->new( $self->CurrentUser ); + $txn_obj->Load( $txn_id ); + my( $ret, $msg ) = $txn_obj->AddAttribute( + Name => 'DeferredRecipients', + Content => $self->{'Deferred'} + ); + $RT::Logger->warning( "Unable to add deferred recipients to outgoing transaction: $msg" ) + unless $ret; + + return ($ret,$msg); +} + +=head2 SquelchMailTo + +Returns list of the addresses to squelch on this transaction. + +=cut + +sub SquelchMailTo { + my $self = shift; + return map $_->Content, $self->TransactionObj->SquelchMailTo; +} + +=head2 RemoveInappropriateRecipients + +Remove addresses that are RT addresses or that are on this transaction's blacklist + +=cut + +sub RemoveInappropriateRecipients { + my $self = shift; + + my @blacklist = (); + + # If there are no recipients, don't try to send the message. + # If the transaction has content and has the header RT-Squelch-Replies-To + + my $msgid = $self->TemplateObj->MIMEObj->head->get('Message-Id'); + if ( my $attachment = $self->TransactionObj->Attachments->First ) { + + if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) { + + # What do we want to do with this? It's probably (?) a bounce + # caused by one of the watcher addresses being broken. + # Default ("true") is to redistribute, for historical reasons. + + if ( !RT->Config->Get('RedistributeAutoGeneratedMessages') ) { + + # Don't send to any watchers. + @{ $self->{$_} } = () for (@EMAIL_RECIPIENT_HEADERS); + $RT::Logger->info( $msgid + . " The incoming message was autogenerated. " + . "Not redistributing this message based on site configuration." + ); + } elsif ( RT->Config->Get('RedistributeAutoGeneratedMessages') eq + 'privileged' ) + { + + # Only send to "privileged" watchers. + foreach my $type (@EMAIL_RECIPIENT_HEADERS) { + foreach my $addr ( @{ $self->{$type} } ) { + my $user = RT::User->new(RT->SystemUser); + $user->LoadByEmail($addr); + push @blacklist, $addr unless $user->id && $user->Privileged; + } + } + $RT::Logger->info( $msgid + . " The incoming message was autogenerated. " + . "Not redistributing this message to unprivileged users based on site configuration." + ); + } + } + + if ( my $squelch = $attachment->GetHeader('RT-Squelch-Replies-To') ) { + push @blacklist, split( /,/, $squelch ); + } + } + + # Let's grab the SquelchMailTo attributes and push those entries into the @blacklisted + push @blacklist, map $_->Content, $self->TicketObj->SquelchMailTo, $self->TransactionObj->SquelchMailTo; + + # Cycle through the people we're sending to and pull out anyone on the + # system blacklist + + # Trim leading and trailing spaces. + @blacklist = map { RT::User->CanonicalizeEmailAddress( $_->address ) } + Email::Address->parse( join ', ', grep defined, @blacklist ); + + foreach my $type (@EMAIL_RECIPIENT_HEADERS) { + my @addrs; + foreach my $addr ( @{ $self->{$type} } ) { + + # Weed out any RT addresses. We really don't want to talk to ourselves! + # If we get a reply back, that means it's not an RT address + if ( !RT::EmailParser->CullRTAddresses($addr) ) { + $RT::Logger->info( $msgid . "$addr appears to point to this RT instance. Skipping" ); + next; + } + if ( grep $addr eq $_, @blacklist ) { + $RT::Logger->info( $msgid . "$addr was blacklisted for outbound mail on this transaction. Skipping"); + next; + } + push @addrs, $addr; + } + foreach my $addr ( @{ $self->{'NoSquelch'}{$type} || [] } ) { + # never send email to itself + if ( !RT::EmailParser->CullRTAddresses($addr) ) { + $RT::Logger->info( $msgid . "$addr appears to point to this RT instance. Skipping" ); + next; + } + push @addrs, $addr; + } + @{ $self->{$type} } = @addrs; + } +} + +=head2 SetReturnAddress is_comment => BOOLEAN + +Calculate and set From and Reply-To headers based on the is_comment flag. + +=cut + +sub SetReturnAddress { + + my $self = shift; + my %args = ( + is_comment => 0, + friendly_name => undef, + @_ + ); + + # From and Reply-To + # $args{is_comment} should be set if the comment address is to be used. + my $replyto; + + if ( $args{'is_comment'} ) { + $replyto = $self->TicketObj->QueueObj->CommentAddress + || RT->Config->Get('CommentAddress'); + } else { + $replyto = $self->TicketObj->QueueObj->CorrespondAddress + || RT->Config->Get('CorrespondAddress'); + } + + unless ( $self->TemplateObj->MIMEObj->head->get('From') ) { + $self->SetFrom( %args, From => $replyto ); + } + + unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) { + $self->SetHeader( 'Reply-To', "$replyto" ); + } + +} + +=head2 SetFrom ( From => emailaddress ) + +Set the From: address for outgoing email + +=cut + +sub SetFrom { + my $self = shift; + my %args = @_; + + my $from = $args{From}; + + if ( RT->Config->Get('UseFriendlyFromLine') ) { + my $friendly_name = $self->GetFriendlyName(%args); + $from = + sprintf( + RT->Config->Get('FriendlyFromLineFormat'), + $self->MIMEEncodeString( + $friendly_name, RT->Config->Get('EmailOutputEncoding') + ), + $args{From} + ); + } + + $self->SetHeader( 'From', $from ); + + #also set Sender:, otherwise MTAs add a nonsensical value like rt@machine, + #and then Outlook prepends "rt@machine on behalf of" to the From: header + $self->SetHeader( 'Sender', $from ); +} + +=head2 GetFriendlyName + +Calculate the proper Friendly Name based on the creator of the transaction + +=cut + +sub GetFriendlyName { + my $self = shift; + my %args = ( + is_comment => 0, + friendly_name => '', + @_ + ); + my $friendly_name = $args{friendly_name}; + + unless ( $friendly_name ) { + $friendly_name = $self->TransactionObj->CreatorObj->FriendlyName; + if ( $friendly_name =~ /^"(.*)"$/ ) { # a quoted string + $friendly_name = $1; + } + } + + $friendly_name =~ s/"/\\"/g; + return $friendly_name; + +} + +=head2 SetHeader FIELD, VALUE + +Set the FIELD of the current MIME object into VALUE. + +=cut + +sub SetHeader { + my $self = shift; + my $field = shift; + my $val = shift; + + chomp $val; + chomp $field; + my $head = $self->TemplateObj->MIMEObj->head; + $head->fold_length( $field, 10000 ); + $head->replace( $field, $val ); + return $head->get($field); +} + +=head2 SetSubject + +This routine sets the subject. it does not add the rt tag. That gets done elsewhere +If subject is already defined via template, it uses that. otherwise, it tries to get +the transaction's subject. + +=cut + +sub SetSubject { + my $self = shift; + my $subject; + + if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) { + return (); + } + + # don't use Transaction->Attachments because it caches + # and anything which later calls ->Attachments will be hurt + # by our RowsPerPage() call. caching is hard. + my $message = RT::Attachments->new( $self->CurrentUser ); + $message->Limit( FIELD => 'TransactionId', VALUE => $self->TransactionObj->id); + $message->OrderBy( FIELD => 'id', ORDER => 'ASC' ); + $message->RowsPerPage(1); + + if ( $self->{'Subject'} ) { + $subject = $self->{'Subject'}; + } elsif ( my $first = $message->First ) { + my $tmp = $first->GetHeader('Subject'); + $subject = defined $tmp ? $tmp : $self->TicketObj->Subject; + } else { + $subject = $self->TicketObj->Subject; + } + $subject = '' unless defined $subject; + chomp $subject; + + $subject =~ s/(\r\n|\n|\s)/ /g; + + $self->SetHeader( 'Subject', Encode::encode_utf8( $subject ) ); + +} + +=head2 SetSubjectToken + +This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this. + +=cut + +sub SetSubjectToken { + my $self = shift; + + my $head = $self->TemplateObj->MIMEObj->head; + $self->SetHeader( + Subject => + Encode::encode_utf8( + RT::Interface::Email::AddSubjectTag( + Encode::decode_utf8( $head->get('Subject') ), + $self->TicketObj, + ), + ), + ); +} + +=head2 SetReferencesHeaders + +Set References and In-Reply-To headers for this message. + +=cut + +sub SetReferencesHeaders { + my $self = shift; + + my $top = $self->TransactionObj->Message->First; + unless ( $top ) { + $self->SetHeader( References => $self->PseudoReference ); + return (undef); + } + + my @in_reply_to = split( /\s+/m, $top->GetHeader('In-Reply-To') || '' ); + my @references = split( /\s+/m, $top->GetHeader('References') || '' ); + my @msgid = split( /\s+/m, $top->GetHeader('Message-ID') || '' ); + + # There are two main cases -- this transaction was created with + # the RT Web UI, and hence we want to *not* append its Message-ID + # to the References and In-Reply-To. OR it came from an outside + # source, and we should treat it as per the RFC + my $org = RT->Config->Get('Organization'); + if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+)-0-0\@\Q$org\E>/ ) { + + # Make all references which are internal be to version which we + # have sent out + + for ( @references, @in_reply_to ) { + s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>$/ + "<$1." . $self->TicketObj->id . + "-" . $self->ScripObj->id . + "-" . $self->ScripActionObj->{_Message_ID} . + "@" . $org . ">"/eg + } + + # In reply to whatever the internal message was in reply to + $self->SetHeader( 'In-Reply-To', join( " ", (@in_reply_to) ) ); + + # Default the references to whatever we're in reply to + @references = @in_reply_to unless @references; + + # References are unchanged from internal + } else { + + # In reply to that message + $self->SetHeader( 'In-Reply-To', join( " ", (@msgid) ) ); + + # Default the references to whatever we're in reply to + @references = @in_reply_to unless @references; + + # Push that message onto the end of the references + push @references, @msgid; + } + + # Push pseudo-ref to the front + my $pseudo_ref = $self->PseudoReference; + @references = ( $pseudo_ref, grep { $_ ne $pseudo_ref } @references ); + + # If there are more than 10 references headers, remove all but the + # first four and the last six (Gotta keep this from growing + # forever) + splice( @references, 4, -6 ) if ( $#references >= 10 ); + + # Add on the references + $self->SetHeader( 'References', join( " ", @references ) ); + $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 ); + +} + +=head2 PseudoReference + +Returns a fake Message-ID: header for the ticket to allow a base level of threading + +=cut + +sub PseudoReference { + + my $self = shift; + my $pseudo_ref + = '<RT-Ticket-' + . $self->TicketObj->id . '@' + . RT->Config->Get('Organization') . '>'; + return $pseudo_ref; +} + +=head2 SetHeaderAsEncoding($field_name, $charset_encoding) + +This routine converts the field into specified charset encoding. + +=cut + +sub SetHeaderAsEncoding { + my $self = shift; + my ( $field, $enc ) = ( shift, shift ); + + my $head = $self->TemplateObj->MIMEObj->head; + + if ( lc($field) eq 'from' and RT->Config->Get('SMTPFrom') ) { + $head->replace( $field, RT->Config->Get('SMTPFrom') ); + return; + } + + my $value = $head->get( $field ); + $value = $self->MIMEEncodeString( $value, $enc ); + $head->replace( $field, $value ); + +} + +=head2 MIMEEncodeString + +Takes a perl string and optional encoding pass it over +L<RT::Interface::Email/EncodeToMIME>. + +Basicly encode a string using B encoding according to RFC2047. + +=cut + +sub MIMEEncodeString { + my $self = shift; + return RT::Interface::Email::EncodeToMIME( String => $_[0], Charset => $_[1] ); +} + +RT::Base->_ImportOverlays(); + +1; + diff --git a/rt/lib/RT/Attachment.pm b/rt/lib/RT/Attachment.pm index 07fdea3b2..af1f82c15 100755 --- a/rt/lib/RT/Attachment.pm +++ b/rt/lib/RT/Attachment.pm @@ -128,19 +128,17 @@ sub Create { $Attachment->make_singlepart; # Get the subject - my $Subject = $Attachment->head->get( 'subject', 0 ); + my $Subject = Encode::decode( 'UTF-8', $Attachment->head->get( 'subject' ) ); $Subject = '' unless defined $Subject; chomp $Subject; - utf8::decode( $Subject ) unless utf8::is_utf8( $Subject ); #Get the Message-ID - my $MessageId = $Attachment->head->get( 'Message-ID', 0 ); + my $MessageId = Encode::decode( "UTF-8", $Attachment->head->get( 'Message-ID' ) ); defined($MessageId) or $MessageId = ''; chomp ($MessageId); $MessageId =~ s/^<(.*?)>$/$1/o; #Get the filename - my $Filename = mime_recommended_filename($Attachment); # remove path part. @@ -148,8 +146,7 @@ sub Create { # MIME::Head doesn't support perl strings well and can return # octets which later will be double encoded in low-level code - my $head = $Attachment->head->as_string; - utf8::decode( $head ) unless utf8::is_utf8( $head ); + my $head = Encode::decode( 'UTF-8', $Attachment->head->as_string ); # If a message has no bodyhandle, that means that it has subparts (or appears to) # and we should act accordingly. @@ -289,7 +286,7 @@ before returning it. sub Content { my $self = shift; return $self->_DecodeLOB( - $self->ContentType, + $self->GetHeader('Content-Type'), # Includes charset, unlike ->ContentType $self->ContentEncoding, $self->_Value('Content', decode_utf8 => 0), ); @@ -320,7 +317,6 @@ sub OriginalContent { } return $self->Content unless RT::I18N::IsTextualContentType($self->ContentType); - my $enc = $self->OriginalEncoding; my $content; if ( !$self->ContentEncoding || $self->ContentEncoding eq 'none' ) { @@ -333,18 +329,20 @@ sub OriginalContent { return( $self->loc("Unknown ContentEncoding [_1]", $self->ContentEncoding)); } - # Turn *off* the SvUTF8 bits here so decode_utf8 and from_to below can work. - local $@; - Encode::_utf8_off($content); + my $entity = MIME::Entity->new(); + $entity->head->add("Content-Type", $self->GetHeader("Content-Type")); + $entity->bodyhandle( MIME::Body::Scalar->new( $content ) ); + my $from = RT::I18N::_FindOrGuessCharset($entity); + $from = 'utf-8' if not $from or not Encode::find_encoding($from); - if (!$enc || $enc eq '' || $enc eq 'utf8' || $enc eq 'utf-8') { - # If we somehow fail to do the decode, at least push out the raw bits - eval { return( Encode::decode_utf8($content)) } || return ($content); - } + my $to = RT::I18N::_CanonicalizeCharset( + $self->OriginalEncoding || 'utf-8' + ); - eval { Encode::from_to($content, 'utf8' => $enc) } if $enc; + local $@; + eval { Encode::from_to($content, $from => $to) }; if ($@) { - $RT::Logger->error("Could not convert attachment from assumed utf8 to '$enc' :".$@); + $RT::Logger->error("Could not convert attachment from $from to $to: ".$@); } return $content; } diff --git a/rt/lib/RT/Config.pm b/rt/lib/RT/Config.pm index 62aae1c35..b97802f7a 100644 --- a/rt/lib/RT/Config.pm +++ b/rt/lib/RT/Config.pm @@ -1024,7 +1024,6 @@ sub Get { my $res; if ( $user && $user->id && $META{$name}->{'Overridable'} ) { - $user = $user->UserObj if $user->isa('RT::CurrentUser'); my $prefs = $user->Preferences($RT::System); $res = $prefs->{$name} if $prefs; } diff --git a/rt/lib/RT/Config.pm.orig b/rt/lib/RT/Config.pm.orig new file mode 100644 index 000000000..62aae1c35 --- /dev/null +++ b/rt/lib/RT/Config.pm.orig @@ -0,0 +1,1382 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +package RT::Config; + +use strict; +use warnings; + + +use File::Spec (); + +=head1 NAME + + RT::Config - RT's config + +=head1 SYNOPSYS + + # get config object + use RT::Config; + my $config = RT::Config->new; + $config->LoadConfigs; + + # get or set option + my $rt_web_path = $config->Get('WebPath'); + $config->Set(EmailOutputEncoding => 'latin1'); + + # get config object from RT package + use RT; + RT->LoadConfig; + my $config = RT->Config; + +=head1 DESCRIPTION + +C<RT::Config> class provide access to RT's and RT extensions' config files. + +RT uses two files for site configuring: + +First file is F<RT_Config.pm> - core config file. This file is shipped +with RT distribution and contains default values for all available options. +B<You should never edit this file.> + +Second file is F<RT_SiteConfig.pm> - site config file. You can use it +to customize your RT instance. In this file you can override any option +listed in core config file. + +RT extensions could also provide thier config files. Extensions should +use F<< <NAME>_Config.pm >> and F<< <NAME>_SiteConfig.pm >> names for +config files, where <NAME> is extension name. + +B<NOTE>: All options from RT's config and extensions' configs are saved +in one place and thus extension could override RT's options, but it is not +recommended. + +=cut + +=head2 %META + +Hash of Config options that may be user overridable +or may require more logic than should live in RT_*Config.pm + +Keyed by config name, there are several properties that +can be set for each config optin: + + Section - What header this option should be grouped + under on the user Settings page + Overridable - Can users change this option + SortOrder - Within a Section, how should the options be sorted + for display to the user + Widget - Mason component path to widget that should be used + to display this config option + WidgetArguments - An argument hash passed to the WIdget + Description - Friendly description to show the user + Values - Arrayref of options (for select Widget) + ValuesLabel - Hashref, key is the Value from the Values + list, value is a user friendly description + of the value + Callback - subref that receives no arguments. It returns + a hashref of items that are added to the rest + of the WidgetArguments + PostLoadCheck - subref passed the RT::Config object and the current + setting of the config option. Can make further checks + (such as seeing if a library is installed) and then change + the setting of this or other options in the Config using + the RT::Config option. + Obfuscate - subref passed the RT::Config object, current setting of the config option + and a user object, can return obfuscated value. it's called in + RT->Config->GetObfuscated() + +=cut + +our %META = ( + # General user overridable options + DefaultQueue => { + Section => 'General', + Overridable => 1, + SortOrder => 1, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Default queue', #loc + Callback => sub { + my $ret = { Values => [], ValuesLabel => {}}; + my $q = RT::Queues->new($HTML::Mason::Commands::session{'CurrentUser'}); + $q->UnLimit; + while (my $queue = $q->Next) { + next unless $queue->CurrentUserHasRight("CreateTicket"); + push @{$ret->{Values}}, $queue->Id; + $ret->{ValuesLabel}{$queue->Id} = $queue->Name; + } + return $ret; + }, + } + }, + RememberDefaultQueue => { + Section => 'General', + Overridable => 1, + SortOrder => 2, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Remember default queue' # loc + } + }, + UsernameFormat => { + Section => 'General', + Overridable => 1, + SortOrder => 3, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Username format', # loc + Values => [qw(concise verbose)], + ValuesLabel => { + concise => 'Short usernames', # loc + verbose => 'Name and email address', # loc + }, + }, + }, + AutocompleteOwners => { + Section => 'General', + Overridable => 1, + SortOrder => 3.1, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Use autocomplete to find owners?', # loc + Hints => 'Replaces the owner dropdowns with textboxes' #loc + } + }, + WebDefaultStylesheet => { + Section => 'General', #loc + Overridable => 1, + SortOrder => 4, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Theme', #loc + # XXX: we need support for 'get values callback' + Values => [qw(web2 freeside2.1 freeside3 aileron ballard)], + }, + PostLoadCheck => sub { + my $self = shift; + my $value = $self->Get('WebDefaultStylesheet'); + + my @comp_roots = RT::Interface::Web->ComponentRoots; + for my $comp_root (@comp_roots) { + return if -d $comp_root.'/NoAuth/css/'.$value; + } + + $RT::Logger->warning( + "The default stylesheet ($value) does not exist in this instance of RT. " + . "Defaulting to freeside3." + ); + + #$self->Set('WebDefaultStylesheet', 'aileron'); + $self->Set('WebDefaultStylesheet', 'freeside3'); + }, + }, + UseSideBySideLayout => { + Section => 'Ticket composition', + Overridable => 1, + SortOrder => 5, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Use a two column layout for create and update forms?' # loc + } + }, + MessageBoxRichText => { + Section => 'Ticket composition', + Overridable => 1, + SortOrder => 5.1, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'WYSIWYG message composer' # loc + } + }, + MessageBoxRichTextHeight => { + Section => 'Ticket composition', + Overridable => 1, + SortOrder => 6, + Widget => '/Widgets/Form/Integer', + WidgetArguments => { + Description => 'WYSIWYG composer height', # loc + } + }, + MessageBoxWidth => { + Section => 'Ticket composition', + Overridable => 1, + SortOrder => 7, + Widget => '/Widgets/Form/Integer', + WidgetArguments => { + Description => 'Message box width', #loc + }, + }, + MessageBoxHeight => { + Section => 'Ticket composition', + Overridable => 1, + SortOrder => 8, + Widget => '/Widgets/Form/Integer', + WidgetArguments => { + Description => 'Message box height', #loc + }, + }, + MessageBoxWrap => { + Section => 'Ticket composition', #loc + Overridable => 1, + SortOrder => 8.1, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Message box wrapping', #loc + Values => [qw(SOFT HARD)], + Hints => "When the WYSIWYG editor is not enabled, this setting determines whether automatic line wraps in the ticket message box are sent to RT or not.", # loc + }, + }, + DefaultTimeUnitsToHours => { + Section => 'Ticket composition', #loc + Overridable => 1, + SortOrder => 9, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Enter time in hours by default', #loc + Hints => 'Only for entry, not display', #loc + }, + }, + SearchResultsRefreshInterval => { + Section => 'General', #loc + Overridable => 1, + SortOrder => 9, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Search results refresh interval', #loc + Values => [qw(0 120 300 600 1200 3600 7200)], + ValuesLabel => { + 0 => "Don't refresh search results.", #loc + 120 => "Refresh search results every 2 minutes.", #loc + 300 => "Refresh search results every 5 minutes.", #loc + 600 => "Refresh search results every 10 minutes.", #loc + 1200 => "Refresh search results every 20 minutes.", #loc + 3600 => "Refresh search results every 60 minutes.", #loc + 7200 => "Refresh search results every 120 minutes.", #loc + }, + }, + }, + + # User overridable options for RT at a glance + HomePageRefreshInterval => { + Section => 'RT at a glance', #loc + Overridable => 1, + SortOrder => 2, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Home page refresh interval', #loc + Values => [qw(0 120 300 600 1200 3600 7200)], + ValuesLabel => { + 0 => "Don't refresh home page.", #loc + 120 => "Refresh home page every 2 minutes.", #loc + 300 => "Refresh home page every 5 minutes.", #loc + 600 => "Refresh home page every 10 minutes.", #loc + 1200 => "Refresh home page every 20 minutes.", #loc + 3600 => "Refresh home page every 60 minutes.", #loc + 7200 => "Refresh home page every 120 minutes.", #loc + }, + }, + }, + + # User overridable options for Ticket displays + MaxInlineBody => { + Section => 'Ticket display', #loc + Overridable => 1, + SortOrder => 1, + Widget => '/Widgets/Form/Integer', + WidgetArguments => { + Description => 'Maximum inline message length', #loc + Hints => + "Length in characters; Use '0' to show all messages inline, regardless of length" #loc + }, + }, + OldestTransactionsFirst => { + Section => 'Ticket display', + Overridable => 1, + SortOrder => 2, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Show oldest history first', #loc + }, + }, + DeferTransactionLoading => { + Section => 'Ticket display', + Overridable => 1, + SortOrder => 3, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Hide ticket history by default', #loc + }, + }, + ShowUnreadMessageNotifications => { + Section => 'Ticket display', + Overridable => 1, + SortOrder => 4, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Notify me of unread messages', #loc + }, + + }, + PlainTextPre => { + Section => 'Ticket display', + Overridable => 1, + SortOrder => 5, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'add <pre> tag around plain text attachments', #loc + Hints => "Use this to protect the format of plain text" #loc + }, + }, + PlainTextMono => { + Section => 'Ticket display', + Overridable => 1, + SortOrder => 5, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'display wrapped and formatted plain text attachments', #loc + Hints => 'Use css rules to display text monospaced and with formatting preserved, but wrap as needed. This does not work well with IE6 and you should use the previous option', #loc + }, + }, + DisplayAfterQuickCreate => { + Section => 'Ticket display', + Overridable => 1, + SortOrder => 6, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'On Quick Create, redirect to ticket display', #loc + #Hints => '', #loc + }, + }, + MoreAboutRequestorTicketList => { + Section => 'Ticket display', #loc + Overridable => 1, + SortOrder => 6, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => q|What tickets to display in the 'More about requestor' box|, #loc + Values => [qw(Active Inactive All None)], + ValuesLabel => { + Active => "Show the Requestor's 10 highest priority active tickets", #loc + Inactive => "Show the Requestor's 10 highest priority inactive tickets", #loc + All => "Show the Requestor's 10 highest priority tickets", #loc + None => "Show no tickets for the Requestor", #loc + }, + }, + }, + SimplifiedRecipients => { + Section => 'Ticket display', #loc + Overridable => 1, + SortOrder => 7, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => q|Show simplified recipient list on ticket update|, #loc + }, + }, + DisplayTicketAfterQuickCreate => { + Section => 'Ticket display', + Overridable => 1, + SortOrder => 8, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => q{Display ticket after "Quick Create"}, #loc + }, + }, + + # User overridable locale options + DateTimeFormat => { + Section => 'Locale', #loc + Overridable => 1, + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Date format', #loc + Callback => sub { my $ret = { Values => [], ValuesLabel => {}}; + my $date = RT::Date->new($HTML::Mason::Commands::session{'CurrentUser'}); + $date->SetToNow; + foreach my $value ($date->Formatters) { + push @{$ret->{Values}}, $value; + $ret->{ValuesLabel}{$value} = $date->Get( + Format => $value, + Timezone => 'user', + ); + } + return $ret; + }, + }, + }, + + RTAddressRegexp => { + Type => 'SCALAR', + PostLoadCheck => sub { + my $self = shift; + my $value = $self->Get('RTAddressRegexp'); + if (not $value) { + $RT::Logger->debug( + 'The RTAddressRegexp option is not set in the config.' + .' Not setting this option results in additional SQL queries to' + .' check whether each address belongs to RT or not.' + .' It is especially important to set this option if RT recieves' + .' emails on addresses that are not in the database or config.' + ); + } elsif (ref $value and ref $value eq "Regexp") { + # Ensure that the regex is case-insensitive; while the + # local part of email addresses is _technically_ + # case-sensitive, most MTAs don't treat it as such. + $RT::Logger->warning( + 'RTAddressRegexp is set to a case-sensitive regular expression.' + .' This may lead to mail loops with MTAs which treat the' + .' local part as case-insensitive -- which is most of them.' + ) if "$value" =~ /^\(\?[a-z]*-([a-z]*):/ and "$1" =~ /i/; + } + }, + }, + # User overridable mail options + EmailFrequency => { + Section => 'Mail', #loc + Overridable => 1, + Default => 'Individual messages', + Widget => '/Widgets/Form/Select', + WidgetArguments => { + Description => 'Email delivery', #loc + Values => [ + 'Individual messages', #loc + 'Daily digest', #loc + 'Weekly digest', #loc + 'Suspended' #loc + ] + } + }, + NotifyActor => { + Section => 'Mail', #loc + Overridable => 1, + SortOrder => 2, + Widget => '/Widgets/Form/Boolean', + WidgetArguments => { + Description => 'Outgoing mail', #loc + Hints => 'Should RT send you mail for ticket updates you make?', #loc + } + }, + + # this tends to break extensions that stash links in ticket update pages + Organization => { + Type => 'SCALAR', + PostLoadCheck => sub { + my ($self,$value) = @_; + $RT::Logger->error("your \$Organization setting ($value) appears to contain whitespace. Please fix this.") + if $value =~ /\s/;; + }, + }, + + # Internal config options + FullTextSearch => { + Type => 'HASH', + PostLoadCheck => sub { + my $self = shift; + my $v = $self->Get('FullTextSearch'); + return unless $v->{Enable} and $v->{Indexed}; + my $dbtype = $self->Get('DatabaseType'); + if ($dbtype eq 'Oracle') { + if (not $v->{IndexName}) { + $RT::Logger->error("No IndexName set for full-text index; disabling"); + $v->{Enable} = $v->{Indexed} = 0; + } + } elsif ($dbtype eq 'Pg') { + my $bad = 0; + if (not $v->{'Column'}) { + $RT::Logger->error("No Column set for full-text index; disabling"); + $v->{Enable} = $v->{Indexed} = 0; + } elsif ($v->{'Column'} eq "Content" + and (not $v->{'Table'} or $v->{'Table'} eq "Attachments")) { + $RT::Logger->error("Column for full-text index is set to Content, not tsvector column; disabling"); + $v->{Enable} = $v->{Indexed} = 0; + } + } elsif ($dbtype eq 'mysql') { + if (not $v->{'Table'}) { + $RT::Logger->error("No Table set for full-text index; disabling"); + $v->{Enable} = $v->{Indexed} = 0; + } elsif ($v->{'Table'} eq "Attachments") { + $RT::Logger->error("Table for full-text index is set to Attachments, not SphinxSE table; disabling"); + $v->{Enable} = $v->{Indexed} = 0; + } elsif (not $v->{'MaxMatches'}) { + $RT::Logger->warn("No MaxMatches set for full-text index; defaulting to 10000"); + $v->{MaxMatches} = 10_000; + } + } else { + $RT::Logger->error("Indexed full-text-search not supported for $dbtype"); + $v->{Indexed} = 0; + } + }, + }, + DisableGraphViz => { + Type => 'SCALAR', + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + return if $value; + return if $INC{'GraphViz.pm'}; + local $@; + return if eval {require GraphViz; 1}; + $RT::Logger->debug("You've enabled GraphViz, but we couldn't load the module: $@"); + $self->Set( DisableGraphViz => 1 ); + }, + }, + DisableGD => { + Type => 'SCALAR', + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + return if $value; + return if $INC{'GD.pm'}; + local $@; + return if eval {require GD; 1}; + $RT::Logger->debug("You've enabled GD, but we couldn't load the module: $@"); + $self->Set( DisableGD => 1 ); + }, + }, + MailPlugins => { Type => 'ARRAY' }, + Plugins => { + Type => 'ARRAY', + PostLoadCheck => sub { + my $self = shift; + my $value = $self->Get('Plugins'); + # XXX Remove in RT 4.2 + return unless $value and grep {$_ eq "RT::FM"} @{$value}; + warn 'RTFM has been integrated into core RT, and must be removed from your @Plugins'; + }, + }, + GnuPG => { Type => 'HASH' }, + GnuPGOptions => { Type => 'HASH', + PostLoadCheck => sub { + my $self = shift; + my $gpg = $self->Get('GnuPG'); + return unless $gpg->{'Enable'}; + my $gpgopts = $self->Get('GnuPGOptions'); + unless (-d $gpgopts->{homedir} && -r _ ) { # no homedir, no gpg + $RT::Logger->debug( + "RT's GnuPG libraries couldn't successfully read your". + " configured GnuPG home directory (".$gpgopts->{homedir} + ."). PGP support has been disabled"); + $gpg->{'Enable'} = 0; + return; + } + + + require RT::Crypt::GnuPG; + unless (RT::Crypt::GnuPG->Probe()) { + $RT::Logger->debug( + "RT's GnuPG libraries couldn't successfully execute gpg.". + " PGP support has been disabled"); + $gpg->{'Enable'} = 0; + } + } + }, + ReferrerWhitelist => { Type => 'ARRAY' }, + ResolveDefaultUpdateType => { + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + return unless $value; + $RT::Logger->info('The ResolveDefaultUpdateType config option has been deprecated. '. + 'You can change the site default in your %Lifecycles config.'); + } + }, + WebPath => { + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + + # "In most cases, you should leave $WebPath set to '' (an empty value)." + return unless $value; + + # try to catch someone who assumes that you shouldn't leave this empty + if ($value eq '/') { + $RT::Logger->error("For the WebPath config option, use the empty string instead of /"); + return; + } + + # $WebPath requires a leading / but no trailing /, or it can be blank. + return if $value =~ m{^/.+[^/]$}; + + if ($value =~ m{/$}) { + $RT::Logger->error("The WebPath config option requires no trailing slash"); + } + + if ($value !~ m{^/}) { + $RT::Logger->error("The WebPath config option requires a leading slash"); + } + }, + }, + WebDomain => { + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + + if (!$value) { + $RT::Logger->error("You must set the WebDomain config option"); + return; + } + + if ($value =~ m{^(\w+://)}) { + $RT::Logger->error("The WebDomain config option must not contain a scheme ($1)"); + return; + } + + if ($value =~ m{(/.*)}) { + $RT::Logger->error("The WebDomain config option must not contain a path ($1)"); + return; + } + + if ($value =~ m{:(\d*)}) { + $RT::Logger->error("The WebDomain config option must not contain a port ($1)"); + return; + } + }, + }, + WebPort => { + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + + if (!$value) { + $RT::Logger->error("You must set the WebPort config option"); + return; + } + + if ($value !~ m{^\d+$}) { + $RT::Logger->error("The WebPort config option must be an integer"); + } + }, + }, + WebBaseURL => { + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + + if (!$value) { + $RT::Logger->error("You must set the WebBaseURL config option"); + return; + } + + if ($value !~ m{^https?://}i) { + $RT::Logger->error("The WebBaseURL config option must contain a scheme (http or https)"); + } + + if ($value =~ m{/$}) { + $RT::Logger->error("The WebBaseURL config option requires no trailing slash"); + } + + if ($value =~ m{^https?://.+?(/[^/].*)}i) { + $RT::Logger->error("The WebBaseURL config option must not contain a path ($1)"); + } + }, + }, + WebURL => { + PostLoadCheck => sub { + my $self = shift; + my $value = shift; + + if (!$value) { + $RT::Logger->error("You must set the WebURL config option"); + return; + } + + if ($value !~ m{^https?://}i) { + $RT::Logger->error("The WebURL config option must contain a scheme (http or https)"); + } + + if ($value !~ m{/$}) { + $RT::Logger->error("The WebURL config option requires a trailing slash"); + } + }, + }, + EmailInputEncodings => { + Type => 'ARRAY', + PostLoadCheck => sub { + my $self = shift; + my $value = $self->Get('EmailInputEncodings'); + return unless $value && @$value; + + my %seen; + foreach my $encoding ( grep defined && length, splice @$value ) { + next if $seen{ $encoding }; + if ( $encoding eq '*' ) { + unshift @$value, '*'; + next; + } + + my $canonic = Encode::resolve_alias( $encoding ); + unless ( $canonic ) { + warn "Unknown encoding '$encoding' in \@EmailInputEncodings option"; + } + elsif ( $seen{ $canonic }++ ) { + next; + } + else { + push @$value, $canonic; + } + } + }, + }, + + ActiveStatus => { + Type => 'ARRAY', + PostLoadCheck => sub { + my $self = shift; + return unless shift; + # XXX Remove in RT 4.2 + warn <<EOT; +The ActiveStatus configuration has been replaced by the new Lifecycles +functionality. You should set the 'active' property of the 'default' +lifecycle and add transition rules; see RT_Config.pm for documentation. +EOT + }, + }, + InactiveStatus => { + Type => 'ARRAY', + PostLoadCheck => sub { + my $self = shift; + return unless shift; + # XXX Remove in RT 4.2 + warn <<EOT; +The InactiveStatus configuration has been replaced by the new Lifecycles +functionality. You should set the 'inactive' property of the 'default' +lifecycle and add transition rules; see RT_Config.pm for documentation. +EOT + }, + }, +); +my %OPTIONS = (); + +=head1 METHODS + +=head2 new + +Object constructor returns new object. Takes no arguments. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) ? ref($proto) : $proto; + my $self = bless {}, $class; + $self->_Init(@_); + return $self; +} + +sub _Init { + return; +} + +=head2 InitConfig + +Do nothin right now. + +=cut + +sub InitConfig { + my $self = shift; + my %args = ( File => '', @_ ); + $args{'File'} =~ s/(?<=Config)(?=\.pm$)/Meta/; + return 1; +} + +=head2 LoadConfigs + +Load all configs. First of all load RT's config then load +extensions' config files in alphabetical order. +Takes no arguments. + +=cut + +sub LoadConfigs { + my $self = shift; + + $self->InitConfig( File => 'RT_Config.pm' ); + $self->LoadConfig( File => 'RT_Config.pm' ); + + my @configs = $self->Configs; + $self->InitConfig( File => $_ ) foreach @configs; + $self->LoadConfig( File => $_ ) foreach @configs; + return; +} + +=head1 LoadConfig + +Takes param hash with C<File> field. +First, the site configuration file is loaded, in order to establish +overall site settings like hostname and name of RT instance. +Then, the core configuration file is loaded to set fallback values +for all settings; it bases some values on settings from the site +configuration file. + +B<Note> that core config file don't change options if site config +has set them so to add value to some option instead of +overriding you have to copy original value from core config file. + +=cut + +sub LoadConfig { + my $self = shift; + my %args = ( File => '', @_ ); + $args{'File'} =~ s/(?<!Site)(?=Config\.pm$)/Site/; + if ( $args{'File'} eq 'RT_SiteConfig.pm' + and my $site_config = $ENV{RT_SITE_CONFIG} ) + { + $self->_LoadConfig( %args, File => $site_config ); + } else { + $self->_LoadConfig(%args); + } + $args{'File'} =~ s/Site(?=Config\.pm$)//; + $self->_LoadConfig(%args); + return 1; +} + +sub _LoadConfig { + my $self = shift; + my %args = ( File => '', @_ ); + + my ($is_ext, $is_site); + if ( $args{'File'} eq ($ENV{RT_SITE_CONFIG}||'') ) { + ($is_ext, $is_site) = ('', 1); + } else { + $is_ext = $args{'File'} =~ /^(?!RT_)(?:(.*)_)(?:Site)?Config/ ? $1 : ''; + $is_site = $args{'File'} =~ /SiteConfig/ ? 1 : 0; + } + + eval { + package RT; + local *Set = sub(\[$@%]@) { + my ( $opt_ref, @args ) = @_; + my ( $pack, $file, $line ) = caller; + return $self->SetFromConfig( + Option => $opt_ref, + Value => [@args], + Package => $pack, + File => $file, + Line => $line, + SiteConfig => $is_site, + Extension => $is_ext, + ); + }; + my @etc_dirs = ($RT::LocalEtcPath); + push @etc_dirs, RT->PluginDirs('etc') if $is_ext; + push @etc_dirs, $RT::EtcPath, @INC; + local @INC = @etc_dirs; + require $args{'File'}; + }; + if ($@) { + return 1 if $is_site && $@ =~ /^Can't locate \Q$args{File}/; + if ( $is_site || $@ !~ /^Can't locate \Q$args{File}/ ) { + die qq{Couldn't load RT config file $args{'File'}:\n\n$@}; + } + + my $username = getpwuid($>); + my $group = getgrgid($(); + + my ( $file_path, $fileuid, $filegid ); + foreach ( $RT::LocalEtcPath, $RT::EtcPath, @INC ) { + my $tmp = File::Spec->catfile( $_, $args{File} ); + ( $fileuid, $filegid ) = ( stat($tmp) )[ 4, 5 ]; + if ( defined $fileuid ) { + $file_path = $tmp; + last; + } + } + unless ($file_path) { + die + qq{Couldn't load RT config file $args{'File'} as user $username / group $group.\n} + . qq{The file couldn't be found in $RT::LocalEtcPath and $RT::EtcPath.\n$@}; + } + + my $message = <<EOF; + +RT couldn't load RT config file %s as: + user: $username + group: $group + +The file is owned by user %s and group %s. + +This usually means that the user/group your webserver is running +as cannot read the file. Be careful not to make the permissions +on this file too liberal, because it contains database passwords. +You may need to put the webserver user in the appropriate group +(%s) or change permissions be able to run succesfully. +EOF + + my $fileusername = getpwuid($fileuid); + my $filegroup = getgrgid($filegid); + my $errormessage = sprintf( $message, + $file_path, $fileusername, $filegroup, $filegroup ); + die "$errormessage\n$@"; + } + return 1; +} + +sub PostLoadCheck { + my $self = shift; + foreach my $o ( grep $META{$_}{'PostLoadCheck'}, $self->Options( Overridable => undef ) ) { + $META{$o}->{'PostLoadCheck'}->( $self, $self->Get($o) ); + } +} + +=head2 Configs + +Returns list of config files found in local etc, plugins' etc +and main etc directories. + +=cut + +sub Configs { + my $self = shift; + + my @configs = (); + foreach my $path ( $RT::LocalEtcPath, RT->PluginDirs('etc'), $RT::EtcPath ) { + my $mask = File::Spec->catfile( $path, "*_Config.pm" ); + my @files = glob $mask; + @files = grep !/^RT_Config\.pm$/, + grep $_ && /^\w+_Config\.pm$/, + map { s/^.*[\\\/]//; $_ } @files; + push @configs, sort @files; + } + + my %seen; + @configs = grep !$seen{$_}++, @configs; + return @configs; +} + +=head2 Get + +Takes name of the option as argument and returns its current value. + +In the case of a user-overridable option, first checks the user's +preferences before looking for site-wide configuration. + +Returns values from RT_SiteConfig, RT_Config and then the %META hash +of configuration variables's "Default" for this config variable, +in that order. + +Returns different things in scalar and array contexts. For scalar +options it's not that important, however for arrays and hash it's. +In scalar context returns references to arrays and hashes. + +Use C<scalar> perl's op to force context, especially when you use +C<(..., Argument => RT->Config->Get('ArrayOpt'), ...)> +as perl's '=>' op doesn't change context of the right hand argument to +scalar. Instead use C<(..., Argument => scalar RT->Config->Get('ArrayOpt'), ...)>. + +It's also important for options that have no default value(no default +in F<etc/RT_Config.pm>). If you don't force scalar context then you'll +get empty list and all your named args will be messed up. For example +C<(arg1 => 1, arg2 => RT->Config->Get('OptionDoesNotExist'), arg3 => 3)> +will result in C<(arg1 => 1, arg2 => 'arg3', 3)> what is most probably +unexpected, or C<(arg1 => 1, arg2 => RT->Config->Get('ArrayOption'), arg3 => 3)> +will result in C<(arg1 => 1, arg2 => 'element of option', 'another_one' => ..., 'arg3', 3)>. + +=cut + +sub Get { + my ( $self, $name, $user ) = @_; + + my $res; + if ( $user && $user->id && $META{$name}->{'Overridable'} ) { + $user = $user->UserObj if $user->isa('RT::CurrentUser'); + my $prefs = $user->Preferences($RT::System); + $res = $prefs->{$name} if $prefs; + } + $res = $OPTIONS{$name} unless defined $res; + $res = $META{$name}->{'Default'} unless defined $res; + return $self->_ReturnValue( $res, $META{$name}->{'Type'} || 'SCALAR' ); +} + +=head2 GetObfuscated + +the same as Get, except it returns Obfuscated value via Obfuscate sub + +=cut + +sub GetObfuscated { + my $self = shift; + my ( $name, $user ) = @_; + my $obfuscate = $META{$name}->{Obfuscate}; + + # we use two Get here is to simplify the logic of the return value + # configs need obfuscation are supposed to be less, so won't be too heavy + + return $self->Get(@_) unless $obfuscate; + + my $res = $self->Get(@_); + $res = $obfuscate->( $self, $res, $user ); + return $self->_ReturnValue( $res, $META{$name}->{'Type'} || 'SCALAR' ); +} + +=head2 Set + +Set option's value to new value. Takes name of the option and new value. +Returns old value. + +The new value should be scalar, array or hash depending on type of the option. +If the option is not defined in meta or the default RT config then it is of +scalar type. + +=cut + +sub Set { + my ( $self, $name ) = ( shift, shift ); + + my $old = $OPTIONS{$name}; + my $type = $META{$name}->{'Type'} || 'SCALAR'; + if ( $type eq 'ARRAY' ) { + $OPTIONS{$name} = [@_]; + { no warnings 'once'; no strict 'refs'; @{"RT::$name"} = (@_); } + } elsif ( $type eq 'HASH' ) { + $OPTIONS{$name} = {@_}; + { no warnings 'once'; no strict 'refs'; %{"RT::$name"} = (@_); } + } else { + $OPTIONS{$name} = shift; + {no warnings 'once'; no strict 'refs'; ${"RT::$name"} = $OPTIONS{$name}; } + } + $META{$name}->{'Type'} = $type; + return $self->_ReturnValue( $old, $type ); +} + +sub _ReturnValue { + my ( $self, $res, $type ) = @_; + return $res unless wantarray; + + if ( $type eq 'ARRAY' ) { + return @{ $res || [] }; + } elsif ( $type eq 'HASH' ) { + return %{ $res || {} }; + } + return $res; +} + +sub SetFromConfig { + my $self = shift; + my %args = ( + Option => undef, + Value => [], + Package => 'RT', + File => '', + Line => 0, + SiteConfig => 1, + Extension => 0, + @_ + ); + + unless ( $args{'File'} ) { + ( $args{'Package'}, $args{'File'}, $args{'Line'} ) = caller(1); + } + + my $opt = $args{'Option'}; + + my $type; + my $name = $self->__GetNameByRef($opt); + if ($name) { + $type = ref $opt; + $name =~ s/.*:://; + } else { + $name = $$opt; + $type = $META{$name}->{'Type'} || 'SCALAR'; + } + + # if option is already set we have to check where + # it comes from and may be ignore it + if ( exists $OPTIONS{$name} ) { + if ( $type eq 'HASH' ) { + $args{'Value'} = [ + @{ $args{'Value'} }, + @{ $args{'Value'} }%2? (undef) : (), + $self->Get( $name ), + ]; + } elsif ( $args{'SiteConfig'} && $args{'Extension'} ) { + # if it's site config of an extension then it can only + # override options that came from its main config + if ( $args{'Extension'} ne $META{$name}->{'Source'}{'Extension'} ) { + my %source = %{ $META{$name}->{'Source'} }; + warn + "Change of config option '$name' at $args{'File'} line $args{'Line'} has been ignored." + ." This option earlier has been set in $source{'File'} line $source{'Line'}." + ." To overide this option use ". ($source{'Extension'}||'RT') + ." site config." + ; + return 1; + } + } elsif ( !$args{'SiteConfig'} && $META{$name}->{'Source'}{'SiteConfig'} ) { + # if it's core config then we can override any option that came from another + # core config, but not site config + + my %source = %{ $META{$name}->{'Source'} }; + if ( $source{'Extension'} ne $args{'Extension'} ) { + # as a site config is loaded earlier then its base config + # then we warn only on different extensions, for example + # RTIR's options is set in main site config + warn + "Change of config option '$name' at $args{'File'} line $args{'Line'} has been ignored." + ." It may be ok, but we want you to be aware." + ." This option has been set earlier in $source{'File'} line $source{'Line'}." + ; + } + + return 1; + } + } + + $META{$name}->{'Type'} = $type; + foreach (qw(Package File Line SiteConfig Extension)) { + $META{$name}->{'Source'}->{$_} = $args{$_}; + } + $self->Set( $name, @{ $args{'Value'} } ); + + return 1; +} + + our %REF_SYMBOLS = ( + SCALAR => '$', + ARRAY => '@', + HASH => '%', + CODE => '&', + ); + +{ + my $last_pack = ''; + + sub __GetNameByRef { + my $self = shift; + my $ref = shift; + my $pack = shift; + if ( !$pack && $last_pack ) { + my $tmp = $self->__GetNameByRef( $ref, $last_pack ); + return $tmp if $tmp; + } + $pack ||= 'main::'; + $pack .= '::' unless substr( $pack, -2 ) eq '::'; + + no strict 'refs'; + my $name = undef; + + # scan $pack's nametable(hash) + foreach my $k ( keys %{$pack} ) { + + # The hash for main:: has a reference to itself + next if $k eq 'main::'; + + # if the entry has a trailing '::' then + # it is a link to another name space + if ( substr( $k, -2 ) eq '::') { + $name = $self->__GetNameByRef( $ref, $pack eq 'main::'? $k : $pack.$k ); + return $name if $name; + } + + # entry of the table with references to + # SCALAR, ARRAY... and other types with + # the same name + my $entry = ${$pack}{$k}; + next unless $entry; + + # Inlined constants are simplified in the symbol table -- + # namely, when possible, you only get a reference back in + # $entry, rather than a full GLOB. In 5.10, scalar + # constants began being inlined this way; starting in 5.20, + # list constants are also inlined. Notably, ref(GLOB) is + # undef, but inlined constants are currently either REF, + # SCALAR, or ARRAY. + next if ref($entry); + + my $ref_type = ref($ref); + + # regex/arrayref/hashref/coderef are stored in SCALAR glob + $ref_type = 'SCALAR' if $ref_type eq 'REF'; + + my $entry_ref = *{$entry}{ $ref_type }; + next if ref $entry_ref && ref $entry_ref ne ref $ref; + next unless $entry_ref; + + # if references are equal then we've found + if ( $entry_ref == $ref ) { + $last_pack = $pack; + return ( $REF_SYMBOLS{ $ref_type } || '*' ) . $pack . $k; + } + } + return ''; + } +} + +=head2 Metadata + + +=head2 Meta + +=cut + +sub Meta { + return $META{ $_[1] }; +} + +sub Sections { + my $self = shift; + my %seen; + my @sections = sort + grep !$seen{$_}++, + map $_->{'Section'} || 'General', + values %META; + return @sections; +} + +sub Options { + my $self = shift; + my %args = ( Section => undef, Overridable => 1, Sorted => 1, @_ ); + my @res = keys %META; + + @res = grep( ( $META{$_}->{'Section'} || 'General' ) eq $args{'Section'}, + @res + ) if defined $args{'Section'}; + + if ( defined $args{'Overridable'} ) { + @res + = grep( ( $META{$_}->{'Overridable'} || 0 ) == $args{'Overridable'}, + @res ); + } + + if ( $args{'Sorted'} ) { + @res = sort { + ($META{$a}->{SortOrder}||9999) <=> ($META{$b}->{SortOrder}||9999) + || $a cmp $b + } @res; + } else { + @res = sort { $a cmp $b } @res; + } + return @res; +} + +=head2 AddOption( Name => '', Section => '', ... ) + +=cut + +sub AddOption { + my $self = shift; + my %args = ( + Name => undef, + Section => undef, + Overridable => 0, + SortOrder => undef, + Widget => '/Widgets/Form/String', + WidgetArguments => {}, + @_ + ); + + unless ( $args{Name} ) { + $RT::Logger->error("Need Name to add a new config"); + return; + } + + unless ( $args{Section} ) { + $RT::Logger->error("Need Section to add a new config option"); + return; + } + + $META{ delete $args{Name} } = \%args; +} + +=head2 DeleteOption( Name => '' ) + +=cut + +sub DeleteOption { + my $self = shift; + my %args = ( + Name => undef, + @_ + ); + if ( $args{Name} ) { + delete $META{$args{Name}}; + } + else { + $RT::Logger->error("Need Name to remove a config option"); + return; + } +} + +=head2 UpdateOption( Name => '' ), Section => '', ... ) + +=cut + +sub UpdateOption { + my $self = shift; + my %args = ( + Name => undef, + Section => undef, + Overridable => undef, + SortOrder => undef, + Widget => undef, + WidgetArguments => undef, + @_ + ); + + my $name = delete $args{Name}; + + unless ( $name ) { + $RT::Logger->error("Need Name to update a new config"); + return; + } + + unless ( exists $META{$name} ) { + $RT::Logger->error("Config $name doesn't exist"); + return; + } + + for my $type ( keys %args ) { + next unless defined $args{$type}; + $META{$name}{$type} = $args{$type}; + } + return 1; +} + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Crypt/GnuPG.pm b/rt/lib/RT/Crypt/GnuPG.pm index d0587d4fe..03636c8c3 100644 --- a/rt/lib/RT/Crypt/GnuPG.pm +++ b/rt/lib/RT/Crypt/GnuPG.pm @@ -401,14 +401,15 @@ sub SignEncrypt { my $entity = $args{'Entity'}; if ( $args{'Sign'} && !defined $args{'Signer'} ) { + my @addresses = Email::Address->parse( Encode::decode("UTF-8",$entity->head->get( 'From' ))); $args{'Signer'} = UseKeyForSigning() - || (Email::Address->parse( $entity->head->get( 'From' ) ))[0]->address; + || $addresses[0]->address; } if ( $args{'Encrypt'} && !$args{'Recipients'} ) { my %seen; $args{'Recipients'} = [ grep $_ && !$seen{ $_ }++, map $_->address, - map Email::Address->parse( $entity->head->get( $_ ) ), + map Email::Address->parse( Encode::decode("UTF-8",$entity->head->get( $_ ) ) ), qw(To Cc Bcc) ]; } @@ -520,7 +521,7 @@ sub SignEncryptRFC3156 { $gnupg->options->push_recipients( $_ ) foreach map UseKeyForEncryption($_) || $_, grep !$seen{ $_ }++, map $_->address, - map Email::Address->parse( $entity->head->get( $_ ) ), + map Email::Address->parse( Encode::decode( "UTF-8", $entity->head->get( $_ ) ) ), qw(To Cc Bcc); my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 ); diff --git a/rt/lib/RT/CurrentUser.pm b/rt/lib/RT/CurrentUser.pm index c11d46031..6ffe14761 100755 --- a/rt/lib/RT/CurrentUser.pm +++ b/rt/lib/RT/CurrentUser.pm @@ -54,7 +54,7 @@ use RT::CurrentUser; - # laod + # load my $current_user = RT::CurrentUser->new; $current_user->Load(...); # or @@ -255,9 +255,6 @@ sub loc_fuzzy { my $self = shift; return '' if !defined $_[0] || $_[0] eq ''; - # XXX: work around perl's deficiency when matching utf8 data - return $_[0] if Encode::is_utf8($_[0]); - return $self->LanguageHandle->maketext_fuzzy( @_ ); } diff --git a/rt/lib/RT/CustomField.pm.orig b/rt/lib/RT/CustomField.pm.orig new file mode 100644 index 000000000..e71bbf78a --- /dev/null +++ b/rt/lib/RT/CustomField.pm.orig @@ -0,0 +1,2170 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +package RT::CustomField; + +use strict; +use warnings; + +use Scalar::Util 'blessed'; + +use base 'RT::Record'; + +sub Table {'CustomFields'} + + +use RT::CustomFieldValues; +use RT::ObjectCustomFields; +use RT::ObjectCustomFieldValues; + +our %FieldTypes = ( + Select => { + sort_order => 10, + selection_type => 1, + + labels => [ 'Select multiple values', # loc + 'Select one value', # loc + 'Select up to [_1] values', # loc + ], + + render_types => { + multiple => [ + + # Default is the first one + 'Select box', # loc + 'List', # loc + ], + single => [ 'Select box', # loc + 'Dropdown', # loc + 'List', # loc + ] + }, + + }, + Freeform => { + sort_order => 20, + selection_type => 0, + + labels => [ 'Enter multiple values', # loc + 'Enter one value', # loc + 'Enter up to [_1] values', # loc + ] + }, + Text => { + sort_order => 30, + selection_type => 0, + labels => [ + 'Fill in multiple text areas', # loc + 'Fill in one text area', # loc + 'Fill in up to [_1] text areas', # loc + ] + }, + Wikitext => { + sort_order => 40, + selection_type => 0, + labels => [ + 'Fill in multiple wikitext areas', # loc + 'Fill in one wikitext area', # loc + 'Fill in up to [_1] wikitext areas', # loc + ] + }, + + Image => { + sort_order => 50, + selection_type => 0, + labels => [ + 'Upload multiple images', # loc + 'Upload one image', # loc + 'Upload up to [_1] images', # loc + ] + }, + Binary => { + sort_order => 60, + selection_type => 0, + labels => [ + 'Upload multiple files', # loc + 'Upload one file', # loc + 'Upload up to [_1] files', # loc + ] + }, + + Combobox => { + sort_order => 70, + selection_type => 1, + labels => [ + 'Combobox: Select or enter multiple values', # loc + 'Combobox: Select or enter one value', # loc + 'Combobox: Select or enter up to [_1] values', # loc + ] + }, + Autocomplete => { + sort_order => 80, + selection_type => 1, + labels => [ + 'Enter multiple values with autocompletion', # loc + 'Enter one value with autocompletion', # loc + 'Enter up to [_1] values with autocompletion', # loc + ] + }, + + Date => { + sort_order => 90, + selection_type => 0, + labels => [ + 'Select multiple dates', # loc + 'Select date', # loc + 'Select up to [_1] dates', # loc + ] + }, + DateTime => { + sort_order => 100, + selection_type => 0, + labels => [ + 'Select multiple datetimes', # loc + 'Select datetime', # loc + 'Select up to [_1] datetimes', # loc + ] + }, + TimeValue => { + sort_order => 105, + selection_type => 0, + labels => [ + 'Enter multiple time values (UNSUPPORTED)', + 'Enter a time value', + 'Enter [_1] time values (UNSUPPORTED)', + ] + }, + + IPAddress => { + sort_order => 110, + selection_type => 0, + + labels => [ 'Enter multiple IP addresses', # loc + 'Enter one IP address', # loc + 'Enter up to [_1] IP addresses', # loc + ] + }, + IPAddressRange => { + sort_order => 120, + selection_type => 0, + + labels => [ 'Enter multiple IP address ranges', # loc + 'Enter one IP address range', # loc + 'Enter up to [_1] IP address ranges', # loc + ] + }, +); + + +our %FRIENDLY_OBJECT_TYPES = (); + +RT::CustomField->_ForObjectType( 'RT::Queue-RT::Ticket' => "Tickets", ); #loc +RT::CustomField->_ForObjectType( + 'RT::Queue-RT::Ticket-RT::Transaction' => "Ticket Transactions", ); #loc +RT::CustomField->_ForObjectType( 'RT::User' => "Users", ); #loc +RT::CustomField->_ForObjectType( 'RT::Queue' => "Queues", ); #loc +RT::CustomField->_ForObjectType( 'RT::Group' => "Groups", ); #loc + +our $RIGHTS = { + SeeCustomField => 'View custom fields', # loc_pair + AdminCustomField => 'Create, modify and delete custom fields', # loc_pair + AdminCustomFieldValues => 'Create, modify and delete custom fields values', # loc_pair + ModifyCustomField => 'Add, modify and delete custom field values for objects' # loc_pair +}; + +our $RIGHT_CATEGORIES = { + SeeCustomField => 'General', + AdminCustomField => 'Admin', + AdminCustomFieldValues => 'Admin', + ModifyCustomField => 'Staff', +}; + +# Tell RT::ACE that this sort of object can get acls granted +$RT::ACE::OBJECT_TYPES{'RT::CustomField'} = 1; + +__PACKAGE__->AddRights(%$RIGHTS); +__PACKAGE__->AddRightCategories(%$RIGHT_CATEGORIES); + +=head2 AddRights C<RIGHT>, C<DESCRIPTION> [, ...] + +Adds the given rights to the list of possible rights. This method +should be called during server startup, not at runtime. + +=cut + +sub AddRights { + my $self = shift; + my %new = @_; + $RIGHTS = { %$RIGHTS, %new }; + %RT::ACE::LOWERCASERIGHTNAMES = ( %RT::ACE::LOWERCASERIGHTNAMES, + map { lc($_) => $_ } keys %new); +} + +sub AvailableRights { + my $self = shift; + return $RIGHTS; +} + +=head2 RightCategories + +Returns a hashref where the keys are rights for this type of object and the +values are the category (General, Staff, Admin) the right falls into. + +=cut + +sub RightCategories { + return $RIGHT_CATEGORIES; +} + +=head2 AddRightCategories C<RIGHT>, C<CATEGORY> [, ...] + +Adds the given right and category pairs to the list of right categories. This +method should be called during server startup, not at runtime. + +=cut + +sub AddRightCategories { + my $self = shift if ref $_[0] or $_[0] eq __PACKAGE__; + my %new = @_; + $RIGHT_CATEGORIES = { %$RIGHT_CATEGORIES, %new }; +} + +=head1 NAME + + RT::CustomField_Overlay - overlay for RT::CustomField + +=head1 DESCRIPTION + +=head1 'CORE' METHODS + +=head2 Create PARAMHASH + +Create takes a hash of values and creates a row in the database: + + varchar(200) 'Name'. + varchar(200) 'Type'. + int(11) 'MaxValues'. + varchar(255) 'Pattern'. + smallint(6) 'Repeated'. + varchar(255) 'Description'. + int(11) 'SortOrder'. + varchar(255) 'LookupType'. + smallint(6) 'Disabled'. + +C<LookupType> is generally the result of either +C<RT::Ticket->CustomFieldLookupType> or C<RT::Transaction->CustomFieldLookupType>. + +=cut + +sub Create { + my $self = shift; + my %args = ( + Name => '', + Type => '', + MaxValues => 0, + Pattern => '', + Description => '', + Disabled => 0, + LookupType => '', + Repeated => 0, + LinkValueTo => '', + IncludeContentForValue => '', + @_, + ); + + unless ( $self->CurrentUser->HasRight(Object => $RT::System, Right => 'AdminCustomField') ) { + return (0, $self->loc('Permission Denied')); + } + + if ( $args{TypeComposite} ) { + @args{'Type', 'MaxValues'} = split(/-/, $args{TypeComposite}, 2); + } + elsif ( $args{Type} =~ s/(?:(Single)|Multiple)$// ) { + # old style Type string + $args{'MaxValues'} = $1 ? 1 : 0; + } + $args{'MaxValues'} = int $args{'MaxValues'}; + + if ( !exists $args{'Queue'}) { + # do nothing -- things below are strictly backward compat + } + elsif ( ! $args{'Queue'} ) { + unless ( $self->CurrentUser->HasRight( Object => $RT::System, Right => 'AssignCustomFields') ) { + return ( 0, $self->loc('Permission Denied') ); + } + $args{'LookupType'} = 'RT::Queue-RT::Ticket'; + } + else { + my $queue = RT::Queue->new($self->CurrentUser); + $queue->Load($args{'Queue'}); + unless ($queue->Id) { + return (0, $self->loc("Queue not found")); + } + unless ( $queue->CurrentUserHasRight('AssignCustomFields') ) { + return ( 0, $self->loc('Permission Denied') ); + } + $args{'LookupType'} = 'RT::Queue-RT::Ticket'; + $args{'Queue'} = $queue->Id; + } + + my ($ok, $msg) = $self->_IsValidRegex( $args{'Pattern'} ); + return (0, $self->loc("Invalid pattern: [_1]", $msg)) unless $ok; + + if ( $args{'MaxValues'} != 1 && $args{'Type'} =~ /(text|combobox)$/i ) { + $RT::Logger->debug("Support for 'multiple' Texts or Comboboxes is not implemented"); + $args{'MaxValues'} = 1; + } + + if ( $args{'RenderType'} ||= undef ) { + my $composite = join '-', @args{'Type', 'MaxValues'}; + return (0, $self->loc("This custom field has no Render Types")) + unless $self->HasRenderTypes( $composite ); + + if ( $args{'RenderType'} eq $self->DefaultRenderType( $composite ) ) { + $args{'RenderType'} = undef; + } else { + return (0, $self->loc("Invalid Render Type") ) + unless grep $_ eq $args{'RenderType'}, $self->RenderTypes( $composite ); + } + } + + $args{'ValuesClass'} = undef if ($args{'ValuesClass'} || '') eq 'RT::CustomFieldValues'; + if ( $args{'ValuesClass'} ||= undef ) { + return (0, $self->loc("This Custom Field can not have list of values")) + unless $self->IsSelectionType( $args{'Type'} ); + + unless ( $self->ValidateValuesClass( $args{'ValuesClass'} ) ) { + return (0, $self->loc("Invalid Custom Field values source")); + } + } + + (my $rv, $msg) = $self->SUPER::Create( + Name => $args{'Name'}, + Type => $args{'Type'}, + RenderType => $args{'RenderType'}, + MaxValues => $args{'MaxValues'}, + Pattern => $args{'Pattern'}, + BasedOn => $args{'BasedOn'}, + ValuesClass => $args{'ValuesClass'}, + Description => $args{'Description'}, + Disabled => $args{'Disabled'}, + LookupType => $args{'LookupType'}, + Repeated => $args{'Repeated'}, + ); + + if ($rv) { + if ( exists $args{'LinkValueTo'}) { + $self->SetLinkValueTo($args{'LinkValueTo'}); + } + + if ( exists $args{'IncludeContentForValue'}) { + $self->SetIncludeContentForValue($args{'IncludeContentForValue'}); + } + + if ( exists $args{'UILocation'} ) { + $self->SetUILocation( $args{'UILocation'} ); + } + + if ( exists $args{'NoClone'} ) { + $self->SetNoClone( $args{'NoClone'} ); + } + + return ($rv, $msg) unless exists $args{'Queue'}; + + # Compat code -- create a new ObjectCustomField mapping + my $OCF = RT::ObjectCustomField->new( $self->CurrentUser ); + $OCF->Create( + CustomField => $self->Id, + ObjectId => $args{'Queue'}, + ); + } + + return ($rv, $msg); +} + +=head2 Load ID/NAME + +Load a custom field. If the value handed in is an integer, load by custom field ID. Otherwise, Load by name. + +=cut + +sub Load { + my $self = shift; + my $id = shift || ''; + + if ( $id =~ /^\d+$/ ) { + return $self->SUPER::Load( $id ); + } else { + return $self->LoadByName( Name => $id ); + } +} + + + +=head2 LoadByName (Queue => QUEUEID, Name => NAME) + +Loads the Custom field named NAME. + +Will load a Disabled Custom Field even if there is a non-disabled Custom Field +with the same Name. + +If a Queue parameter is specified, only look for ticket custom fields tied to that Queue. + +If the Queue parameter is '0', look for global ticket custom fields. + +If no queue parameter is specified, look for any and all custom fields with this name. + +BUG/TODO, this won't let you specify that you only want user or group CFs. + +=cut + +# Compatibility for API change after 3.0 beta 1 +*LoadNameAndQueue = \&LoadByName; +# Change after 3.4 beta. +*LoadByNameAndQueue = \&LoadByName; + +sub LoadByName { + my $self = shift; + my %args = ( + Queue => undef, + Name => undef, + @_, + ); + + unless ( defined $args{'Name'} && length $args{'Name'} ) { + $RT::Logger->error("Couldn't load Custom Field without Name"); + return wantarray ? (0, $self->loc("No name provided")) : 0; + } + + # if we're looking for a queue by name, make it a number + if ( defined $args{'Queue'} && ($args{'Queue'} =~ /\D/ || !$self->ContextObject) ) { + my $QueueObj = RT::Queue->new( $self->CurrentUser ); + $QueueObj->Load( $args{'Queue'} ); + $args{'Queue'} = $QueueObj->Id; + $self->SetContextObject( $QueueObj ) + unless $self->ContextObject; + } + + # XXX - really naive implementation. Slow. - not really. still just one query + + my $CFs = RT::CustomFields->new( $self->CurrentUser ); + $CFs->SetContextObject( $self->ContextObject ); + my $field = $args{'Name'} =~ /\D/? 'Name' : 'id'; + $CFs->Limit( FIELD => $field, VALUE => $args{'Name'}, CASESENSITIVE => 0); + # Don't limit to queue if queue is 0. Trying to do so breaks + # RT::Group type CFs. + if ( defined $args{'Queue'} ) { + $CFs->LimitToQueue( $args{'Queue'} ); + } + + # When loading by name, we _can_ load disabled fields, but prefer + # non-disabled fields. + $CFs->FindAllRows; + $CFs->OrderByCols( + { FIELD => "Disabled", ORDER => 'ASC' }, + ); + + # We only want one entry. + $CFs->RowsPerPage(1); + + # version before 3.8 just returns 0, so we need to test if wantarray to be + # backward compatible. + return wantarray ? (0, $self->loc("Not found")) : 0 unless my $first = $CFs->First; + + return $self->LoadById( $first->id ); +} + + + + +=head2 Custom field values + +=head3 Values FIELD + +Return a object (collection) of all acceptable values for this Custom Field. +Class of the object can vary and depends on the return value +of the C<ValuesClass> method. + +=cut + +*ValuesObj = \&Values; + +sub Values { + my $self = shift; + + my $class = $self->ValuesClass; + if ( $class ne 'RT::CustomFieldValues') { + eval "require $class" or die "$@"; + } + my $cf_values = $class->new( $self->CurrentUser ); + # if the user has no rights, return an empty object + if ( $self->id && $self->CurrentUserHasRight( 'SeeCustomField') ) { + $cf_values->LimitToCustomField( $self->Id ); + } else { + $cf_values->Limit( FIELD => 'id', VALUE => 0, SUBCLAUSE => 'acl' ); + } + return ($cf_values); +} + + +=head3 AddValue HASH + +Create a new value for this CustomField. Takes a paramhash containing the elements Name, Description and SortOrder + +=cut + +sub AddValue { + my $self = shift; + my %args = @_; + + unless ($self->CurrentUserHasRight('AdminCustomField') || $self->CurrentUserHasRight('AdminCustomFieldValues')) { + return (0, $self->loc('Permission Denied')); + } + + # allow zero value + if ( !defined $args{'Name'} || $args{'Name'} eq '' ) { + return (0, $self->loc("Can't add a custom field value without a name")); + } + + my $newval = RT::CustomFieldValue->new( $self->CurrentUser ); + return $newval->Create( %args, CustomField => $self->Id ); +} + + + + +=head3 DeleteValue ID + +Deletes a value from this custom field by id. + +Does not remove this value for any article which has had it selected + +=cut + +sub DeleteValue { + my $self = shift; + my $id = shift; + unless ( $self->CurrentUserHasRight('AdminCustomField') || $self->CurrentUserHasRight('AdminCustomFieldValues') ) { + return (0, $self->loc('Permission Denied')); + } + + my $val_to_del = RT::CustomFieldValue->new( $self->CurrentUser ); + $val_to_del->Load( $id ); + unless ( $val_to_del->Id ) { + return (0, $self->loc("Couldn't find that value")); + } + unless ( $val_to_del->CustomField == $self->Id ) { + return (0, $self->loc("That is not a value for this custom field")); + } + + my $retval = $val_to_del->Delete; + unless ( $retval ) { + return (0, $self->loc("Custom field value could not be deleted")); + } + return ($retval, $self->loc("Custom field value deleted")); +} + + +=head2 ValidateQueue Queue + +Make sure that the name specified is valid + +=cut + +sub ValidateName { + my $self = shift; + my $value = shift; + + return 0 unless length $value; + + return $self->SUPER::ValidateName($value); +} + +=head2 ValidateQueue Queue + +Make sure that the queue specified is a valid queue name + +=cut + +sub ValidateQueue { + my $self = shift; + my $id = shift; + + return undef unless defined $id; + # 0 means "Global" null would _not_ be ok. + return 1 if $id eq '0'; + + my $q = RT::Queue->new( RT->SystemUser ); + $q->Load( $id ); + return undef unless $q->id; + return 1; +} + + + +=head2 Types + +Retuns an array of the types of CustomField that are supported + +=cut + +sub Types { + return (sort {(($FieldTypes{$a}{sort_order}||999) <=> ($FieldTypes{$b}{sort_order}||999)) or ($a cmp $b)} keys %FieldTypes); +} + + +=head2 IsSelectionType + +Retuns a boolean value indicating whether the C<Values> method makes sense +to this Custom Field. + +=cut + +sub IsSelectionType { + my $self = shift; + my $type = @_? shift : $self->Type; + return undef unless $type; + return $FieldTypes{$type}->{selection_type}; +} + + + +=head2 IsExternalValues + +=cut + +sub IsExternalValues { + my $self = shift; + return 0 unless $self->IsSelectionType( @_ ); + return $self->ValuesClass eq 'RT::CustomFieldValues'? 0 : 1; +} + +sub ValuesClass { + my $self = shift; + return $self->_Value( ValuesClass => @_ ) || 'RT::CustomFieldValues'; +} + +sub SetValuesClass { + my $self = shift; + my $class = shift || 'RT::CustomFieldValues'; + + if ( $class eq 'RT::CustomFieldValues' ) { + return $self->_Set( Field => 'ValuesClass', Value => undef, @_ ); + } + + return (0, $self->loc("This Custom Field can not have list of values")) + unless $self->IsSelectionType; + + unless ( $self->ValidateValuesClass( $class ) ) { + return (0, $self->loc("Invalid Custom Field values source")); + } + return $self->_Set( Field => 'ValuesClass', Value => $class, @_ ); +} + +sub ValidateValuesClass { + my $self = shift; + my $class = shift; + + return 1 if !$class || $class eq 'RT::CustomFieldValues'; + return 1 if grep $class eq $_, RT->Config->Get('CustomFieldValuesSources'); + return undef; +} + + +=head2 FriendlyType [TYPE, MAX_VALUES] + +Returns a localized human-readable version of the custom field type. +If a custom field type is specified as the parameter, the friendly type for that type will be returned + +=cut + +sub FriendlyType { + my $self = shift; + + my $type = @_ ? shift : $self->Type; + my $max = @_ ? shift : $self->MaxValues; + $max = 0 unless $max; + + if (my $friendly_type = $FieldTypes{$type}->{labels}->[$max>2 ? 2 : $max]) { + return ( $self->loc( $friendly_type, $max ) ); + } + else { + return ( $self->loc( $type ) ); + } +} + +sub FriendlyTypeComposite { + my $self = shift; + my $composite = shift || $self->TypeComposite; + return $self->FriendlyType(split(/-/, $composite, 2)); +} + + +=head2 ValidateType TYPE + +Takes a single string. returns true if that string is a value +type of custom field + + +=cut + +sub ValidateType { + my $self = shift; + my $type = shift; + + if ( $type =~ s/(?:Single|Multiple)$// ) { + $RT::Logger->warning( "Prefix 'Single' and 'Multiple' to Type deprecated, use MaxValues instead at (". join(":",caller).")"); + } + + if ( $FieldTypes{$type} ) { + return 1; + } + else { + return undef; + } +} + + +sub SetType { + my $self = shift; + my $type = shift; + if ($type =~ s/(?:(Single)|Multiple)$//) { + $RT::Logger->warning("'Single' and 'Multiple' on SetType deprecated, use SetMaxValues instead at (". join(":",caller).")"); + $self->SetMaxValues($1 ? 1 : 0); + } + $self->_Set(Field => 'Type', Value =>$type); +} + +=head2 SetPattern STRING + +Takes a single string representing a regular expression. Performs basic +validation on that regex, and sets the C<Pattern> field for the CF if it +is valid. + +=cut + +sub SetPattern { + my $self = shift; + my $regex = shift; + + my ($ok, $msg) = $self->_IsValidRegex($regex); + if ($ok) { + return $self->_Set(Field => 'Pattern', Value => $regex); + } + else { + return (0, $self->loc("Invalid pattern: [_1]", $msg)); + } +} + +=head2 _IsValidRegex(Str $regex) returns (Bool $success, Str $msg) + +Tests if the string contains an invalid regex. + +=cut + +sub _IsValidRegex { + my $self = shift; + my $regex = shift or return (1, 'valid'); + + local $^W; local $@; + local $SIG{__DIE__} = sub { 1 }; + local $SIG{__WARN__} = sub { 1 }; + + if (eval { qr/$regex/; 1 }) { + return (1, 'valid'); + } + + my $err = $@; + $err =~ s{[,;].*}{}; # strip debug info from error + chomp $err; + return (0, $err); +} + + +=head2 SingleValue + +Returns true if this CustomField only accepts a single value. +Returns false if it accepts multiple values + +=cut + +sub SingleValue { + my $self = shift; + if (($self->MaxValues||0) == 1) { + return 1; + } + else { + return undef; + } +} + +sub UnlimitedValues { + my $self = shift; + if (($self->MaxValues||0) == 0) { + return 1; + } + else { + return undef; + } +} + + +=head2 CurrentUserHasRight RIGHT + +Helper function to call the custom field's queue's CurrentUserHasRight with the passed in args. + +=cut + +sub CurrentUserHasRight { + my $self = shift; + my $right = shift; + + return $self->CurrentUser->HasRight( + Object => $self, + Right => $right, + ); +} + +=head2 ACLEquivalenceObjects + +Returns list of objects via which users can get rights on this custom field. For custom fields +these objects can be set using L<ContextObject|/"ContextObject and SetContextObject">. + +=cut + +sub ACLEquivalenceObjects { + my $self = shift; + + my $ctx = $self->ContextObject + or return; + return ($ctx, $ctx->ACLEquivalenceObjects); +} + +=head2 ContextObject and SetContextObject + +Set or get a context for this object. It can be ticket, queue or another object +this CF applies to. Used for ACL control, for example SeeCustomField can be granted on +queue level to allow people to see all fields applied to the queue. + +=cut + +sub SetContextObject { + my $self = shift; + return $self->{'context_object'} = shift; +} + +sub ContextObject { + my $self = shift; + return $self->{'context_object'}; +} + +sub ValidContextType { + my $self = shift; + my $class = shift; + + my %valid; + $valid{$_}++ for split '-', $self->LookupType; + delete $valid{'RT::Transaction'}; + + return $valid{$class}; +} + +=head2 LoadContextObject + +Takes an Id for a Context Object and loads the right kind of RT::Object +for this particular Custom Field (based on the LookupType) and returns it. +This is a good way to ensure you don't try to use a Queue as a Context +Object on a User Custom Field. + +=cut + +sub LoadContextObject { + my $self = shift; + my $type = shift; + my $contextid = shift; + + unless ( $self->ValidContextType($type) ) { + RT->Logger->debug("Invalid ContextType $type for Custom Field ".$self->Id); + return; + } + + my $context_object = $type->new( $self->CurrentUser ); + my ($id, $msg) = $context_object->LoadById( $contextid ); + unless ( $id ) { + RT->Logger->debug("Invalid ContextObject id: $msg"); + return; + } + return $context_object; +} + +=head2 ValidateContextObject + +Ensure that a given ContextObject applies to this Custom Field. +For custom fields that are assigned to Queues or to Classes, this checks that the Custom +Field is actually applied to that objects. For Global Custom Fields, it returns true +as long as the Object is of the right type, because you may be using +your permissions on a given Queue of Class to see a Global CF. +For CFs that are only applied Globally, you don't need a ContextObject. + +=cut + +sub ValidateContextObject { + my $self = shift; + my $object = shift; + + return 1 if $self->IsApplied(0); + + # global only custom fields don't have objects + # that should be used as context objects. + return if $self->ApplyGlobally; + + # Otherwise, make sure we weren't passed a user object that we're + # supposed to treat as a queue. + return unless $self->ValidContextType(ref $object); + + # Check that it is applied correctly + my ($applied_to) = grep {ref($_) eq $self->RecordClassFromLookupType} ($object, $object->ACLEquivalenceObjects); + return unless $applied_to; + return $self->IsApplied($applied_to->id); +} + + +sub _Set { + my $self = shift; + + unless ( $self->CurrentUserHasRight('AdminCustomField') ) { + return ( 0, $self->loc('Permission Denied') ); + } + return $self->SUPER::_Set( @_ ); + +} + + + +=head2 _Value + +Takes the name of a table column. +Returns its value as a string, if the user passes an ACL check + +=cut + +sub _Value { + my $self = shift; + return undef unless $self->id; + + # we need to do the rights check + unless ( $self->CurrentUserHasRight('SeeCustomField') ) { + $RT::Logger->debug( + "Permission denied. User #". $self->CurrentUser->id + ." has no SeeCustomField right on CF #". $self->id + ); + return (undef); + } + return $self->__Value( @_ ); +} + + +=head2 SetDisabled + +Takes a boolean. +1 will cause this custom field to no longer be avaialble for objects. +0 will re-enable this field. + +=cut + + +=head2 SetTypeComposite + +Set this custom field's type and maximum values as a composite value + +=cut + +sub SetTypeComposite { + my $self = shift; + my $composite = shift; + + my $old = $self->TypeComposite; + + my ($type, $max_values) = split(/-/, $composite, 2); + if ( $type ne $self->Type ) { + my ($status, $msg) = $self->SetType( $type ); + return ($status, $msg) unless $status; + } + if ( ($max_values || 0) != ($self->MaxValues || 0) ) { + my ($status, $msg) = $self->SetMaxValues( $max_values ); + return ($status, $msg) unless $status; + } + my $render = $self->RenderType; + if ( $render and not grep { $_ eq $render } $self->RenderTypes ) { + # We switched types and our render type is no longer valid, so unset it + # and use the default + $self->SetRenderType( undef ); + } + return 1, $self->loc( + "Type changed from '[_1]' to '[_2]'", + $self->FriendlyTypeComposite( $old ), + $self->FriendlyTypeComposite( $composite ), + ); +} + +=head2 TypeComposite + +Returns a composite value composed of this object's type and maximum values + +=cut + + +sub TypeComposite { + my $self = shift; + return join '-', ($self->Type || ''), ($self->MaxValues || 0); +} + +=head2 TypeComposites + +Returns an array of all possible composite values for custom fields. + +=cut + +sub TypeComposites { + my $self = shift; + return grep !/(?:[Tt]ext|Combobox|Date|DateTime|TimeValue)-0/, map { ("$_-1", "$_-0") } $self->Types; +} + +=head2 RenderType + +Returns the type of form widget to render for this custom field. Currently +this only affects fields which return true for L</HasRenderTypes>. + +=cut + +sub RenderType { + my $self = shift; + return '' unless $self->HasRenderTypes; + + return $self->_Value( 'RenderType', @_ ) + || $self->DefaultRenderType; +} + +=head2 SetRenderType TYPE + +Sets this custom field's render type. + +=cut + +sub SetRenderType { + my $self = shift; + my $type = shift; + return (0, $self->loc("This custom field has no Render Types")) + unless $self->HasRenderTypes; + + if ( !$type || $type eq $self->DefaultRenderType ) { + return $self->_Set( Field => 'RenderType', Value => undef, @_ ); + } + + if ( not grep { $_ eq $type } $self->RenderTypes ) { + return (0, $self->loc("Invalid Render Type for custom field of type [_1]", + $self->FriendlyType)); + } + + return $self->_Set( Field => 'RenderType', Value => $type, @_ ); +} + +=head2 DefaultRenderType [TYPE COMPOSITE] + +Returns the default render type for this custom field's type or the TYPE +COMPOSITE specified as an argument. + +=cut + +sub DefaultRenderType { + my $self = shift; + my $composite = @_ ? shift : $self->TypeComposite; + my ($type, $max) = split /-/, $composite, 2; + return unless $type and $self->HasRenderTypes($composite); + return $FieldTypes{$type}->{render_types}->{ $max == 1 ? 'single' : 'multiple' }[0]; +} + +=head2 HasRenderTypes [TYPE_COMPOSITE] + +Returns a boolean value indicating whether the L</RenderTypes> and +L</RenderType> methods make sense for this custom field. + +Currently true only for type C<Select>. + +=cut + +sub HasRenderTypes { + my $self = shift; + my ($type, $max) = split /-/, (@_ ? shift : $self->TypeComposite), 2; + return undef unless $type; + return defined $FieldTypes{$type}->{render_types} + ->{ $max == 1 ? 'single' : 'multiple' }; +} + +=head2 RenderTypes [TYPE COMPOSITE] + +Returns the valid render types for this custom field's type or the TYPE +COMPOSITE specified as an argument. + +=cut + +sub RenderTypes { + my $self = shift; + my $composite = @_ ? shift : $self->TypeComposite; + my ($type, $max) = split /-/, $composite, 2; + return unless $type and $self->HasRenderTypes($composite); + return @{$FieldTypes{$type}->{render_types}->{ $max == 1 ? 'single' : 'multiple' }}; +} + +=head2 SetLookupType + +Autrijus: care to doc how LookupTypes work? + +=cut + +sub SetLookupType { + my $self = shift; + my $lookup = shift; + if ( $lookup ne $self->LookupType ) { + # Okay... We need to invalidate our existing relationships + my $ObjectCustomFields = RT::ObjectCustomFields->new($self->CurrentUser); + $ObjectCustomFields->LimitToCustomField($self->Id); + $_->Delete foreach @{$ObjectCustomFields->ItemsArrayRef}; + } + return $self->_Set(Field => 'LookupType', Value =>$lookup); +} + +=head2 LookupTypes + +Returns an array of LookupTypes available + +=cut + + +sub LookupTypes { + my $self = shift; + return sort keys %FRIENDLY_OBJECT_TYPES; +} + +my @FriendlyObjectTypes = ( + "[_1] objects", # loc + "[_1]'s [_2] objects", # loc + "[_1]'s [_2]'s [_3] objects", # loc +); + +=head2 FriendlyLookupType + +Returns a localized description of the type of this custom field + +=cut + +sub FriendlyLookupType { + my $self = shift; + my $lookup = shift || $self->LookupType; + + return ($self->loc( $FRIENDLY_OBJECT_TYPES{$lookup} )) + if (defined $FRIENDLY_OBJECT_TYPES{$lookup} ); + + my @types = map { s/^RT::// ? $self->loc($_) : $_ } + grep { defined and length } + split( /-/, $lookup ) + or return; + return ( $self->loc( $FriendlyObjectTypes[$#types], @types ) ); +} + +=head1 RecordClassFromLookupType + +Returns the type of Object referred to by ObjectCustomFields' ObjectId column + +Optionally takes a LookupType to use instead of using the value on the loaded +record. In this case, the method may be called on the class instead of an +object. + +=cut + +sub RecordClassFromLookupType { + my $self = shift; + my $type = shift || $self->LookupType; + my ($class) = ($type =~ /^([^-]+)/); + unless ( $class ) { + if (blessed($self) and $self->LookupType eq $type) { + $RT::Logger->error( + "Custom Field #". $self->id + ." has incorrect LookupType '$type'" + ); + } else { + RT->Logger->error("Invalid LookupType passed as argument: $type"); + } + return undef; + } + return $class; +} + +=head1 ObjectTypeFromLookupType + +Returns the ObjectType used in ObjectCustomFieldValues rows for this CF + +Optionally takes a LookupType to use instead of using the value on the loaded +record. In this case, the method may be called on the class instead of an +object. + +=cut + +sub ObjectTypeFromLookupType { + my $self = shift; + my $type = shift || $self->LookupType; + my ($class) = ($type =~ /([^-]+)$/); + unless ( $class ) { + if (blessed($self) and $self->LookupType eq $type) { + $RT::Logger->error( + "Custom Field #". $self->id + ." has incorrect LookupType '$type'" + ); + } else { + RT->Logger->error("Invalid LookupType passed as argument: $type"); + } + return undef; + } + return $class; +} + +sub CollectionClassFromLookupType { + my $self = shift; + + my $record_class = $self->RecordClassFromLookupType; + return undef unless $record_class; + + my $collection_class; + if ( UNIVERSAL::can($record_class.'Collection', 'new') ) { + $collection_class = $record_class.'Collection'; + } elsif ( UNIVERSAL::can($record_class.'es', 'new') ) { + $collection_class = $record_class.'es'; + } elsif ( UNIVERSAL::can($record_class.'s', 'new') ) { + $collection_class = $record_class.'s'; + } else { + $RT::Logger->error("Can not find a collection class for record class '$record_class'"); + return undef; + } + return $collection_class; +} + +=head1 ApplyGlobally + +Certain custom fields (users, groups) should only be applied globally +but rather than regexing in code for LookupType =~ RT::Queue, we'll codify +the rules here. + +=cut + +sub ApplyGlobally { + my $self = shift; + + return ($self->LookupType =~ /^RT::(?:Group|User)/io); + +} + +=head1 AppliedTo + +Returns collection with objects this custom field is applied to. +Class of the collection depends on L</LookupType>. +See all L</NotAppliedTo> . + +Doesn't takes into account if object is applied globally. + +=cut + +sub AppliedTo { + my $self = shift; + + my ($res, $ocfs_alias) = $self->_AppliedTo; + return $res unless $res; + + $res->Limit( + ALIAS => $ocfs_alias, + FIELD => 'id', + OPERATOR => 'IS NOT', + VALUE => 'NULL', + ); + + return $res; +} + +=head1 NotAppliedTo + +Returns collection with objects this custom field is not applied to. +Class of the collection depends on L</LookupType>. +See all L</AppliedTo> . + +Doesn't takes into account if object is applied globally. + +=cut + +sub NotAppliedTo { + my $self = shift; + + my ($res, $ocfs_alias) = $self->_AppliedTo; + return $res unless $res; + + $res->Limit( + ALIAS => $ocfs_alias, + FIELD => 'id', + OPERATOR => 'IS', + VALUE => 'NULL', + ); + + return $res; +} + +sub _AppliedTo { + my $self = shift; + + my ($class) = $self->CollectionClassFromLookupType; + return undef unless $class; + + my $res = $class->new( $self->CurrentUser ); + + # If CF is a Group CF, only display user-defined groups + if ( $class eq 'RT::Groups' ) { + $res->LimitToUserDefinedGroups; + } + + $res->OrderBy( FIELD => 'Name' ); + my $ocfs_alias = $res->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'ObjectCustomFields', + FIELD2 => 'ObjectId', + ); + $res->Limit( + LEFTJOIN => $ocfs_alias, + ALIAS => $ocfs_alias, + FIELD => 'CustomField', + VALUE => $self->id, + ); + return ($res, $ocfs_alias); +} + +=head2 IsApplied + +Takes object id and returns corresponding L<RT::ObjectCustomField> +record if this custom field is applied to the object. Use 0 to check +if custom field is applied globally. + +=cut + +sub IsApplied { + my $self = shift; + my $id = shift; + my $ocf = RT::ObjectCustomField->new( $self->CurrentUser ); + $ocf->LoadByCols( CustomField => $self->id, ObjectId => $id || 0 ); + return undef unless $ocf->id; + return $ocf; +} + +=head2 AddToObject OBJECT + +Add this custom field as a custom field for a single object, such as a queue or group. + +Takes an object + +=cut + + +sub AddToObject { + my $self = shift; + my $object = shift; + my $id = $object->Id || 0; + + unless (index($self->LookupType, ref($object)) == 0) { + return ( 0, $self->loc('Lookup type mismatch') ); + } + + unless ( $object->CurrentUserHasRight('AssignCustomFields') ) { + return ( 0, $self->loc('Permission Denied') ); + } + + if ( $self->IsApplied( $id ) ) { + return ( 0, $self->loc("Custom field is already applied to the object") ); + } + + if ( $id ) { + # applying locally + return (0, $self->loc("Couldn't apply custom field to an object as it's global already") ) + if $self->IsApplied( 0 ); + } + else { + my $applied = RT::ObjectCustomFields->new( $self->CurrentUser ); + $applied->LimitToCustomField( $self->id ); + while ( my $record = $applied->Next ) { + $record->Delete; + } + } + + my $ocf = RT::ObjectCustomField->new( $self->CurrentUser ); + my ( $oid, $msg ) = $ocf->Create( + ObjectId => $id, CustomField => $self->id, + ); + return ( $oid, $msg ); +} + + +=head2 RemoveFromObject OBJECT + +Remove this custom field for a single object, such as a queue or group. + +Takes an object + +=cut + +sub RemoveFromObject { + my $self = shift; + my $object = shift; + my $id = $object->Id || 0; + + unless (index($self->LookupType, ref($object)) == 0) { + return ( 0, $self->loc('Object type mismatch') ); + } + + unless ( $object->CurrentUserHasRight('AssignCustomFields') ) { + return ( 0, $self->loc('Permission Denied') ); + } + + my $ocf = $self->IsApplied( $id ); + unless ( $ocf ) { + return ( 0, $self->loc("This custom field does not apply to that object") ); + } + + # XXX: Delete doesn't return anything + my ( $oid, $msg ) = $ocf->Delete; + return ( $oid, $msg ); +} + + +=head2 AddValueForObject HASH + +Adds a custom field value for a record object of some kind. +Takes a param hash of + +Required: + + Object + Content + +Optional: + + LargeContent + ContentType + +=cut + +sub AddValueForObject { + my $self = shift; + my %args = ( + Object => undef, + Content => undef, + LargeContent => undef, + ContentType => undef, + @_ + ); + my $obj = $args{'Object'} or return ( 0, $self->loc('Invalid object') ); + + unless ( $self->CurrentUserHasRight('ModifyCustomField') ) { + return ( 0, $self->loc('Permission Denied') ); + } + + unless ( $self->MatchPattern($args{'Content'}) ) { + return ( 0, $self->loc('Input must match [_1]', $self->FriendlyPattern) ); + } + + $RT::Handle->BeginTransaction; + + if ( $self->MaxValues ) { + my $current_values = $self->ValuesForObject($obj); + my $extra_values = ( $current_values->Count + 1 ) - $self->MaxValues; + + # (The +1 is for the new value we're adding) + + # If we have a set of current values and we've gone over the maximum + # allowed number of values, we'll need to delete some to make room. + # which former values are blown away is not guaranteed + + while ($extra_values) { + my $extra_item = $current_values->Next; + unless ( $extra_item->id ) { + $RT::Logger->crit( "We were just asked to delete " + ."a custom field value that doesn't exist!" ); + $RT::Handle->Rollback(); + return (undef); + } + $extra_item->Delete; + $extra_values--; + } + } + + if (my $canonicalizer = $self->can('_CanonicalizeValue'.$self->Type)) { + $canonicalizer->($self, \%args); + } + + + + my $newval = RT::ObjectCustomFieldValue->new( $self->CurrentUser ); + my ($val, $msg) = $newval->Create( + ObjectType => ref($obj), + ObjectId => $obj->Id, + Content => $args{'Content'}, + LargeContent => $args{'LargeContent'}, + ContentType => $args{'ContentType'}, + CustomField => $self->Id + ); + + unless ($val) { + $RT::Handle->Rollback(); + return ($val, $self->loc("Couldn't create record: [_1]", $msg)); + } + + $RT::Handle->Commit(); + return ($val); + +} + + + +sub _CanonicalizeValueDateTime { + my $self = shift; + my $args = shift; + my $DateObj = RT::Date->new( $self->CurrentUser ); + $DateObj->Set( Format => 'unknown', + Value => $args->{'Content'} ); + $args->{'Content'} = $DateObj->ISO; +} + +# For date, we need to store Content as ISO date +sub _CanonicalizeValueDate { + my $self = shift; + my $args = shift; + + # in case user input date with time, let's omit it by setting timezone + # to utc so "hour" won't affect "day" + my $DateObj = RT::Date->new( $self->CurrentUser ); + $DateObj->Set( Format => 'unknown', + Value => $args->{'Content'}, + ); + $args->{'Content'} = $DateObj->Date( Timezone => 'user' ); +} + +=head2 MatchPattern STRING + +Tests the incoming string against the Pattern of this custom field object +and returns a boolean; returns true if the Pattern is empty. + +=cut + +sub MatchPattern { + my $self = shift; + my $regex = $self->Pattern or return 1; + + return (( defined $_[0] ? $_[0] : '') =~ $regex); +} + + + + +=head2 FriendlyPattern + +Prettify the pattern of this custom field, by taking the text in C<(?#text)> +and localizing it. + +=cut + +sub FriendlyPattern { + my $self = shift; + my $regex = $self->Pattern; + + return '' unless length $regex; + if ( $regex =~ /\(\?#([^)]*)\)/ ) { + return '[' . $self->loc($1) . ']'; + } + else { + return $regex; + } +} + + + + +=head2 DeleteValueForObject HASH + +Deletes a custom field value for a ticket. Takes a param hash of Object and Content + +Returns a tuple of (STATUS, MESSAGE). If the call succeeded, the STATUS is true. otherwise it's false + +=cut + +sub DeleteValueForObject { + my $self = shift; + my %args = ( Object => undef, + Content => undef, + Id => undef, + @_ ); + + + unless ($self->CurrentUserHasRight('ModifyCustomField')) { + return (0, $self->loc('Permission Denied')); + } + + my $oldval = RT::ObjectCustomFieldValue->new($self->CurrentUser); + + if (my $id = $args{'Id'}) { + $oldval->Load($id); + } + unless ($oldval->id) { + $oldval->LoadByObjectContentAndCustomField( + Object => $args{'Object'}, + Content => $args{'Content'}, + CustomField => $self->Id, + ); + } + + + # check to make sure we found it + unless ($oldval->Id) { + return(0, $self->loc("Custom field value [_1] could not be found for custom field [_2]", $args{'Content'}, $self->Name)); + } + + # for single-value fields, we need to validate that empty string is a valid value for it + if ( $self->SingleValue and not $self->MatchPattern( '' ) ) { + return ( 0, $self->loc('Input must match [_1]', $self->FriendlyPattern) ); + } + + # delete it + + my $ret = $oldval->Delete(); + unless ($ret) { + return(0, $self->loc("Custom field value could not be found")); + } + return($oldval->Id, $self->loc("Custom field value deleted")); +} + + +=head2 ValuesForObject OBJECT + +Return an L<RT::ObjectCustomFieldValues> object containing all of this custom field's values for OBJECT + +=cut + +sub ValuesForObject { + my $self = shift; + my $object = shift; + + my $values = RT::ObjectCustomFieldValues->new($self->CurrentUser); + unless ($self->id and $self->CurrentUserHasRight('SeeCustomField')) { + # Return an empty object if they have no rights to see + $values->Limit( FIELD => "id", VALUE => 0, SUBCLAUSE => "ACL" ); + return ($values); + } + + $values->LimitToCustomField($self->Id); + $values->LimitToObject($object); + + return ($values); +} + + +=head2 _ForObjectType PATH FRIENDLYNAME + +Tell RT that a certain object accepts custom fields + +Examples: + + 'RT::Queue-RT::Ticket' => "Tickets", # loc + 'RT::Queue-RT::Ticket-RT::Transaction' => "Ticket Transactions", # loc + 'RT::User' => "Users", # loc + 'RT::Group' => "Groups", # loc + 'RT::Queue' => "Queues", # loc + +This is a class method. + +=cut + +sub _ForObjectType { + my $self = shift; + my $path = shift; + my $friendly_name = shift; + + $FRIENDLY_OBJECT_TYPES{$path} = $friendly_name; + +} + + +=head2 IncludeContentForValue [VALUE] (and SetIncludeContentForValue) + +Gets or sets the C<IncludeContentForValue> for this custom field. RT +uses this field to automatically include content into the user's browser +as they display records with custom fields in RT. + +=cut + +sub SetIncludeContentForValue { + shift->IncludeContentForValue(@_); +} +sub IncludeContentForValue{ + my $self = shift; + $self->_URLTemplate('IncludeContentForValue', @_); +} + + + +=head2 LinkValueTo [VALUE] (and SetLinkValueTo) + +Gets or sets the C<LinkValueTo> for this custom field. RT +uses this field to make custom field values into hyperlinks in the user's +browser as they display records with custom fields in RT. + +=cut + + +sub SetLinkValueTo { + shift->LinkValueTo(@_); +} + +sub LinkValueTo { + my $self = shift; + $self->_URLTemplate('LinkValueTo', @_); + +} + + +=head2 _URLTemplate NAME [VALUE] + +With one argument, returns the _URLTemplate named C<NAME>, but only if +the current user has the right to see this custom field. + +With two arguments, attemptes to set the relevant template value. + +=cut + +sub _URLTemplate { + my $self = shift; + my $template_name = shift; + if (@_) { + + my $value = shift; + unless ( $self->CurrentUserHasRight('AdminCustomField') ) { + return ( 0, $self->loc('Permission Denied') ); + } + $self->SetAttribute( Name => $template_name, Content => $value ); + return ( 1, $self->loc('Updated') ); + } else { + unless ( $self->id && $self->CurrentUserHasRight('SeeCustomField') ) { + return (undef); + } + + my @attr = $self->Attributes->Named($template_name); + my $attr = shift @attr; + + if ($attr) { return $attr->Content } + + } +} + +sub SetBasedOn { + my $self = shift; + my $value = shift; + + return $self->_Set( Field => 'BasedOn', Value => $value, @_ ) + unless defined $value and length $value; + + my $cf = RT::CustomField->new( $self->CurrentUser ); + $cf->SetContextObject( $self->ContextObject ); + $cf->Load( ref $value ? $value->id : $value ); + + return (0, "Permission denied") + unless $cf->id && $cf->CurrentUserHasRight('SeeCustomField'); + + # XXX: Remove this restriction once we support lists and cascaded selects + if ( $self->RenderType =~ /List/ ) { + return (0, $self->loc("We can't currently render as a List when basing categories on another custom field. Please use another render type.")); + } + + return $self->_Set( Field => 'BasedOn', Value => $value, @_ ) +} + +sub BasedOnObj { + my $self = shift; + + my $obj = RT::CustomField->new( $self->CurrentUser ); + $obj->SetContextObject( $self->ContextObject ); + if ( $self->BasedOn ) { + $obj->Load( $self->BasedOn ); + } + return $obj; +} + +sub UILocation { + my $self = shift; + my $tag = $self->FirstAttribute( 'UILocation' ); + return $tag ? $tag->Content : ''; +} + +sub SetUILocation { + my $self = shift; + my $tag = shift; + if ( $tag ) { + return $self->SetAttribute( Name => 'UILocation', Content => $tag ); + } + else { + return $self->DeleteAttribute('UILocation'); + } +} + +sub NoClone { + my $self = shift; + $self->FirstAttribute('NoClone') ? 1 : ''; +} + +sub SetNoClone { + my $self = shift; + my $value = shift; + if ( $value ) { + return $self->SetAttribute( Name => 'NoClone', Content => 1 ); + } else { + return $self->DeleteAttribute('NoClone'); + } +} + + +=head2 id + +Returns the current value of id. +(In the database, id is stored as int(11).) + + +=cut + + +=head2 Name + +Returns the current value of Name. +(In the database, Name is stored as varchar(200).) + + + +=head2 SetName VALUE + + +Set Name to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Name will be stored as a varchar(200).) + + +=cut + + +=head2 Type + +Returns the current value of Type. +(In the database, Type is stored as varchar(200).) + + + +=head2 SetType VALUE + + +Set Type to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Type will be stored as a varchar(200).) + + +=cut + + +=head2 RenderType + +Returns the current value of RenderType. +(In the database, RenderType is stored as varchar(64).) + + + +=head2 SetRenderType VALUE + + +Set RenderType to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, RenderType will be stored as a varchar(64).) + + +=cut + + +=head2 MaxValues + +Returns the current value of MaxValues. +(In the database, MaxValues is stored as int(11).) + + + +=head2 SetMaxValues VALUE + + +Set MaxValues to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, MaxValues will be stored as a int(11).) + + +=cut + + +=head2 Pattern + +Returns the current value of Pattern. +(In the database, Pattern is stored as text.) + + + +=head2 SetPattern VALUE + + +Set Pattern to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Pattern will be stored as a text.) + + +=cut + + +=head2 Repeated + +Returns the current value of Repeated. +(In the database, Repeated is stored as smallint(6).) + + + +=head2 SetRepeated VALUE + + +Set Repeated to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Repeated will be stored as a smallint(6).) + + +=cut + + +=head2 BasedOn + +Returns the current value of BasedOn. +(In the database, BasedOn is stored as int(11).) + + + +=head2 SetBasedOn VALUE + + +Set BasedOn to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, BasedOn will be stored as a int(11).) + + +=cut + + +=head2 Description + +Returns the current value of Description. +(In the database, Description is stored as varchar(255).) + + + +=head2 SetDescription VALUE + + +Set Description to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Description will be stored as a varchar(255).) + + +=cut + + +=head2 SortOrder + +Returns the current value of SortOrder. +(In the database, SortOrder is stored as int(11).) + + + +=head2 SetSortOrder VALUE + + +Set SortOrder to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, SortOrder will be stored as a int(11).) + + +=cut + + +=head2 LookupType + +Returns the current value of LookupType. +(In the database, LookupType is stored as varchar(255).) + + + +=head2 SetLookupType VALUE + + +Set LookupType to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, LookupType will be stored as a varchar(255).) + + +=cut + + +=head2 Creator + +Returns the current value of Creator. +(In the database, Creator is stored as int(11).) + + +=cut + + +=head2 Created + +Returns the current value of Created. +(In the database, Created is stored as datetime.) + + +=cut + + +=head2 LastUpdatedBy + +Returns the current value of LastUpdatedBy. +(In the database, LastUpdatedBy is stored as int(11).) + + +=cut + + +=head2 LastUpdated + +Returns the current value of LastUpdated. +(In the database, LastUpdated is stored as datetime.) + + +=cut + + +=head2 Disabled + +Returns the current value of Disabled. +(In the database, Disabled is stored as smallint(6).) + + + +=head2 SetDisabled VALUE + + +Set Disabled to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Disabled will be stored as a smallint(6).) + + +=cut + + + +sub _CoreAccessible { + { + + id => + {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''}, + Name => + {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''}, + Type => + {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''}, + RenderType => + {read => 1, write => 1, sql_type => 12, length => 64, is_blob => 0, is_numeric => 0, type => 'varchar(64)', default => ''}, + MaxValues => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''}, + Pattern => + {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'text', default => ''}, + Repeated => + {read => 1, write => 1, sql_type => 5, length => 6, is_blob => 0, is_numeric => 1, type => 'smallint(6)', default => '0'}, + ValuesClass => + {read => 1, write => 1, sql_type => 12, length => 64, is_blob => 0, is_numeric => 0, type => 'varchar(64)', default => ''}, + BasedOn => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''}, + Description => + {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''}, + SortOrder => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + LookupType => + {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''}, + Creator => + {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Created => + {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + LastUpdatedBy => + {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + LastUpdated => + {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + Disabled => + {read => 1, write => 1, sql_type => 5, length => 6, is_blob => 0, is_numeric => 1, type => 'smallint(6)', default => '0'}, + + } +}; + + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Dashboard/Mailer.pm b/rt/lib/RT/Dashboard/Mailer.pm index eb620e65d..038cf4593 100644 --- a/rt/lib/RT/Dashboard/Mailer.pm +++ b/rt/lib/RT/Dashboard/Mailer.pm @@ -382,9 +382,14 @@ sub BuildEmail { $cid_of{$uri} = time() . $$ . int(rand(1e6)); my ($data, $filename, $mimetype, $encoding) = GetResource($uri); - # downgrade non-text strings, because all strings are utf8 by - # default, which is wrong for non-text strings. - if ( $mimetype !~ m{text/} ) { + # Encode textual data in UTF-8, and downgrade (treat + # codepoints as codepoints, and ensure the UTF-8 flag is + # off) everything else. + my @extra; + if ( $mimetype =~ m{text/} ) { + $data = Encode::encode( "UTF-8", $data ); + @extra = ( Charset => "UTF-8" ); + } else { utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed"); } @@ -396,6 +401,7 @@ sub BuildEmail { Disposition => 'inline', Name => RT::Interface::Email::EncodeToMIME( String => $filename ), 'Content-Id' => $cid_of{$uri}, + @extra, ); return "cid:$cid_of{$uri}"; @@ -409,16 +415,16 @@ sub BuildEmail { ); my $entity = MIME::Entity->build( - From => Encode::encode_utf8($args{From}), - To => Encode::encode_utf8($args{To}), + From => Encode::encode("UTF-8", $args{From}), + To => Encode::encode("UTF-8", $args{To}), Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ), Type => "multipart/mixed", ); $entity->attach( - Data => Encode::encode_utf8($content), Type => 'text/html', Charset => 'UTF-8', + Data => Encode::encode("UTF-8", $content), Disposition => 'inline', Encoding => "base64", ); @@ -547,6 +553,9 @@ sub GetResource { for ($k, $v) { s/%(..)/chr hex $1/ge } + # Decode from bytes to characters + $_ = Encode::decode( "UTF-8", $_ ) for $k, $v; + # no value yet, simple key=value if (!exists $args{$k}) { $args{$k} = $v; diff --git a/rt/lib/RT/EmailParser.pm b/rt/lib/RT/EmailParser.pm index 89f7ea4f9..630730abd 100644 --- a/rt/lib/RT/EmailParser.pm +++ b/rt/lib/RT/EmailParser.pm @@ -299,8 +299,8 @@ sub ParseCcAddressesFromHead { my (@Addresses); - my @ToObjs = Email::Address->parse( $self->Head->get('To') ); - my @CcObjs = Email::Address->parse( $self->Head->get('Cc') ); + my @ToObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('To') ) ); + my @CcObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('Cc') ) ); foreach my $AddrObj ( @ToObjs, @CcObjs ) { my $Address = $AddrObj->address; @@ -618,7 +618,7 @@ sub RescueOutlook { # Add base64 since we've seen examples of double newlines with # this type too. Need an example of a multi-part base64 to # handle that permutation if it exists. - elsif ( $mime->head->get('Content-Transfer-Encoding') =~ m{base64} ) { + elsif ( ($mime->head->get('Content-Transfer-Encoding')||'') =~ m{base64} ) { $text_part = $mime; # Assuming single part, already decoded. } diff --git a/rt/lib/RT/EmailParser.pm.orig b/rt/lib/RT/EmailParser.pm.orig new file mode 100644 index 000000000..89f7ea4f9 --- /dev/null +++ b/rt/lib/RT/EmailParser.pm.orig @@ -0,0 +1,692 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +package RT::EmailParser; + + +use base qw/RT::Base/; + +use strict; +use warnings; + + +use Email::Address; +use MIME::Entity; +use MIME::Head; +use MIME::Parser; +use File::Temp qw/tempdir/; + +=head1 NAME + + RT::EmailParser - helper functions for parsing parts from incoming + email messages + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + + + +=head1 METHODS + +=head2 new + +Returns a new RT::EmailParser object + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + bless ($self, $class); + return $self; +} + + +=head2 SmartParseMIMEEntityFromScalar Message => SCALAR_REF [, Decode => BOOL, Exact => BOOL ] } + +Parse a message stored in a scalar from scalar_ref. + +=cut + +sub SmartParseMIMEEntityFromScalar { + my $self = shift; + my %args = ( Message => undef, Decode => 1, Exact => 0, @_ ); + + eval { + my ( $fh, $temp_file ); + for ( 1 .. 10 ) { + + # on NFS and NTFS, it is possible that tempfile() conflicts + # with other processes, causing a race condition. we try to + # accommodate this by pausing and retrying. + last + if ( $fh, $temp_file ) = + eval { File::Temp::tempfile( UNLINK => 0 ) }; + sleep 1; + } + if ($fh) { + + #thank you, windows + binmode $fh; + $fh->autoflush(1); + print $fh $args{'Message'}; + close($fh); + if ( -f $temp_file ) { + + # We have to trust the temp file's name -- untaint it + $temp_file =~ /(.*)/; + my $entity = $self->ParseMIMEEntityFromFile( $1, $args{'Decode'}, $args{'Exact'} ); + unlink($1); + return $entity; + } + } + }; + + #If for some reason we weren't able to parse the message using a temp file + # try it with a scalar + if ( $@ || !$self->Entity ) { + return $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'}, $args{'Exact'} ); + } + +} + + +=head2 ParseMIMEEntityFromSTDIN + +Parse a message from standard input + +=cut + +sub ParseMIMEEntityFromSTDIN { + my $self = shift; + return $self->ParseMIMEEntityFromFileHandle(\*STDIN, @_); +} + +=head2 ParseMIMEEntityFromScalar $message + +Takes either a scalar or a reference to a scalar which contains a stringified MIME message. +Parses it. + +Returns true if it wins. +Returns false if it loses. + +=cut + +sub ParseMIMEEntityFromScalar { + my $self = shift; + return $self->_ParseMIMEEntity( shift, 'parse_data', @_ ); +} + +=head2 ParseMIMEEntityFromFilehandle *FH + +Parses a mime entity from a filehandle passed in as an argument + +=cut + +sub ParseMIMEEntityFromFileHandle { + my $self = shift; + return $self->_ParseMIMEEntity( shift, 'parse', @_ ); +} + +=head2 ParseMIMEEntityFromFile + +Parses a mime entity from a filename passed in as an argument + +=cut + +sub ParseMIMEEntityFromFile { + my $self = shift; + return $self->_ParseMIMEEntity( shift, 'parse_open', @_ ); +} + + +sub _ParseMIMEEntity { + my $self = shift; + my $message = shift; + my $method = shift; + my $postprocess = (@_ ? shift : 1); + my $exact = shift; + + # Create a new parser object: + my $parser = MIME::Parser->new(); + $self->_SetupMIMEParser($parser); + $parser->decode_bodies(0) if $exact; + + # TODO: XXX 3.0 we really need to wrap this in an eval { } + unless ( $self->{'entity'} = $parser->$method($message) ) { + $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages"); + # Try again, this time without extracting nested messages + $parser->extract_nested_messages(0); + unless ( $self->{'entity'} = $parser->$method($message) ) { + $RT::Logger->crit("couldn't parse MIME stream"); + return ( undef); + } + } + + $self->_PostProcessNewEntity if $postprocess; + + return $self->{'entity'}; +} + +sub _DecodeBodies { + my $self = shift; + return unless $self->{'entity'}; + + my @parts = $self->{'entity'}->parts_DFS; + $self->_DecodeBody($_) foreach @parts; +} + +sub _DecodeBody { + my $self = shift; + my $entity = shift; + + my $old = $entity->bodyhandle or return; + return unless $old->is_encoded; + + require MIME::Decoder; + my $encoding = $entity->head->mime_encoding; + my $decoder = MIME::Decoder->new($encoding); + unless ( $decoder ) { + $RT::Logger->error("Couldn't find decoder for '$encoding', switching to binary"); + $old->is_encoded(0); + return; + } + + require MIME::Body; + # XXX: use InCore for now, but later must switch to files + my $new = MIME::Body::InCore->new(); + $new->binmode(1); + $new->is_encoded(0); + + my $source = $old->open('r') or die "couldn't open body: $!"; + my $destination = $new->open('w') or die "couldn't open body: $!"; + { + local $@; + eval { $decoder->decode($source, $destination) }; + $RT::Logger->error($@) if $@; + } + $source->close or die "can't close: $!"; + $destination->close or die "can't close: $!"; + + $entity->bodyhandle( $new ); +} + +=head2 _PostProcessNewEntity + +cleans up and postprocesses a newly parsed MIME Entity + +=cut + +sub _PostProcessNewEntity { + my $self = shift; + + #Now we've got a parsed mime object. + + # Unfold headers that are have embedded newlines + # Better do this before conversion or it will break + # with multiline encoded Subject (RFC2047) (fsck.com #5594) + $self->Head->unfold; + + # try to convert text parts into utf-8 charset + RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8'); +} + +=head2 ParseCcAddressesFromHead HASHREF + +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 RT->Config->Get('RTAddressRegexp') matches. + +=cut + +sub ParseCcAddressesFromHead { + my $self = shift; + my %args = ( + QueueObj => undef, + CurrentUser => undef, + @_ + ); + + my (@Addresses); + + my @ToObjs = Email::Address->parse( $self->Head->get('To') ); + my @CcObjs = Email::Address->parse( $self->Head->get('Cc') ); + + foreach my $AddrObj ( @ToObjs, @CcObjs ) { + my $Address = $AddrObj->address; + my $user = RT::User->new(RT->SystemUser); + $Address = $user->CanonicalizeEmailAddress($Address); + next if lc $args{'CurrentUser'}->EmailAddress eq lc $Address; + next if $self->IsRTAddress($Address); + + push ( @Addresses, $Address ); + } + return (@Addresses); +} + + +=head2 IsRTaddress ADDRESS + +Takes a single parameter, an email address. +Returns true if that address matches the C<RTAddressRegexp> config option. +Returns false, otherwise. + + +=cut + +sub IsRTAddress { + my $self = shift; + my $address = shift; + + if ( my $address_re = RT->Config->Get('RTAddressRegexp') ) { + return $address =~ /$address_re/i ? 1 : undef; + } + + # we don't warn here, but do in config check + if ( my $correspond_address = RT->Config->Get('CorrespondAddress') ) { + return 1 if lc $correspond_address eq lc $address; + } + if ( my $comment_address = RT->Config->Get('CommentAddress') ) { + return 1 if lc $comment_address eq lc $address; + } + + my $queue = RT::Queue->new( RT->SystemUser ); + $queue->LoadByCols( CorrespondAddress => $address ); + return 1 if $queue->id; + + $queue->LoadByCols( CommentAddress => $address ); + return 1 if $queue->id; + + return undef; +} + + +=head2 CullRTAddresses ARRAY + +Takes a single argument, an array of email addresses. +Returns the same array with any IsRTAddress()es weeded out. + + +=cut + +sub CullRTAddresses { + my $self = shift; + my @addresses = (@_); + + return grep { !$self->IsRTAddress($_) } @addresses; +} + + + + + +# LookupExternalUserInfo is a site-definable method for synchronizing +# incoming users with an external data source. +# +# This routine takes a tuple of EmailAddress and FriendlyName +# EmailAddress is the user's email address, ususally taken from +# an email message's From: header. +# FriendlyName is a freeform string, ususally taken from the "comment" +# portion of an email message's From: header. +# +# If you define an AutoRejectRequest template, RT will use this +# template for the rejection message. + + +=head2 LookupExternalUserInfo + + LookupExternalUserInfo is a site-definable method for synchronizing + incoming users with an external data source. + + This routine takes a tuple of EmailAddress and FriendlyName + EmailAddress is the user's email address, ususally taken from + an email message's From: header. + FriendlyName is a freeform string, ususally taken from the "comment" + portion of an email message's From: header. + + It returns (FoundInExternalDatabase, ParamHash); + + FoundInExternalDatabase must be set to 1 before return if the user + was found in the external database. + + ParamHash is a Perl parameter hash which can contain at least the + following fields. These fields are used to populate RT's users + database when the user is created. + + EmailAddress is the email address that RT should use for this user. + Name is the 'Name' attribute RT should use for this user. + 'Name' is used for things like access control and user lookups. + RealName is what RT should display as the user's name when displaying + 'friendly' names + +=cut + +sub LookupExternalUserInfo { + my $self = shift; + my $EmailAddress = shift; + my $RealName = shift; + + my $FoundInExternalDatabase = 1; + my %params; + + #Name is the RT username you want to use for this user. + $params{'Name'} = $EmailAddress; + $params{'EmailAddress'} = $EmailAddress; + $params{'RealName'} = $RealName; + + return ($FoundInExternalDatabase, %params); +} + +=head2 Head + +Return the parsed head from this message + +=cut + +sub Head { + my $self = shift; + return $self->Entity->head; +} + +=head2 Entity + +Return the parsed Entity from this message + +=cut + +sub Entity { + my $self = shift; + return $self->{'entity'}; +} + + + +=head2 _SetupMIMEParser $parser + +A private instance method which sets up a mime parser to do its job + +=cut + + + ## TODO: Does it make sense storing to disk at all? After all, we + ## need to put each msg as an in-core scalar before saving it to + ## the database, don't we? + + ## At the same time, we should make sure that we nuke attachments + ## Over max size and return them + +sub _SetupMIMEParser { + my $self = shift; + my $parser = shift; + + # Set up output directory for files; we use $RT::VarPath instead + # of File::Spec->tmpdir (e.g., /tmp) beacuse it isn't always + # writable. + my $tmpdir; + if ( -w $RT::VarPath ) { + $tmpdir = File::Temp::tempdir( DIR => $RT::VarPath, CLEANUP => 1 ); + } elsif (-w File::Spec->tmpdir) { + $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 ); + } else { + $RT::Logger->crit("Neither the RT var directory ($RT::VarPath) nor the system tmpdir (@{[File::Spec->tmpdir]}) are writable; falling back to in-memory parsing!"); + } + + #If someone includes a message, extract it + $parser->extract_nested_messages(1); + $parser->extract_uuencode(1); ### default is false + + if ($tmpdir) { + # If we got a writable tmpdir, write to disk + push ( @{ $self->{'AttachmentDirs'} ||= [] }, $tmpdir ); + $parser->output_dir($tmpdir); + $parser->filer->ignore_filename(1); + + # Set up the prefix for files with auto-generated names: + $parser->output_prefix("part"); + + # From the MIME::Parser docs: + # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope" + # Turns out that the default is to recycle tempfiles + # Temp files should never be recycled, especially when running under perl taint checking + + $parser->tmp_recycling(0) if $parser->can('tmp_recycling'); + } else { + # Otherwise, fall back to storing it in memory + $parser->output_to_core(1); + $parser->tmp_to_core(1); + $parser->use_inner_files(1); + } + +} + +=head2 ParseEmailAddress string + +Returns a list of Email::Address objects +Works around the bug that Email::Address 1.889 and earlier +doesn't handle local-only email addresses (when users pass +in just usernames on the RT system in fields that expect +Email Addresses) + +We don't handle the case of +bob, fred@bestpractical.com +because we don't want to fail parsing +bob, "Falcone, Fred" <fred@bestpractical.com> +The next release of Email::Address will have a new method +we can use that removes the bandaid + +=cut + +sub ParseEmailAddress { + my $self = shift; + my $address_string = shift; + + $address_string =~ s/^\s+|\s+$//g; + + my @addresses; + # if it looks like a username / local only email + if ($address_string !~ /@/ && $address_string =~ /^\w+$/) { + my $user = RT::User->new( RT->SystemUser ); + my ($id, $msg) = $user->Load($address_string); + if ($id) { + push @addresses, Email::Address->new($user->Name,$user->EmailAddress); + } else { + $RT::Logger->error("Unable to parse an email address from $address_string: $msg"); + } + } else { + @addresses = Email::Address->parse($address_string); + } + + $self->CleanupAddresses(@addresses); + + return @addresses; + +} + +=head2 CleanupAddresses ARRAY + +Massages an array of L<Email::Address> objects to make their email addresses +more palatable. + +Currently this strips off surrounding single quotes around C<< ->address >> and +B<< modifies the L<Email::Address> objects in-place >>. + +Returns the list of objects for convienence in C<map>/C<grep> chains. + +=cut + +sub CleanupAddresses { + my $self = shift; + + for my $addr (@_) { + next unless defined $addr; + # Outlook sometimes sends addresses surrounded by single quotes; + # clean them all up + if ((my $email = $addr->address) =~ s/^'(.+)'$/$1/) { + $addr->address($email); + } + } + return @_; +} + +=head2 RescueOutlook + +Outlook 2007/2010 have a bug when you write an email with the html format. +it will send a 'multipart/alternative' with both 'text/plain' and 'text/html' +in it. it's cool to have a 'text/plain' part, but the problem is the part is +not so right: all the "\n" in your main message will become "\n\n" :/ + +this method will fix this bug, i.e. replaces "\n\n" to "\n". +return 1 if it does find the problem in the entity and get it fixed. + +=cut + + +sub RescueOutlook { + my $self = shift; + my $mime = $self->Entity(); + return unless $mime && $self->LooksLikeMSEmail($mime); + + my $text_part; + if ( $mime->head->get('Content-Type') =~ m{multipart/mixed} ) { + my $first = $mime->parts(0); + if ( $first && $first->head->get('Content-Type') =~ m{multipart/alternative} ) + { + my $inner_first = $first->parts(0); + if ( $inner_first && $inner_first->head->get('Content-Type') =~ m{text/plain} ) + { + $text_part = $inner_first; + } + } + } + elsif ( $mime->head->get('Content-Type') =~ m{multipart/alternative} ) { + my $first = $mime->parts(0); + if ( $first && $first->head->get('Content-Type') =~ m{text/plain} ) { + $text_part = $first; + } + } + + # Add base64 since we've seen examples of double newlines with + # this type too. Need an example of a multi-part base64 to + # handle that permutation if it exists. + elsif ( $mime->head->get('Content-Transfer-Encoding') =~ m{base64} ) { + $text_part = $mime; # Assuming single part, already decoded. + } + + if ($text_part) { + + # use the unencoded string + my $content = $text_part->bodyhandle->as_string; + if ( $content =~ s/\n\n/\n/g ) { + + # Outlook puts a space on extra newlines, remove it + $content =~ s/\ +$//mg; + + # only write only if we did change the content + if ( my $io = $text_part->open("w") ) { + $io->print($content); + $io->close; + $RT::Logger->debug( + "Removed extra newlines from MS Outlook message."); + return 1; + } + else { + $RT::Logger->error("Can't write to body to fix newlines"); + } + } + } + + return; +} + +=head1 LooksLikeMSEmail + +Try to determine if the current email may have +come from MS Outlook or gone through Exchange, and therefore +may have extra newlines added. + +=cut + +sub LooksLikeMSEmail { + my $self = shift; + my $mime = shift; + + my $mailer = $mime->head->get('X-Mailer'); + + # 12.0 is outlook 2007, 14.0 is 2010 + return 1 if ( $mailer && $mailer =~ /Microsoft(?:.*?)Outlook 1[2-4]\./ ); + + if ( RT->Config->Get('CheckMoreMSMailHeaders') ) { + + # Check for additional headers that might + # indicate this came from Outlook or through Exchange. + # A sample we received had the headers X-MS-Has-Attach: and + # X-MS-Tnef-Correlator: and both had no value. + + my @tags = $mime->head->tags(); + return 1 if grep { /^X-MS-/ } @tags; + } + + return 0; # Doesn't look like MS email. +} + +sub DESTROY { + my $self = shift; + File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1) + if $self->{'AttachmentDirs'}; +} + + + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Generated.pm b/rt/lib/RT/Generated.pm index f4fb88d8f..2f46d4886 100644 --- a/rt/lib/RT/Generated.pm +++ b/rt/lib/RT/Generated.pm @@ -50,7 +50,7 @@ package RT; use warnings; use strict; -our $VERSION = '4.0.21'; +our $VERSION = '4.0.22'; diff --git a/rt/lib/RT/I18N.pm b/rt/lib/RT/I18N.pm index bc267e438..11cd5f120 100644 --- a/rt/lib/RT/I18N.pm +++ b/rt/lib/RT/I18N.pm @@ -62,7 +62,6 @@ use Locale::Maketext 1.04; use Locale::Maketext::Lexicon 0.25; use base 'Locale::Maketext::Fuzzy'; -use Encode; use MIME::Entity; use MIME::Head; use File::Glob; @@ -231,7 +230,7 @@ sub SetMIMEEntityToEncoding { ); # If this is a textual entity, we'd need to preserve its original encoding - $head->replace( "X-RT-Original-Encoding" => $charset ) + $head->replace( "X-RT-Original-Encoding" => Encode::encode( "UTF-8", $charset ) ) if $head->mime_attr('content-type.charset') or IsTextualContentType($head->mime_type); return unless IsTextualContentType($head->mime_type); @@ -240,13 +239,12 @@ sub SetMIMEEntityToEncoding { if ( $body && ($enc ne $charset || $enc =~ /^utf-?8(?:-strict)?$/i) ) { my $string = $body->as_string or return; + RT::Util::assert_bytes($string); $RT::Logger->debug( "Converting '$charset' to '$enc' for " . $head->mime_type . " - " - . ( $head->get('subject') || 'Subjectless message' ) ); + . ( Encode::decode("UTF-8",$head->get('subject')) || 'Subjectless message' ) ); - # NOTE:: see the comments at the end of the sub. - Encode::_utf8_off($string); Encode::from_to( $string, $charset => $enc ); my $new_body = MIME::Body::InCore->new($string); @@ -259,30 +257,11 @@ sub SetMIMEEntityToEncoding { } } -# NOTES: Why Encode::_utf8_off before Encode::from_to -# -# All the strings in RT are utf-8 now. Quotes from Encode POD: -# -# [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK]) -# ... The data in $octets must be encoded as octets and not as -# characters in Perl's internal format. ... -# -# Not turning off the UTF-8 flag in the string will prevent the string -# from conversion. - - - =head2 DecodeMIMEWordsToUTF8 $raw An utility method which mimics MIME::Words::decode_mimewords, but only -limited functionality. This function returns an utf-8 string. - -It returns the decoded string, or the original string if it's not -encoded. Since the subroutine converts specified string into utf-8 -charset, it should not alter a subject written in English. - -Why not use MIME::Words directly? Because it fails in RT when I -tried. Maybe it's ok now. +limited functionality. Despite its name, this function returns the +bytes of the string, in UTF-8. =cut @@ -563,13 +542,13 @@ sub SetMIMEHeadToEncoding { return if $charset eq $enc and $preserve_words; + RT::Util::assert_bytes( $head->as_string ); foreach my $tag ( $head->tags ) { next unless $tag; # seen in wild: headers with no name my @values = $head->get_all($tag); $head->delete($tag); foreach my $value (@values) { if ( $charset ne $enc || $enc =~ /^utf-?8(?:-strict)?$/i ) { - Encode::_utf8_off($value); Encode::from_to( $value, $charset => $enc ); } $value = DecodeMIMEWordsToEncoding( $value, $enc, $tag ) diff --git a/rt/lib/RT/I18N/de.pm b/rt/lib/RT/I18N/de.pm new file mode 100644 index 000000000..3a40a7f9e --- /dev/null +++ b/rt/lib/RT/I18N/de.pm @@ -0,0 +1,61 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +use strict; +use warnings; + +package RT::I18N::de; +use base 'RT::I18N'; + +sub init { + $_[0]->{numf_comma} = 1; +} + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/I18N/fr.pm b/rt/lib/RT/I18N/fr.pm new file mode 100644 index 000000000..904b84199 --- /dev/null +++ b/rt/lib/RT/I18N/fr.pm @@ -0,0 +1,68 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +use strict; +use warnings; + +package RT::I18N::fr; +use base 'RT::I18N'; + +use strict; +use warnings; + +sub numf { + my ($handle, $num) = @_[0,1]; + my $fr_num = $handle->SUPER::numf($num); + # French prefer to print 1000 as 1(nbsp)000 rather than 1,000 + $fr_num =~ tr<.,><,\x{A0}>; + return $fr_num; +} + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Interface/Email.pm b/rt/lib/RT/Interface/Email.pm index 74120ba07..a4826ad36 100755 --- a/rt/lib/RT/Interface/Email.pm +++ b/rt/lib/RT/Interface/Email.pm @@ -114,7 +114,7 @@ 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") || ""; + my $RTLoop = Encode::decode( "UTF-8", $head->get("X-RT-Loop-Prevention") || "" ); chomp ($RTLoop); # remove that newline if ( $RTLoop eq RT->Config->Get('rtname') ) { return 1; @@ -253,22 +253,27 @@ sub MailError { # the colons are necessary to make ->build include non-standard headers my %entity_args = ( Type => "multipart/mixed", - From => $args{'From'}, - Bcc => $args{'Bcc'}, - To => $args{'To'}, - Subject => $args{'Subject'}, - 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'), + From => Encode::encode( "UTF-8", $args{'From'} ), + Bcc => Encode::encode( "UTF-8", $args{'Bcc'} ), + To => Encode::encode( "UTF-8", $args{'To'} ), + Subject => EncodeToMIME( String => $args{'Subject'} ), + 'X-RT-Loop-Prevention:' => Encode::encode( "UTF-8", RT->Config->Get('rtname') ), ); # only set precedence if the sysadmin wants us to if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) { - $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence'); + $entity_args{'Precedence:'} = + Encode::encode( "UTF-8", RT->Config->Get('DefaultErrorMailPrecedence') ); } my $entity = MIME::Entity->build(%entity_args); SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} ); - $entity->attach( Data => $args{'Explanation'} . "\n" ); + $entity->attach( + Type => "text/plain", + Charset => "UTF-8", + Data => Encode::encode( "UTF-8", $args{'Explanation'} . "\n" ), + ); if ( $args{'MIMEObj'} ) { $args{'MIMEObj'}->sync_headers; @@ -276,7 +281,7 @@ sub MailError { } if ( $args{'Attach'} ) { - $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' ); + $entity->attach( Data => Encode::encode( "UTF-8", $args{'Attach'} ), Type => 'message/rfc822' ); } @@ -374,7 +379,7 @@ sub SendEmail { return 0; } - my $msgid = $args{'Entity'}->head->get('Message-ID') || ''; + my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' ); chomp $msgid; # If we don't have any recipients to send to, don't send a message; @@ -411,7 +416,7 @@ sub SendEmail { require RT::Date; my $date = RT::Date->new( RT->SystemUser ); $date->SetToNow; - $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) ); + $args{'Entity'}->head->set( 'Date', Encode::encode( "UTF-8", $date->RFC2822( Timezone => 'server' ) ) ); } my $mail_command = RT->Config->Get('MailCommand'); @@ -514,12 +519,13 @@ sub SendEmail { # 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); + my @recipients = map $_->address, map + Email::Address->parse(Encode::decode("UTF-8", $head->get($_))), + qw(To Cc Bcc); $head->delete('Bcc'); my $sender = RT->Config->Get('SMTPFrom') - || $args{'Entity'}->head->get('From'); + || Encode::decode( "UTF-8", $args{'Entity'}->head->get('From') ); chomp $sender; my $status = $smtp->mail( $sender ) @@ -624,10 +630,10 @@ sub SendEmailUsingTemplate { return -1; } - $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) ) + $mail->head->set( $_ => Encode::encode( "UTF-8", $args{ $_ } ) ) foreach grep defined $args{$_}, qw(To Cc Bcc From); - $mail->head->set( $_ => $args{ExtraHeaders}{$_} ) + $mail->head->set( $_ => Encode::encode( "UTF-8", $args{ExtraHeaders}{$_} ) ) foreach keys %{ $args{ExtraHeaders} }; SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} ); @@ -760,8 +766,9 @@ sub SendForward { . $txn->id ." of a ticket #". $txn->ObjectId; } $mail = MIME::Entity->build( - Type => 'text/plain', - Data => $description, + Type => 'text/plain', + Charset => "UTF-8", + Data => Encode::encode( "UTF-8", $description ), ); } @@ -844,7 +851,7 @@ sub SignEncrypt { ); return 1 unless $args{'Sign'} || $args{'Encrypt'}; - my $msgid = $args{'Entity'}->head->get('Message-ID') || ''; + my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' ); chomp $msgid; $RT::Logger->debug("$msgid Signing message") if $args{'Sign'}; @@ -980,9 +987,6 @@ sub EncodeToMIME { $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, '' ); @@ -1087,7 +1091,8 @@ sub ParseCcAddressesFromHead { && !IgnoreCcAddress( $_ ) } map lc $user->CanonicalizeEmailAddress( $_->address ), - map RT::EmailParser->CleanupAddresses( Email::Address->parse( $args{'Head'}->get( $_ ) ) ), + map RT::EmailParser->CleanupAddresses( Email::Address->parse( + Encode::decode( "UTF-8", $args{'Head'}->get( $_ ) ) ) ), qw(To Cc); } @@ -1125,7 +1130,7 @@ sub ParseSenderAddressFromHead { #Figure out who's sending this message. foreach my $header ( @sender_headers ) { - my $addr_line = $head->get($header) || next; + my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next; my ($addr, $name) = ParseAddressFromHeader( $addr_line ); # only return if the address is not empty return ($addr, $name, @errors) if $addr; @@ -1153,7 +1158,7 @@ sub ParseErrorsToAddressFromHead { foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) { # If there's a header of that name - my $headerobj = $head->get($header); + my $headerobj = Encode::decode( "UTF-8", $head->get($header) ); if ($headerobj) { my ( $addr, $name ) = ParseAddressFromHeader($headerobj); @@ -1198,9 +1203,9 @@ sub DeleteRecipientsFromHead { my %skip = map { lc $_ => 1 } @_; foreach my $field ( qw(To Cc Bcc) ) { - $head->set( $field => + $head->set( $field => Encode::encode( "UTF-8", join ', ', map $_->format, grep !$skip{ lc $_->address }, - Email::Address->parse( $head->get( $field ) ) + Email::Address->parse( Encode::decode( "UTF-8", $head->get( $field ) ) ) ) ); } } @@ -1233,7 +1238,7 @@ sub SetInReplyTo { my $get_header = sub { my @res; if ( $args{'InReplyTo'}->isa('MIME::Entity') ) { - @res = $args{'InReplyTo'}->head->get( shift ); + @res = map {Encode::decode("UTF-8", $_)} $args{'InReplyTo'}->head->get( shift ); } else { @res = $args{'InReplyTo'}->GetHeader( shift ) || ''; } @@ -1256,14 +1261,14 @@ sub SetInReplyTo { if @references > 10; my $mail = $args{'Message'}; - $mail->head->set( 'In-Reply-To' => Encode::encode_utf8(join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid; - $mail->head->set( 'References' => Encode::encode_utf8(join ' ', @references) ); + $mail->head->set( 'In-Reply-To' => Encode::encode( "UTF-8", join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid; + $mail->head->set( 'References' => Encode::encode( "UTF-8", join ' ', @references) ); } sub ExtractTicketId { my $entity = shift; - my $subject = $entity->head->get('Subject') || ''; + my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') || '' ); chomp $subject; return ParseTicketId( $subject ); } @@ -1468,14 +1473,14 @@ sub Gateway { my $head = $Message->head; my $ErrorsTo = ParseErrorsToAddressFromHead( $head ); my $Sender = (ParseSenderAddressFromHead( $head ))[0]; - my $From = $head->get("From"); + my $From = Encode::decode( "UTF-8", $head->get("From") ); chomp $From if defined $From; - my $MessageId = $head->get('Message-ID') + my $MessageId = Encode::decode( "UTF-8", $head->get('Message-ID') ) || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>'; #Pull apart the subject line - my $Subject = $head->get('Subject') || ''; + my $Subject = Encode::decode( "UTF-8", $head->get('Subject') || ''); chomp $Subject; # Lets check for mail loops of various sorts. @@ -1498,7 +1503,7 @@ sub Gateway { $args{'ticket'} ||= ExtractTicketId( $Message ); # ExtractTicketId may have been overridden, and edited the Subject - my $NewSubject = $Message->head->get('Subject'); + my $NewSubject = Encode::decode( "UTF-8", $Message->head->get('Subject') ); chomp $NewSubject; $SystemTicket = RT::Ticket->new( RT->SystemUser ); @@ -1746,7 +1751,7 @@ sub _RunUnsafeAction { @_ ); - my $From = $args{Message}->head->get("From"); + my $From = Encode::decode( "UTF-8", $args{Message}->head->get("From") ); if ( $args{'Action'} =~ /^take$/i ) { my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id ); @@ -1902,7 +1907,7 @@ sub _HandleMachineGeneratedMail { # to the scrip. We might want to notify nobody. Or just # the RT Owner. Or maybe all Privileged watchers. my ( $Sender, $junk ) = ParseSenderAddressFromHead($head); - $head->replace( 'RT-Squelch-Replies-To', $Sender ); + $head->replace( 'RT-Squelch-Replies-To', Encode::encode("UTF-8", $Sender ) ); $head->replace( 'RT-DetectedAutoGenerated', 'true' ); } return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop ); diff --git a/rt/lib/RT/Interface/Email.pm.orig b/rt/lib/RT/Interface/Email.pm.orig new file mode 100755 index 000000000..74120ba07 --- /dev/null +++ b/rt/lib/RT/Interface/Email.pm.orig @@ -0,0 +1,1944 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +package RT::Interface::Email; + +use strict; +use warnings; + +use Email::Address; +use MIME::Entity; +use RT::EmailParser; +use File::Temp; +use UNIVERSAL::require; +use Mail::Mailer (); +use Text::ParseWords qw/shellwords/; + +BEGIN { + use base 'Exporter'; + use vars qw ( @EXPORT_OK); + + # set the version for version checking + our $VERSION = 2.0; + + # your exported package globals go here, + # as well as any optionally exported functions + @EXPORT_OK = qw( + &CreateUser + &GetMessageContent + &CheckForLoops + &CheckForSuspiciousSender + &CheckForAutoGenerated + &CheckForBounce + &MailError + &ParseCcAddressesFromHead + &ParseSenderAddressFromHead + &ParseErrorsToAddressFromHead + &ParseAddressFromHeader + &Gateway); + +} + +=head1 NAME + + RT::Interface::Email - helper functions for parsing email sent to RT + +=head1 SYNOPSIS + + use lib "!!RT_LIB_PATH!!"; + use lib "!!RT_ETC_PATH!!"; + + use RT::Interface::Email qw(Gateway CreateUser); + +=head1 DESCRIPTION + + + + +=head1 METHODS + +=head2 CheckForLoops HEAD + +Takes a HEAD object of L<MIME::Head> class and returns true if the +message's been sent by this RT instance. Uses "X-RT-Loop-Prevention" +field of the head for test. + +=cut + +sub CheckForLoops { + my $head = shift; + + # If this instance of RT sent it our, we don't want to take it in + my $RTLoop = $head->get("X-RT-Loop-Prevention") || ""; + chomp ($RTLoop); # remove that newline + if ( $RTLoop eq RT->Config->Get('rtname') ) { + return 1; + } + + # TODO: We might not trap the case where RT instance A sends a mail + # to RT instance B which sends a mail to ... + return undef; +} + +=head2 CheckForSuspiciousSender HEAD + +Takes a HEAD object of L<MIME::Head> class and returns true if sender +is suspicious. Suspicious means mailer daemon. + +See also L</ParseSenderAddressFromHead>. + +=cut + +sub CheckForSuspiciousSender { + my $head = shift; + + #if it's from a postmaster or mailer daemon, it's likely a bounce. + + #TODO: better algorithms needed here - there is no standards for + #bounces, so it's very difficult to separate them from anything + #else. At the other hand, the Return-To address is only ment to be + #used as an error channel, we might want to put up a separate + #Return-To address which is treated differently. + + #TODO: search through the whole email and find the right Ticket ID. + + my ( $From, $junk ) = ParseSenderAddressFromHead($head); + + # If unparseable (non-ASCII), $From can come back undef + return undef if not defined $From; + + if ( ( $From =~ /^mailer-daemon\@/i ) + or ( $From =~ /^postmaster\@/i ) + or ( $From eq "" )) + { + return (1); + + } + + return undef; +} + +=head2 CheckForAutoGenerated HEAD + +Takes a HEAD object of L<MIME::Head> class and returns true if message +is autogenerated. Checks 'Precedence' and 'X-FC-Machinegenerated' +fields of the head in tests. + +=cut + +sub CheckForAutoGenerated { + my $head = shift; + + my $Precedence = $head->get("Precedence") || ""; + if ( $Precedence =~ /^(bulk|junk)/i ) { + return (1); + } + + # Per RFC3834, any Auto-Submitted header which is not "no" means + # it is auto-generated. + my $AutoSubmitted = $head->get("Auto-Submitted") || ""; + if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) { + return (1); + } + + # First Class mailer uses this as a clue. + my $FCJunk = $head->get("X-FC-Machinegenerated") || ""; + if ( $FCJunk =~ /^true/i ) { + return (1); + } + + return (0); +} + + +sub CheckForBounce { + my $head = shift; + + my $ReturnPath = $head->get("Return-path") || ""; + return ( $ReturnPath =~ /<>/ ); +} + + +=head2 MailError PARAM HASH + +Sends an error message. Takes a param hash: + +=over 4 + +=item From - sender's address, by default is 'CorrespondAddress'; + +=item To - recipient, by default is 'OwnerEmail'; + +=item Bcc - optional Bcc recipients; + +=item Subject - subject of the message, default is 'There has been an error'; + +=item Explanation - main content of the error, default value is 'Unexplained error'; + +=item MIMEObj - optional MIME entity that's attached to the error mail, as well we +add 'In-Reply-To' field to the error that points to this message. + +=item Attach - optional text that attached to the error as 'message/rfc822' part. + +=item LogLevel - log level under which we should write the subject and +explanation message into the log, by default we log it as critical. + +=back + +=cut + +sub MailError { + my %args = ( + To => RT->Config->Get('OwnerEmail'), + Bcc => undef, + From => RT->Config->Get('CorrespondAddress'), + Subject => 'There has been an error', + Explanation => 'Unexplained error', + MIMEObj => undef, + Attach => undef, + LogLevel => 'crit', + @_ + ); + + $RT::Logger->log( + level => $args{'LogLevel'}, + message => "$args{Subject}: $args{'Explanation'}", + ) if $args{'LogLevel'}; + + # the colons are necessary to make ->build include non-standard headers + my %entity_args = ( + Type => "multipart/mixed", + From => $args{'From'}, + Bcc => $args{'Bcc'}, + To => $args{'To'}, + Subject => $args{'Subject'}, + 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'), + ); + + # only set precedence if the sysadmin wants us to + if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) { + $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence'); + } + + my $entity = MIME::Entity->build(%entity_args); + SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} ); + + $entity->attach( Data => $args{'Explanation'} . "\n" ); + + if ( $args{'MIMEObj'} ) { + $args{'MIMEObj'}->sync_headers; + $entity->add_part( $args{'MIMEObj'} ); + } + + if ( $args{'Attach'} ) { + $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' ); + + } + + SendEmail( Entity => $entity, Bounce => 1 ); +} + + +=head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ] + +Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using +RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a +true value, the message will be marked as an autogenerated error, if +possible. Sets Date field of the head to now if it's not set. + +If the C<X-RT-Squelch> header is set to any true value, the mail will +not be sent. One use is to let extensions easily cancel outgoing mail. + +Ticket and Transaction arguments are optional. If Transaction is +specified and Ticket is not then ticket of the transaction is +used, but only if the transaction belongs to a ticket. + +Returns 1 on success, 0 on error or -1 if message has no recipients +and hasn't been sent. + +=head3 Signing and Encrypting + +This function as well signs and/or encrypts the message according to +headers of a transaction's attachment or properties of a ticket's queue. +To get full access to the configuration Ticket and/or Transaction +arguments must be provided, but you can force behaviour using Sign +and/or Encrypt arguments. + +The following precedence of arguments are used to figure out if +the message should be encrypted and/or signed: + +* if Sign or Encrypt argument is defined then its value is used + +* else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt +header field then it's value is used + +* else properties of a queue of the Ticket are used. + +=cut + +sub WillSignEncrypt { + my %args = @_; + my $attachment = delete $args{Attachment}; + my $ticket = delete $args{Ticket}; + + if ( not RT->Config->Get('GnuPG')->{'Enable'} ) { + $args{Sign} = $args{Encrypt} = 0; + return wantarray ? %args : 0; + } + + for my $argument ( qw(Sign Encrypt) ) { + next if defined $args{ $argument }; + + if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) { + $args{$argument} = $attachment->GetHeader("X-RT-$argument"); + } elsif ( $ticket and $argument eq "Encrypt" ) { + $args{Encrypt} = $ticket->QueueObj->Encrypt(); + } elsif ( $ticket and $argument eq "Sign" ) { + # Note that $queue->Sign is UI-only, and that all + # UI-generated messages explicitly set the X-RT-Crypt header + # to 0 or 1; thus this path is only taken for messages + # generated _not_ via the web UI. + $args{Sign} = $ticket->QueueObj->SignAuto(); + } + } + + return wantarray ? %args : ($args{Sign} || $args{Encrypt}); +} + +sub SendEmail { + my (%args) = ( + Entity => undef, + Bounce => 0, + Ticket => undef, + Transaction => undef, + @_, + ); + + my $TicketObj = $args{'Ticket'}; + my $TransactionObj = $args{'Transaction'}; + + foreach my $arg( qw(Entity Bounce) ) { + next unless defined $args{ lc $arg }; + + $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead"); + $args{ $arg } = delete $args{ lc $arg }; + } + + unless ( $args{'Entity'} ) { + $RT::Logger->crit( "Could not send mail without 'Entity' object" ); + return 0; + } + + my $msgid = $args{'Entity'}->head->get('Message-ID') || ''; + chomp $msgid; + + # If we don't have any recipients to send to, don't send a message; + unless ( $args{'Entity'}->head->get('To') + || $args{'Entity'}->head->get('Cc') + || $args{'Entity'}->head->get('Bcc') ) + { + $RT::Logger->info( $msgid . " No recipients found. Not sending." ); + return -1; + } + + if ($args{'Entity'}->head->get('X-RT-Squelch')) { + $RT::Logger->info( $msgid . " Squelch header found. Not sending." ); + return -1; + } + + if ( $TransactionObj && !$TicketObj + && $TransactionObj->ObjectType eq 'RT::Ticket' ) + { + $TicketObj = $TransactionObj->Object; + } + + if ( RT->Config->Get('GnuPG')->{'Enable'} ) { + %args = WillSignEncrypt( + %args, + Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef, + Ticket => $TicketObj, + ); + my $res = SignEncrypt( %args ); + return $res unless $res > 0; + } + + unless ( $args{'Entity'}->head->get('Date') ) { + require RT::Date; + my $date = RT::Date->new( RT->SystemUser ); + $date->SetToNow; + $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) ); + } + + my $mail_command = RT->Config->Get('MailCommand'); + + if ($mail_command eq 'testfile' and not $Mail::Mailer::testfile::config{outfile}) { + $Mail::Mailer::testfile::config{outfile} = File::Temp->new; + $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}"); + } + + # if it is a sub routine, we just return it; + return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' ); + + if ( $mail_command eq 'sendmailpipe' ) { + my $path = RT->Config->Get('SendmailPath'); + my @args = shellwords(RT->Config->Get('SendmailArguments')); + + # SetOutgoingMailFrom and bounces conflict, since they both want -f + if ( $args{'Bounce'} ) { + push @args, shellwords(RT->Config->Get('SendmailBounceArguments')); + } elsif ( my $MailFrom = RT->Config->Get('SetOutgoingMailFrom') ) { + my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef; + my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {}; + + if ($TicketObj) { + my $QueueName = $TicketObj->QueueObj->Name; + my $QueueAddressOverride = $Overrides->{$QueueName}; + + if ($QueueAddressOverride) { + $OutgoingMailAddress = $QueueAddressOverride; + } else { + $OutgoingMailAddress ||= $TicketObj->QueueObj->CorrespondAddress + || RT->Config->Get('CorrespondAddress'); + } + } + elsif ($Overrides->{'Default'}) { + $OutgoingMailAddress = $Overrides->{'Default'}; + } + + push @args, "-f", $OutgoingMailAddress + if $OutgoingMailAddress; + } + + # VERP + if ( $TransactionObj and + my $prefix = RT->Config->Get('VERPPrefix') and + my $domain = RT->Config->Get('VERPDomain') ) + { + my $from = $TransactionObj->CreatorObj->EmailAddress; + $from =~ s/@/=/g; + $from =~ s/\s//g; + push @args, "-f", "$prefix$from\@$domain"; + } + + eval { + # don't ignore CHLD signal to get proper exit code + local $SIG{'CHLD'} = 'DEFAULT'; + + # if something wrong with $mail->print we will get PIPE signal, handle it + local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" }; + + require IPC::Open2; + my ($mail, $stdout); + my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args ) + or die "couldn't execute program: $!"; + + $args{'Entity'}->print($mail); + close $mail or die "close pipe failed: $!"; + + waitpid($pid, 0); + if ($?) { + # sendmail exit statuses mostly errors with data not software + # TODO: status parsing: core dump, exit on signal or EX_* + my $msg = "$msgid: `$path @args` exited with code ". ($?>>8); + $msg = ", interrupted by signal ". ($?&127) if $?&127; + $RT::Logger->error( $msg ); + die $msg; + } + }; + if ( $@ ) { + $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ ); + if ( $TicketObj ) { + _RecordSendEmailFailure( $TicketObj ); + } + return 0; + } + } + elsif ( $mail_command eq 'smtp' ) { + require Net::SMTP; + my $smtp = do { local $@; eval { Net::SMTP->new( + Host => RT->Config->Get('SMTPServer'), + Debug => RT->Config->Get('SMTPDebug'), + ) } }; + unless ( $smtp ) { + $RT::Logger->crit( "Could not connect to SMTP server."); + if ($TicketObj) { + _RecordSendEmailFailure( $TicketObj ); + } + return 0; + } + + # duplicate head as we want drop Bcc field + my $head = $args{'Entity'}->head->dup; + my @recipients = map $_->address, map + Email::Address->parse($head->get($_)), qw(To Cc Bcc); + $head->delete('Bcc'); + + my $sender = RT->Config->Get('SMTPFrom') + || $args{'Entity'}->head->get('From'); + chomp $sender; + + my $status = $smtp->mail( $sender ) + && $smtp->recipient( @recipients ); + + if ( $status ) { + $smtp->data; + my $fh = $smtp->tied_fh; + $head->print( $fh ); + print $fh "\n"; + $args{'Entity'}->print_body( $fh ); + $smtp->dataend; + } + $smtp->quit; + + unless ( $status ) { + $RT::Logger->crit( "$msgid: Could not send mail via SMTP." ); + if ( $TicketObj ) { + _RecordSendEmailFailure( $TicketObj ); + } + return 0; + } + } + else { + local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'}); + + my @mailer_args = ($mail_command); + if ( $mail_command eq 'sendmail' ) { + $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath'); + push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments')); + } + else { + push @mailer_args, RT->Config->Get('MailParams'); + } + + unless ( $args{'Entity'}->send( @mailer_args ) ) { + $RT::Logger->crit( "$msgid: Could not send mail." ); + if ( $TicketObj ) { + _RecordSendEmailFailure( $TicketObj ); + } + return 0; + } + } + return 1; +} + +=head2 PrepareEmailUsingTemplate Template => '', Arguments => {} + +Loads a template. Parses it using arguments if it's not empty. +Returns a tuple (L<RT::Template> object, error message). + +Note that even if a template object is returned MIMEObj method +may return undef for empty templates. + +=cut + +sub PrepareEmailUsingTemplate { + my %args = ( + Template => '', + Arguments => {}, + @_ + ); + + my $template = RT::Template->new( RT->SystemUser ); + $template->LoadGlobalTemplate( $args{'Template'} ); + unless ( $template->id ) { + return (undef, "Couldn't load template '". $args{'Template'} ."'"); + } + return $template if $template->IsEmpty; + + my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } ); + return (undef, $msg) unless $status; + + return $template; +} + +=head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => '' + +Sends email using a template, takes name of template, arguments for it and recipients. + +=cut + +sub SendEmailUsingTemplate { + my %args = ( + Template => '', + Arguments => {}, + To => undef, + Cc => undef, + Bcc => undef, + From => RT->Config->Get('CorrespondAddress'), + InReplyTo => undef, + ExtraHeaders => {}, + @_ + ); + + my ($template, $msg) = PrepareEmailUsingTemplate( %args ); + return (0, $msg) unless $template; + + my $mail = $template->MIMEObj; + unless ( $mail ) { + $RT::Logger->info("Message is not sent as template #". $template->id ." is empty"); + return -1; + } + + $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) ) + foreach grep defined $args{$_}, qw(To Cc Bcc From); + + $mail->head->set( $_ => $args{ExtraHeaders}{$_} ) + foreach keys %{ $args{ExtraHeaders} }; + + SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} ); + + return SendEmail( Entity => $mail ); +} + +=head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => '' + +Forwards transaction with all attachments as 'message/rfc822'. + +=cut + +sub ForwardTransaction { + my $txn = shift; + my %args = ( To => '', Cc => '', Bcc => '', @_ ); + + my $entity = $txn->ContentAsMIME; + + my ( $ret, $msg ) = SendForward( %args, Entity => $entity, Transaction => $txn ); + if ($ret) { + my $ticket = $txn->TicketObj; + my ( $ret, $msg ) = $ticket->_NewTransaction( + Type => 'Forward Transaction', + Field => $txn->id, + Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc}, + ); + unless ($ret) { + $RT::Logger->error("Failed to create transaction: $msg"); + } + } + return ( $ret, $msg ); +} + +=head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => '' + +Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'. + +=cut + +sub ForwardTicket { + my $ticket = shift; + my %args = ( To => '', Cc => '', Bcc => '', @_ ); + + my $txns = $ticket->Transactions; + $txns->Limit( + FIELD => 'Type', + VALUE => $_, + ) for qw(Create Correspond); + + my $entity = MIME::Entity->build( + Type => 'multipart/mixed', + Description => 'forwarded ticket', + ); + $entity->add_part( $_ ) foreach + map $_->ContentAsMIME, + @{ $txns->ItemsArrayRef }; + + my ( $ret, $msg ) = SendForward( + %args, + Entity => $entity, + Ticket => $ticket, + Template => 'Forward Ticket', + ); + + if ($ret) { + my ( $ret, $msg ) = $ticket->_NewTransaction( + Type => 'Forward Ticket', + Field => $ticket->id, + Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc}, + ); + unless ($ret) { + $RT::Logger->error("Failed to create transaction: $msg"); + } + } + + return ( $ret, $msg ); + +} + +=head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => '' + +Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template. + +=cut + +sub SendForward { + my (%args) = ( + Entity => undef, + Ticket => undef, + Transaction => undef, + Template => 'Forward', + To => '', Cc => '', Bcc => '', + @_ + ); + + my $txn = $args{'Transaction'}; + my $ticket = $args{'Ticket'}; + $ticket ||= $txn->Object if $txn; + + my $entity = $args{'Entity'}; + unless ( $entity ) { + require Carp; + $RT::Logger->error(Carp::longmess("No entity provided")); + return (0, $ticket->loc("Couldn't send email")); + } + + my ($template, $msg) = PrepareEmailUsingTemplate( + Template => $args{'Template'}, + Arguments => { + Ticket => $ticket, + Transaction => $txn, + }, + ); + + my $mail; + if ( $template ) { + $mail = $template->MIMEObj; + } else { + $RT::Logger->warning($msg); + } + unless ( $mail ) { + $RT::Logger->warning("Couldn't generate email using template '$args{Template}'"); + + my $description; + unless ( $args{'Transaction'} ) { + $description = 'This is forward of ticket #'. $ticket->id; + } else { + $description = 'This is forward of transaction #' + . $txn->id ." of a ticket #". $txn->ObjectId; + } + $mail = MIME::Entity->build( + Type => 'text/plain', + Data => $description, + ); + } + + $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) ) + foreach grep defined $args{$_}, qw(To Cc Bcc); + + $mail->make_multipart unless $mail->is_multipart; + $mail->add_part( $entity ); + + my $from; + unless (defined $mail->head->get('Subject')) { + my $subject = ''; + $subject = $txn->Subject if $txn; + $subject ||= $ticket->Subject if $ticket; + + unless ( RT->Config->Get('ForwardFromUser') ) { + # XXX: what if want to forward txn of other object than ticket? + $subject = AddSubjectTag( $subject, $ticket ); + } + + $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) ); + } + + $mail->head->set( + From => EncodeToMIME( + String => GetForwardFrom( Transaction => $txn, Ticket => $ticket ) + ) + ); + + my $status = RT->Config->Get('ForwardFromUser') + # never sign if we forward from User + ? SendEmail( %args, Entity => $mail, Sign => 0 ) + : SendEmail( %args, Entity => $mail ); + return (0, $ticket->loc("Couldn't send email")) unless $status; + return (1, $ticket->loc("Sent email successfully")); +} + +=head2 GetForwardFrom Ticket => undef, Transaction => undef + +Resolve the From field to use in forward mail + +=cut + +sub GetForwardFrom { + my %args = ( Ticket => undef, Transaction => undef, @_ ); + my $txn = $args{Transaction}; + my $ticket = $args{Ticket} || $txn->Object; + + if ( RT->Config->Get('ForwardFromUser') ) { + return ( $txn || $ticket )->CurrentUser->EmailAddress; + } + else { + return $ticket->QueueObj->CorrespondAddress + || RT->Config->Get('CorrespondAddress'); + } +} + +=head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0 + +Signs and encrypts message using L<RT::Crypt::GnuPG>, but as well +handle errors with users' keys. + +If a recipient has no key or has other problems with it, then the +unction sends a error to him using 'Error: public key' template. +Also, notifies RT's owner using template 'Error to RT owner: public key' +to inform that there are problems with users' keys. Then we filter +all bad recipients and retry. + +Returns 1 on success, 0 on error and -1 if all recipients are bad and +had been filtered out. + +=cut + +sub SignEncrypt { + my %args = ( + Entity => undef, + Sign => 0, + Encrypt => 0, + @_ + ); + return 1 unless $args{'Sign'} || $args{'Encrypt'}; + + my $msgid = $args{'Entity'}->head->get('Message-ID') || ''; + chomp $msgid; + + $RT::Logger->debug("$msgid Signing message") if $args{'Sign'}; + $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'}; + + require RT::Crypt::GnuPG; + my %res = RT::Crypt::GnuPG::SignEncrypt( %args ); + return 1 unless $res{'exit_code'}; + + my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} ); + + my @bad_recipients; + foreach my $line ( @status ) { + # if the passphrase fails, either you have a bad passphrase + # or gpg-agent has died. That should get caught in Create and + # Update, but at least throw an error here + if (($line->{'Operation'}||'') eq 'PassphraseCheck' + && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) { + $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" ); + return 0; + } + next unless ($line->{'Operation'}||'') eq 'RecipientsCheck'; + next if $line->{'Status'} eq 'DONE'; + $RT::Logger->error( $line->{'Message'} ); + push @bad_recipients, $line; + } + return 0 unless @bad_recipients; + + $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0] + foreach @bad_recipients; + + foreach my $recipient ( @bad_recipients ) { + my $status = SendEmailUsingTemplate( + To => $recipient->{'AddressObj'}->address, + Template => 'Error: public key', + Arguments => { + %$recipient, + TicketObj => $args{'Ticket'}, + TransactionObj => $args{'Transaction'}, + }, + ); + unless ( $status ) { + $RT::Logger->error("Couldn't send 'Error: public key'"); + } + } + + my $status = SendEmailUsingTemplate( + To => RT->Config->Get('OwnerEmail'), + Template => 'Error to RT owner: public key', + Arguments => { + BadRecipients => \@bad_recipients, + TicketObj => $args{'Ticket'}, + TransactionObj => $args{'Transaction'}, + }, + ); + unless ( $status ) { + $RT::Logger->error("Couldn't send 'Error to RT owner: public key'"); + } + + DeleteRecipientsFromHead( + $args{'Entity'}->head, + map $_->{'AddressObj'}->address, @bad_recipients + ); + + unless ( $args{'Entity'}->head->get('To') + || $args{'Entity'}->head->get('Cc') + || $args{'Entity'}->head->get('Bcc') ) + { + $RT::Logger->debug("$msgid No recipients that have public key, not sending"); + return -1; + } + + # redo without broken recipients + %res = RT::Crypt::GnuPG::SignEncrypt( %args ); + return 0 if $res{'exit_code'}; + + return 1; +} + +use MIME::Words (); + +=head2 EncodeToMIME + +Takes a hash with a String and a Charset. Returns the string encoded +according to RFC2047, using B (base64 based) encoding. + +String must be a perl string, octets are returned. + +If Charset is not provided then $EmailOutputEncoding config option +is used, or "latin-1" if that is not set. + +=cut + +sub EncodeToMIME { + my %args = ( + String => undef, + Charset => undef, + @_ + ); + my $value = $args{'String'}; + return $value unless $value; # 0 is perfect ascii + my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding'); + my $encoding = 'B'; + + # using RFC2047 notation, sec 2. + # encoded-word = "=?" charset "?" encoding "?" encoded-text "?=" + + # An 'encoded-word' may not be more than 75 characters long + # + # MIME encoding increases 4/3*(number of bytes), and always in multiples + # of 4. Thus we have to find the best available value of bytes available + # for each chunk. + # + # First we get the integer max which max*4/3 would fit on space. + # Then we find the greater multiple of 3 lower or equal than $max. + my $max = int( + ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) ) + * 3 + ) / 4 + ); + $max = int( $max / 3 ) * 3; + + chomp $value; + + if ( $max <= 0 ) { + + # gives an error... + $RT::Logger->crit("Can't encode! Charset or encoding too big."); + return ($value); + } + + return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s; + + $value =~ s/\s+$//; + + # we need perl string to split thing char by char + Encode::_utf8_on($value) unless Encode::is_utf8($value); + + my ( $tmp, @chunks ) = ( '', () ); + while ( length $value ) { + my $char = substr( $value, 0, 1, '' ); + my $octets = Encode::encode( $charset, $char ); + if ( length($tmp) + length($octets) > $max ) { + push @chunks, $tmp; + $tmp = ''; + } + $tmp .= $octets; + } + push @chunks, $tmp if length $tmp; + + # encode an join chuncks + $value = join "\n ", + map MIME::Words::encode_mimeword( $_, $encoding, $charset ), + @chunks; + return ($value); +} + +sub CreateUser { + my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_; + + my $NewUser = RT::User->new( RT->SystemUser ); + + my ( $Val, $Message ) = $NewUser->Create( + Name => ( $Username || $Address ), + EmailAddress => $Address, + RealName => $Name, + Password => undef, + Privileged => 0, + Comments => 'Autocreated on ticket submission', + ); + + unless ($Val) { + + # Deal with the race condition of two account creations at once + if ($Username) { + $NewUser->LoadByName($Username); + } + + unless ( $NewUser->Id ) { + $NewUser->LoadByEmail($Address); + } + + unless ( $NewUser->Id ) { + MailError( + To => $ErrorsTo, + Subject => "User could not be created", + Explanation => + "User creation failed in mailgateway: $Message", + MIMEObj => $entity, + LogLevel => 'crit', + ); + } + } + + #Load the new user object + my $CurrentUser = RT::CurrentUser->new; + $CurrentUser->LoadByEmail( $Address ); + + unless ( $CurrentUser->id ) { + $RT::Logger->warning( + "Couldn't load user '$Address'." . "giving up" ); + MailError( + To => $ErrorsTo, + Subject => "User could not be loaded", + Explanation => + "User '$Address' could not be loaded in the mail gateway", + MIMEObj => $entity, + LogLevel => 'crit' + ); + } + + return $CurrentUser; +} + + + +=head2 ParseCcAddressesFromHead HASH + +Takes a hash containing QueueObj, Head and CurrentUser objects. +Returns a list of all email addresses in the To and Cc +headers b<except> the current Queue's email addresses, the CurrentUser's +email address and anything that the configuration sub RT::IsRTAddress matches. + +=cut + +sub ParseCcAddressesFromHead { + my %args = ( + Head => undef, + QueueObj => undef, + CurrentUser => undef, + @_ + ); + + my $current_address = lc $args{'CurrentUser'}->EmailAddress; + my $user = $args{'CurrentUser'}->UserObj; + + return + grep { $_ ne $current_address + && !RT::EmailParser->IsRTAddress( $_ ) + && !IgnoreCcAddress( $_ ) + } + map lc $user->CanonicalizeEmailAddress( $_->address ), + map RT::EmailParser->CleanupAddresses( Email::Address->parse( $args{'Head'}->get( $_ ) ) ), + qw(To Cc); +} + +=head2 IgnoreCcAddress ADDRESS + +Returns true if ADDRESS matches the $IgnoreCcRegexp config variable. + +=cut + +sub IgnoreCcAddress { + my $address = shift; + if ( my $address_re = RT->Config->Get('IgnoreCcRegexp') ) { + return 1 if $address =~ /$address_re/i; + } + return undef; +} + +=head2 ParseSenderAddressFromHead HEAD + +Takes a MIME::Header object. Returns (user@host, friendly name, errors) +where the first two values are the From (evaluated in order of +Reply-To:, From:, Sender). + +A list of error messages may be returned even when a Sender value is +found, since it could be a parse error for another (checked earlier) +sender field. In this case, the errors aren't fatal, but may be useful +to investigate the parse failure. + +=cut + +sub ParseSenderAddressFromHead { + my $head = shift; + my @sender_headers = ('Reply-To', 'From', 'Sender'); + my @errors; # Accumulate any errors + + #Figure out who's sending this message. + foreach my $header ( @sender_headers ) { + my $addr_line = $head->get($header) || next; + my ($addr, $name) = ParseAddressFromHeader( $addr_line ); + # only return if the address is not empty + return ($addr, $name, @errors) if $addr; + + chomp $addr_line; + push @errors, "$header: $addr_line"; + } + + return (undef, undef, @errors); +} + +=head2 ParseErrorsToAddressFromHead HEAD + +Takes a MIME::Header object. Return a single value : user@host +of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:, +From:, Sender) + +=cut + +sub ParseErrorsToAddressFromHead { + my $head = shift; + + #Figure out who's sending this message. + + foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) { + + # If there's a header of that name + my $headerobj = $head->get($header); + if ($headerobj) { + my ( $addr, $name ) = ParseAddressFromHeader($headerobj); + + # If it's got actual useful content... + return ($addr) if ($addr); + } + } +} + + + +=head2 ParseAddressFromHeader ADDRESS + +Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name + +=cut + +sub ParseAddressFromHeader { + my $Addr = shift; + + # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate + $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g; + my @Addresses = RT::EmailParser->ParseEmailAddress($Addr); + + my ($AddrObj) = grep ref $_, @Addresses; + unless ( $AddrObj ) { + return ( undef, undef ); + } + + return ( $AddrObj->address, $AddrObj->phrase ); +} + +=head2 DeleteRecipientsFromHead HEAD RECIPIENTS + +Gets a head object and list of addresses. +Deletes addresses from To, Cc or Bcc fields. + +=cut + +sub DeleteRecipientsFromHead { + my $head = shift; + my %skip = map { lc $_ => 1 } @_; + + foreach my $field ( qw(To Cc Bcc) ) { + $head->set( $field => + join ', ', map $_->format, grep !$skip{ lc $_->address }, + Email::Address->parse( $head->get( $field ) ) + ); + } +} + +sub GenMessageId { + my %args = ( + Ticket => undef, + Scrip => undef, + ScripAction => undef, + @_ + ); + my $org = RT->Config->Get('Organization'); + my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0; + my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0; + my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0; + + return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.' + . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ; +} + +sub SetInReplyTo { + my %args = ( + Message => undef, + InReplyTo => undef, + Ticket => undef, + @_ + ); + return unless $args{'Message'} && $args{'InReplyTo'}; + + my $get_header = sub { + my @res; + if ( $args{'InReplyTo'}->isa('MIME::Entity') ) { + @res = $args{'InReplyTo'}->head->get( shift ); + } else { + @res = $args{'InReplyTo'}->GetHeader( shift ) || ''; + } + return grep length, map { split /\s+/m, $_ } grep defined, @res; + }; + + my @id = $get_header->('Message-ID'); + #XXX: custom header should begin with X- otherwise is violation of the standard + my @rtid = $get_header->('RT-Message-ID'); + my @references = $get_header->('References'); + unless ( @references ) { + @references = $get_header->('In-Reply-To'); + } + push @references, @id, @rtid; + if ( $args{'Ticket'} ) { + my $pseudo_ref = '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>'; + push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references; + } + @references = splice @references, 4, -6 + if @references > 10; + + my $mail = $args{'Message'}; + $mail->head->set( 'In-Reply-To' => Encode::encode_utf8(join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid; + $mail->head->set( 'References' => Encode::encode_utf8(join ' ', @references) ); +} + +sub ExtractTicketId { + my $entity = shift; + + my $subject = $entity->head->get('Subject') || ''; + chomp $subject; + return ParseTicketId( $subject ); +} + +sub ParseTicketId { + my $Subject = shift; + + my $rtname = RT->Config->Get('rtname'); + my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i; + + my $id; + if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) { + $id = $1; + } else { + foreach my $tag ( RT->System->SubjectTag ) { + next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i; + $id = $1; + last; + } + } + return undef unless $id; + + $RT::Logger->debug("Found a ticket ID. It's $id"); + return $id; +} + +sub AddSubjectTag { + my $subject = shift; + my $ticket = shift; + unless ( ref $ticket ) { + my $tmp = RT::Ticket->new( RT->SystemUser ); + $tmp->Load( $ticket ); + $ticket = $tmp; + } + my $id = $ticket->id; + my $queue_tag = $ticket->QueueObj->SubjectTag; + + my $tag_re = RT->Config->Get('EmailSubjectTagRegex'); + unless ( $tag_re ) { + my $tag = $queue_tag || RT->Config->Get('rtname'); + $tag_re = qr/\Q$tag\E/; + } elsif ( $queue_tag ) { + $tag_re = qr/$tag_re|\Q$queue_tag\E/; + } + return $subject if $subject =~ /\[$tag_re\s+#$id\]/; + + $subject =~ s/(\r\n|\n|\s)/ /g; + chomp $subject; + return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject"; +} + + +=head2 Gateway ARGSREF + + +Takes parameters: + + action + queue + message + + +This performs all the "guts" of the mail rt-mailgate program, and is +designed to be called from the web interface with a message, user +object, and so on. + +Can also take an optional 'ticket' parameter; this ticket id overrides +any ticket id found in the subject. + +Returns: + + An array of: + + (status code, message, optional ticket object) + + status code is a numeric value. + + for temporary failures, the status code should be -75 + + for permanent failures which are handled by RT, the status code + should be 0 + + for succces, the status code should be 1 + + + +=cut + +sub _LoadPlugins { + my @mail_plugins = @_; + + my @res; + foreach my $plugin (@mail_plugins) { + if ( ref($plugin) eq "CODE" ) { + push @res, $plugin; + } elsif ( !ref $plugin ) { + my $Class = $plugin; + $Class = "RT::Interface::Email::" . $Class + unless $Class =~ /^RT::/; + $Class->require or + do { $RT::Logger->error("Couldn't load $Class: $@"); next }; + + no strict 'refs'; + unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) { + $RT::Logger->crit( "No GetCurrentUser code found in $Class module"); + next; + } + push @res, $Class; + } else { + $RT::Logger->crit( "$plugin - is not class name or code reference"); + } + } + return @res; +} + +sub Gateway { + my $argsref = shift; + my %args = ( + action => 'correspond', + queue => '1', + ticket => undef, + message => undef, + %$argsref + ); + + my $SystemTicket; + my $Right; + + # Validate the action + my ( $status, @actions ) = IsCorrectAction( $args{'action'} ); + unless ($status) { + return ( + -75, + "Invalid 'action' parameter " + . $actions[0] + . " for queue " + . $args{'queue'}, + undef + ); + } + + my $parser = RT::EmailParser->new(); + $parser->SmartParseMIMEEntityFromScalar( + Message => $args{'message'}, + Decode => 0, + Exact => 1, + ); + + my $Message = $parser->Entity(); + unless ($Message) { + MailError( + Subject => "RT Bounce: Unparseable message", + Explanation => "RT couldn't process the message below", + Attach => $args{'message'} + ); + + return ( 0, + "Failed to parse this message. Something is likely badly wrong with the message" + ); + } + + my @mail_plugins = grep $_, RT->Config->Get('MailPlugins'); + push @mail_plugins, "Auth::MailFrom" unless @mail_plugins; + @mail_plugins = _LoadPlugins( @mail_plugins ); + + my %skip_plugin; + foreach my $class( grep !ref, @mail_plugins ) { + # check if we should apply filter before decoding + my $check_cb = do { + no strict 'refs'; + *{ $class . "::ApplyBeforeDecode" }{CODE}; + }; + next unless defined $check_cb; + next unless $check_cb->( + Message => $Message, + RawMessageRef => \$args{'message'}, + ); + + $skip_plugin{ $class }++; + + my $Code = do { + no strict 'refs'; + *{ $class . "::GetCurrentUser" }{CODE}; + }; + my ($status, $msg) = $Code->( + Message => $Message, + RawMessageRef => \$args{'message'}, + ); + next if $status > 0; + + if ( $status == -2 ) { + return (1, $msg, undef); + } elsif ( $status == -1 ) { + return (0, $msg, undef); + } + } + @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins; + $parser->_DecodeBodies; + $parser->RescueOutlook; + $parser->_PostProcessNewEntity; + + my $head = $Message->head; + my $ErrorsTo = ParseErrorsToAddressFromHead( $head ); + my $Sender = (ParseSenderAddressFromHead( $head ))[0]; + my $From = $head->get("From"); + chomp $From if defined $From; + + my $MessageId = $head->get('Message-ID') + || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>'; + + #Pull apart the subject line + my $Subject = $head->get('Subject') || ''; + chomp $Subject; + + # Lets check for mail loops of various sorts. + my ($should_store_machine_generated_message, $IsALoop, $result); + ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) = + _HandleMachineGeneratedMail( + Message => $Message, + ErrorsTo => $ErrorsTo, + Subject => $Subject, + MessageId => $MessageId + ); + + # Do not pass loop messages to MailPlugins, to make sure the loop + # is broken, unless $RT::StoreLoops is set. + if ($IsALoop && !$should_store_machine_generated_message) { + return ( 0, $result, undef ); + } + # }}} + + $args{'ticket'} ||= ExtractTicketId( $Message ); + + # ExtractTicketId may have been overridden, and edited the Subject + my $NewSubject = $Message->head->get('Subject'); + chomp $NewSubject; + + $SystemTicket = RT::Ticket->new( RT->SystemUser ); + $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ; + if ( $SystemTicket->id ) { + $Right = 'ReplyToTicket'; + } else { + $Right = 'CreateTicket'; + } + + #Set up a queue object + my $SystemQueueObj = RT::Queue->new( RT->SystemUser ); + $SystemQueueObj->Load( $args{'queue'} ); + + # We can safely have no queue of we have a known-good ticket + unless ( $SystemTicket->id || $SystemQueueObj->id ) { + return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef ); + } + + my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel( + MailPlugins => \@mail_plugins, + Actions => \@actions, + Message => $Message, + RawMessageRef => \$args{message}, + SystemTicket => $SystemTicket, + SystemQueue => $SystemQueueObj, + ); + + # If authentication fails and no new user was created, get out. + if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) { + + # If the plugins refused to create one, they lose. + unless ( $AuthStat == -1 ) { + _NoAuthorizedUserFound( + Right => $Right, + Message => $Message, + Requestor => $ErrorsTo, + Queue => $args{'queue'} + ); + + } + return ( 0, "Could not load a valid user", undef ); + } + + # If we got a user, but they don't have the right to say things + if ( $AuthStat == 0 ) { + MailError( + To => $ErrorsTo, + Subject => "Permission Denied", + Explanation => + "You do not have permission to communicate with RT", + MIMEObj => $Message + ); + return ( + 0, + ($CurrentUser->EmailAddress || $CurrentUser->Name) + . " ($Sender) tried to submit a message to " + . $args{'Queue'} + . " without permission.", + undef + ); + } + + + unless ($should_store_machine_generated_message) { + return ( 0, $result, undef ); + } + + # if plugin's updated SystemTicket then update arguments + $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id; + + my $Ticket = RT::Ticket->new($CurrentUser); + + if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions ) + { + + my @Cc; + my @Requestors = ( $CurrentUser->id ); + + if (RT->Config->Get('ParseNewMessageForTicketCcs')) { + @Cc = ParseCcAddressesFromHead( + Head => $head, + CurrentUser => $CurrentUser, + QueueObj => $SystemQueueObj + ); + } + + $head->replace('X-RT-Interface' => 'Email'); + + my ( $id, $Transaction, $ErrStr ) = $Ticket->Create( + Queue => $SystemQueueObj->Id, + Subject => $NewSubject, + Requestor => \@Requestors, + Cc => \@Cc, + MIMEObj => $Message + ); + if ( $id == 0 ) { + MailError( + To => $ErrorsTo, + Subject => "Ticket creation failed: $Subject", + Explanation => $ErrStr, + MIMEObj => $Message + ); + return ( 0, "Ticket creation From: $From failed: $ErrStr", $Ticket ); + } + + # strip comments&corresponds from the actions we don't need + # to record them if we've created the ticket just now + @actions = grep !/^(comment|correspond)$/, @actions; + $args{'ticket'} = $id; + + } elsif ( $args{'ticket'} ) { + + $Ticket->Load( $args{'ticket'} ); + unless ( $Ticket->Id ) { + my $error = "Could not find a ticket with id " . $args{'ticket'}; + MailError( + To => $ErrorsTo, + Subject => "Message not recorded: $Subject", + Explanation => $error, + MIMEObj => $Message + ); + + return ( 0, $error ); + } + $args{'ticket'} = $Ticket->id; + } else { + return ( 1, "Success", $Ticket ); + } + + # }}} + + my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands'); + foreach my $action (@actions) { + + # If the action is comment, add a comment. + if ( $action =~ /^(?:comment|correspond)$/i ) { + my $method = ucfirst lc $action; + my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message ); + unless ($status) { + + #Warn the sender that we couldn't actually submit the comment. + MailError( + To => $ErrorsTo, + Subject => "Message not recorded ($method): $Subject", + Explanation => $msg, + MIMEObj => $Message + ); + return ( 0, "Message From: $From not recorded: $msg", $Ticket ); + } + } elsif ($unsafe_actions) { + my ( $status, $msg ) = _RunUnsafeAction( + Action => $action, + ErrorsTo => $ErrorsTo, + Message => $Message, + Ticket => $Ticket, + CurrentUser => $CurrentUser, + ); + return ($status, $msg, $Ticket) unless $status == 1; + } + } + return ( 1, "Success", $Ticket ); +} + +=head2 GetAuthenticationLevel + + # Authentication Level + # -1 - Get out. this user has been explicitly declined + # 0 - User may not do anything (Not used at the moment) + # 1 - Normal user + # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate + +=cut + +sub GetAuthenticationLevel { + my %args = ( + MailPlugins => [], + Actions => [], + Message => undef, + RawMessageRef => undef, + SystemTicket => undef, + SystemQueue => undef, + @_, + ); + + my ( $CurrentUser, $AuthStat, $error ); + + # Initalize AuthStat so comparisons work correctly + $AuthStat = -9999999; + + # if plugin returns AuthStat -2 we skip action + # NOTE: this is experimental API and it would be changed + my %skip_action = (); + + # Since this needs loading, no matter what + foreach (@{ $args{MailPlugins} }) { + my ($Code, $NewAuthStat); + if ( ref($_) eq "CODE" ) { + $Code = $_; + } else { + no strict 'refs'; + $Code = *{ $_ . "::GetCurrentUser" }{CODE}; + } + + foreach my $action (@{ $args{Actions} }) { + ( $CurrentUser, $NewAuthStat ) = $Code->( + Message => $args{Message}, + RawMessageRef => $args{RawMessageRef}, + CurrentUser => $CurrentUser, + AuthLevel => $AuthStat, + Action => $action, + Ticket => $args{SystemTicket}, + Queue => $args{SystemQueue}, + ); + +# You get the highest level of authentication you were assigned, unless you get the magic -1 +# If a module returns a "-1" then we discard the ticket, so. + $AuthStat = $NewAuthStat + if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 ); + + last if $AuthStat == -1; + $skip_action{$action}++ if $AuthStat == -2; + } + + # strip actions we should skip + @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}} + if $AuthStat == -2; + last unless @{$args{Actions}}; + + last if $AuthStat == -1; + } + + return $AuthStat if !wantarray; + + return ($AuthStat, $CurrentUser, $error); +} + +sub _RunUnsafeAction { + my %args = ( + Action => undef, + ErrorsTo => undef, + Message => undef, + Ticket => undef, + CurrentUser => undef, + @_ + ); + + my $From = $args{Message}->head->get("From"); + + if ( $args{'Action'} =~ /^take$/i ) { + my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id ); + unless ($status) { + MailError( + To => $args{'ErrorsTo'}, + Subject => "Ticket not taken", + Explanation => $msg, + MIMEObj => $args{'Message'} + ); + return ( 0, "Ticket not taken, by email From: $From" ); + } + } elsif ( $args{'Action'} =~ /^resolve$/i ) { + my $new_status = $args{'Ticket'}->FirstInactiveStatus; + if ($new_status) { + my ( $status, $msg ) = $args{'Ticket'}->SetStatus($new_status); + unless ($status) { + + #Warn the sender that we couldn't actually submit the comment. + MailError( + To => $args{'ErrorsTo'}, + Subject => "Ticket not resolved", + Explanation => $msg, + MIMEObj => $args{'Message'} + ); + return ( 0, "Ticket not resolved, by email From: $From" ); + } + } + } else { + return ( 0, "Not supported unsafe action $args{'Action'}, by email From: $From", $args{'Ticket'} ); + } + return ( 1, "Success" ); +} + +=head2 _NoAuthorizedUserFound + +Emails the RT Owner and the requestor when the auth plugins return "No auth user found" + +=cut + +sub _NoAuthorizedUserFound { + my %args = ( + Right => undef, + Message => undef, + Requestor => undef, + Queue => undef, + @_ + ); + + # Notify the RT Admin of the failure. + MailError( + To => RT->Config->Get('OwnerEmail'), + Subject => "Could not load a valid user", + Explanation => <<EOT, +RT could not load a valid user, and RT's configuration does not allow +for the creation of a new user for this email (@{[$args{Requestor}]}). + +You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the +queue @{[$args{'Queue'}]}. + +EOT + MIMEObj => $args{'Message'}, + LogLevel => 'error' + ); + + # Also notify the requestor that his request has been dropped. + if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) { + MailError( + To => $args{'Requestor'}, + Subject => "Could not load a valid user", + Explanation => <<EOT, +RT could not load a valid user, and RT's configuration does not allow +for the creation of a new user for your email. + +EOT + MIMEObj => $args{'Message'}, + LogLevel => 'error' + ); + } +} + +=head2 _HandleMachineGeneratedMail + +Takes named params: + Message + ErrorsTo + Subject + +Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc. +Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message", +"This message appears to be a loop (boolean)" ); + +=cut + +sub _HandleMachineGeneratedMail { + my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ ); + my $head = $args{'Message'}->head; + my $ErrorsTo = $args{'ErrorsTo'}; + + my $IsBounce = CheckForBounce($head); + + my $IsAutoGenerated = CheckForAutoGenerated($head); + + my $IsSuspiciousSender = CheckForSuspiciousSender($head); + + my $IsALoop = CheckForLoops($head); + + my $SquelchReplies = 0; + + my $owner_mail = RT->Config->Get('OwnerEmail'); + + #If the message is autogenerated, we need to know, so we can not + # send mail to the sender + if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) { + $SquelchReplies = 1; + $ErrorsTo = $owner_mail; + } + + # Warn someone if it's a loop, before we drop it on the ground + if ($IsALoop) { + $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself."); + + #Should we mail it to RTOwner? + if ( RT->Config->Get('LoopsToRTOwner') ) { + MailError( + To => $owner_mail, + Subject => "RT Bounce: ".$args{'Subject'}, + Explanation => "RT thinks this message may be a bounce", + MIMEObj => $args{Message} + ); + } + + #Do we actually want to store it? + return ( 0, $ErrorsTo, "Message Bounced", $IsALoop ) + unless RT->Config->Get('StoreLoops'); + } + + # Squelch replies if necessary + # Don't let the user stuff the RT-Squelch-Replies-To header. + if ( $head->get('RT-Squelch-Replies-To') ) { + $head->replace( + 'RT-Relocated-Squelch-Replies-To', + $head->get('RT-Squelch-Replies-To') + ); + $head->delete('RT-Squelch-Replies-To'); + } + + if ($SquelchReplies) { + + # Squelch replies to the sender, and also leave a clue to + # allow us to squelch ALL outbound messages. This way we + # can punt the logic of "what to do when we get a bounce" + # to the scrip. We might want to notify nobody. Or just + # the RT Owner. Or maybe all Privileged watchers. + my ( $Sender, $junk ) = ParseSenderAddressFromHead($head); + $head->replace( 'RT-Squelch-Replies-To', $Sender ); + $head->replace( 'RT-DetectedAutoGenerated', 'true' ); + } + return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop ); +} + +=head2 IsCorrectAction + +Returns a list of valid actions we've found for this message + +=cut + +sub IsCorrectAction { + my $action = shift; + my @actions = grep $_, split /-/, $action; + return ( 0, '(no value)' ) unless @actions; + foreach ( @actions ) { + return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/; + } + return ( 1, @actions ); +} + +sub _RecordSendEmailFailure { + my $ticket = shift; + if ($ticket) { + $ticket->_RecordNote( + NoteType => 'SystemError', + Content => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.", + ); + return 1; + } + else { + $RT::Logger->error( "Can't record send email failure as ticket is missing" ); + return; + } +} + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Interface/Email/Auth/GnuPG.pm b/rt/lib/RT/Interface/Email/Auth/GnuPG.pm index 5137707e5..898a8d9b7 100755 --- a/rt/lib/RT/Interface/Email/Auth/GnuPG.pm +++ b/rt/lib/RT/Interface/Email/Auth/GnuPG.pm @@ -118,7 +118,7 @@ sub GetCurrentUser { foreach my $part ( $args{'Message'}->parts_DFS ) { my $decrypted; - my $status = $part->head->get( 'X-RT-GnuPG-Status' ); + my $status = Encode::decode( "UTF-8", $part->head->get( 'X-RT-GnuPG-Status' ) ); if ( $status ) { for ( RT::Crypt::GnuPG::ParseStatus( $status ) ) { if ( $_->{Operation} eq 'Decrypt' && $_->{Status} eq 'DONE' ) { @@ -126,7 +126,7 @@ sub GetCurrentUser { } if ( $_->{Operation} eq 'Verify' && $_->{Status} eq 'DONE' ) { $part->head->replace( - 'X-RT-Incoming-Signature' => $_->{UserString} + 'X-RT-Incoming-Signature' => Encode::encode( "UTF-8", $_->{UserString} ) ); } } diff --git a/rt/lib/RT/Interface/Web.pm b/rt/lib/RT/Interface/Web.pm index 59d315431..35b0cffa1 100644 --- a/rt/lib/RT/Interface/Web.pm +++ b/rt/lib/RT/Interface/Web.pm @@ -68,7 +68,6 @@ use URI qw(); use RT::Interface::Web::Menu; use RT::Interface::Web::Session; use Digest::MD5 (); -use Encode qw(); use List::MoreUtils qw(); use JSON qw(); @@ -1127,21 +1126,25 @@ sub StripContent { sub DecodeARGS { 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. Specifically, the call_next method pass through + # original arguments, which are still the encoded bytes, not + # characters. "{ 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. %{$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 ) + ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) : ( $type eq 'ARRAY' ) - ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } - @$_ ] + ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ] : ( $type eq 'HASH' ) - ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } - %$_ } + ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ } : $_ } %$ARGS; } @@ -1149,17 +1152,6 @@ sub DecodeARGS { 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}; @@ -1494,8 +1486,12 @@ sub StoreRequestToken { if ($ARGS->{Attach}) { my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' ); my $file_path = delete $ARGS->{'Attach'}; + + # This needs to be decoded because the value is a reference; + # hence it was not decoded along with all of the standard + # arguments in DecodeARGS $data->{attach} = { - filename => Encode::decode_utf8("$file_path"), + filename => Encode::decode("UTF-8", "$file_path"), mime => $attachment, }; } @@ -2008,7 +2004,7 @@ sub ProcessUpdateMessage { Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web', ); - $Message->head->replace( 'Message-ID' => Encode::encode_utf8( + $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} ) ) ); my $old_txn = RT::Transaction->new( $session{'CurrentUser'} ); @@ -2136,7 +2132,10 @@ sub ProcessAttachments { { # attachment? my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' ); - my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}"); + # This needs to be decoded because the value is a reference; + # hence it was not decoded along with all of the standard + # arguments in DecodeARGS + my $file_path = Encode::decode("UTF-8", "$ARGSRef->{'Attach'}"); $session{'Attachments'} = { %{ $session{'Attachments'} || {} }, $file_path => $attachment, }; } @@ -2174,9 +2173,9 @@ sub MakeMIMEEntity { ); my $Message = MIME::Entity->build( Type => 'multipart/mixed', - "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ), + "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ), "X-RT-Interface" => $args{Interface}, - map { $_ => Encode::encode_utf8( $args{ $_} ) } + map { $_ => Encode::encode( "UTF-8", $args{ $_} ) } grep defined $args{$_}, qw(Subject From Cc) ); @@ -2188,7 +2187,7 @@ sub MakeMIMEEntity { $Message->attach( Type => $args{'Type'} || 'text/plain', Charset => 'UTF-8', - Data => $args{'Body'}, + Data => Encode::encode( "UTF-8", $args{'Body'} ), ); } @@ -2205,16 +2204,16 @@ sub MakeMIMEEntity { my $uploadinfo = $cgi_object->uploadInfo($filehandle); - my $filename = "$filehandle"; + my $filename = Encode::decode("UTF-8","$filehandle"); $filename =~ s{^.*[\\/]}{}; $Message->attach( Type => $uploadinfo->{'Content-Type'}, - Filename => $filename, - Data => \@content, + Filename => Encode::encode("UTF-8",$filename), + Data => \@content, # Bytes, as read directly from the file, above ); if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) { - $Message->head->set( 'Subject' => $filename ); + $Message->head->set( 'Subject' => Encode::encode( "UTF-8", $filename ) ); } # Attachment parts really shouldn't get a Message-ID or "interface" diff --git a/rt/lib/RT/Interface/Web.pm.orig b/rt/lib/RT/Interface/Web.pm.orig new file mode 100644 index 000000000..59d315431 --- /dev/null +++ b/rt/lib/RT/Interface/Web.pm.orig @@ -0,0 +1,3454 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +## Portions Copyright 2000 Tobias Brox <tobix@fsck.com> + +## This is a library of static subs to be used by the Mason web +## interface to RT + +=head1 NAME + +RT::Interface::Web + + +=cut + +use strict; +use warnings; + +package RT::Interface::Web; + +use RT::SavedSearches; +use URI qw(); +use RT::Interface::Web::Menu; +use RT::Interface::Web::Session; +use Digest::MD5 (); +use Encode qw(); +use List::MoreUtils qw(); +use JSON qw(); + +=head2 SquishedCSS $style + +=cut + +my %SQUISHED_CSS; +sub SquishedCSS { + my $style = shift or die "need name"; + return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style}; + require RT::Squish::CSS; + my $css = RT::Squish::CSS->new( Style => $style ); + $SQUISHED_CSS{ $css->Style } = $css; + return $css; +} + +=head2 SquishedJS + +=cut + +my $SQUISHED_JS; +sub SquishedJS { + return $SQUISHED_JS if $SQUISHED_JS; + + require RT::Squish::JS; + my $js = RT::Squish::JS->new(); + $SQUISHED_JS = $js; + return $js; +} + +=head2 ClearSquished + +Removes the cached CSS and JS entries, forcing them to be regenerated +on next use. + +=cut + +sub ClearSquished { + undef $SQUISHED_JS; + %SQUISHED_CSS = (); +} + +=head2 EscapeUTF8 SCALARREF + +does a css-busting but minimalist escaping of whatever html you're passing in. + +=cut + +sub EscapeUTF8 { + my $ref = shift; + return unless defined $$ref; + + $$ref =~ s/&/&/g; + $$ref =~ s/</</g; + $$ref =~ s/>/>/g; + $$ref =~ s/\(/(/g; + $$ref =~ s/\)/)/g; + $$ref =~ s/"/"/g; + $$ref =~ s/'/'/g; +} + + + +=head2 EscapeURI SCALARREF + +Escapes URI component according to RFC2396 + +=cut + +sub EscapeURI { + my $ref = shift; + return unless defined $$ref; + + use bytes; + $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg; +} + +=head2 EncodeJSON SCALAR + +Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple +value or a reference. + +=cut + +sub EncodeJSON { + JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 }); +} + +sub _encode_surrogates { + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); +} + +sub EscapeJS { + my $ref = shift; + return unless defined $$ref; + + $$ref = "'" . join('', + map { + chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) : + $_ <= 255 ? sprintf("\\x%02X", $_) : + $_ <= 65535 ? sprintf("\\u%04X", $_) : + sprintf("\\u%X\\u%X", _encode_surrogates($_)) + } unpack('U*', $$ref)) + . "'"; +} + +=head2 WebCanonicalizeInfo(); + +Different web servers set different environmental varibles. This +function must return something suitable for REMOTE_USER. By default, +just downcase $ENV{'REMOTE_USER'} + +=cut + +sub WebCanonicalizeInfo { + return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'}; +} + + + +=head2 WebExternalAutoInfo($user); + +Returns a hash of user attributes, used when WebExternalAuto is set. + +=cut + +sub WebExternalAutoInfo { + my $user = shift; + + my %user_info; + + # default to making Privileged users, even if they specify + # some other default Attributes + if ( !$RT::AutoCreate + || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) ) + { + $user_info{'Privileged'} = 1; + } + + if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) { + + # Populate fields with information from Unix /etc/passwd + + my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ]; + $user_info{'Comments'} = $comments if defined $comments; + $user_info{'RealName'} = $realname if defined $realname; + } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) { + + # Populate fields with information from NT domain controller + } + + # and return the wad of stuff + return {%user_info}; +} + + +sub HandleRequest { + my $ARGS = shift; + + if (RT->Config->Get('DevelMode')) { + require Module::Refresh; + Module::Refresh->refresh; + } + + $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8"); + + $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ]; + + # Roll back any dangling transactions from a previous failed connection + $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth; + + MaybeEnableSQLStatementLog(); + + # avoid reentrancy, as suggested by masonbook + local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest; + + $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') ) + if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') ); + + ValidateWebConfig(); + + DecodeARGS($ARGS); + local $HTML::Mason::Commands::DECODED_ARGS = $ARGS; + PreprocessTimeUpdates($ARGS); + + InitializeMenu(); + MaybeShowInstallModePage(); + + $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS ); + SendSessionCookie(); + + if ( _UserLoggedIn() ) { + # make user info up to date + $HTML::Mason::Commands::session{'CurrentUser'} + ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id ); + undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'}; + } + else { + $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new(); + } + + # Process session-related callbacks before any auth attempts + $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' ); + + MaybeRejectPrivateComponentRequest(); + + MaybeShowNoAuthPage($ARGS); + + AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn(); + + _ForceLogout() unless _UserLoggedIn(); + + # Process per-page authentication callbacks + $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' ); + + if ( $ARGS->{'NotMobile'} ) { + $HTML::Mason::Commands::session{'NotMobile'} = 1; + } + + unless ( _UserLoggedIn() ) { + _ForceLogout(); + + # Authenticate if the user is trying to login via user/pass query args + my ($authed, $msg) = AttemptPasswordAuthentication($ARGS); + + unless ($authed) { + my $m = $HTML::Mason::Commands::m; + + # REST urls get a special 401 response + if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) { + $HTML::Mason::Commands::r->content_type("text/plain"); + $m->error_format("text"); + $m->out("RT/$RT::VERSION 401 Credentials required\n"); + $m->out("\n$msg\n") if $msg; + $m->abort; + } + # Specially handle /index.html and /m/index.html so that we get a nicer URL + elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) { + my $mobile = $1 ? 1 : 0; + my $next = SetNextPage($ARGS); + $m->comp('/NoAuth/Login.html', + next => $next, + actions => [$msg], + mobile => $mobile); + $m->abort; + } + else { + TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef)); + } + } + } + + MaybeShowInterstitialCSRFPage($ARGS); + + # now it applies not only to home page, but any dashboard that can be used as a workspace + $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'} + if ( $ARGS->{'HomeRefreshInterval'} ); + + # Process per-page global callbacks + $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' ); + + ShowRequestedPage($ARGS); + LogRecordedSQLStatements(RequestData => { + Path => $HTML::Mason::Commands::m->request_path, + }); + + # Process per-page final cleanup callbacks + $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' ); + + $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS ) + unless $HTML::Mason::Commands::r->content_type + =~ qr<^(text|application)/(x-)?(css|javascript)>; +} + +sub _ForceLogout { + + delete $HTML::Mason::Commands::session{'CurrentUser'}; +} + +sub _UserLoggedIn { + if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) { + return 1; + } else { + return undef; + } + +} + +=head2 LoginError ERROR + +Pushes a login error into the Actions session store and returns the hash key. + +=cut + +sub LoginError { + my $new = shift; + my $key = Digest::MD5::md5_hex( rand(1024) ); + push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new; + $HTML::Mason::Commands::session{'i'}++; + return $key; +} + +=head2 SetNextPage ARGSRef [PATH] + +Intuits and stashes the next page in the sesssion hash. If PATH is +specified, uses that instead of the value of L<IntuitNextPage()>. Returns +the hash value. + +=cut + +sub SetNextPage { + my $ARGS = shift; + my $next = $_[0] ? $_[0] : IntuitNextPage(); + my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024)); + my $page = { url => $next }; + + # If an explicit URL was passed and we didn't IntuitNextPage, then + # IsPossibleCSRF below is almost certainly unrelated to the actual + # destination. Currently explicit next pages aren't used in RT, but the + # API is available. + if (not $_[0] and RT->Config->Get("RestrictReferrer")) { + # This isn't really CSRF, but the CSRF heuristics are useful for catching + # requests which may have unintended side-effects. + my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS); + if ($is_csrf) { + RT->Logger->notice( + "Marking original destination as having side-effects before redirecting for login.\n" + ."Request: $next\n" + ."Reason: " . HTML::Mason::Commands::loc($msg, @loc) + ); + $page->{'HasSideEffects'} = [$msg, @loc]; + } + } + + $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page; + $HTML::Mason::Commands::session{'i'}++; + return $hash; +} + +=head2 FetchNextPage HASHKEY + +Returns the stashed next page hashref for the given hash. + +=cut + +sub FetchNextPage { + my $hash = shift || ""; + return $HTML::Mason::Commands::session{'NextPage'}->{$hash}; +} + +=head2 RemoveNextPage HASHKEY + +Removes the stashed next page for the given hash and returns it. + +=cut + +sub RemoveNextPage { + my $hash = shift || ""; + return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash}; +} + +=head2 TangentForLogin ARGSRef [HASH] + +Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as +the next page. Takes a hashref of request %ARGS as the first parameter. +Optionally takes all other parameters as a hash which is dumped into query +params. + +=cut + +sub TangentForLogin { + my $ARGS = shift; + my $hash = SetNextPage($ARGS); + my %query = (@_, next => $hash); + + $query{mobile} = 1 + if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)}; + + my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?'; + $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query); + Redirect($login); +} + +=head2 TangentForLoginWithError ERROR + +Localizes the passed error message, stashes it with L<LoginError> and then +calls L<TangentForLogin> with the appropriate results key. + +=cut + +sub TangentForLoginWithError { + my $ARGS = shift; + my $key = LoginError(HTML::Mason::Commands::loc(@_)); + TangentForLogin( $ARGS, results => $key ); +} + +=head2 IntuitNextPage + +Attempt to figure out the path to which we should return the user after a +tangent. The current request URL is used, or failing that, the C<WebURL> +configuration variable. + +=cut + +sub IntuitNextPage { + my $req_uri; + + # This includes any query parameters. Redirect will take care of making + # it an absolute URL. + if ($ENV{'REQUEST_URI'}) { + $req_uri = $ENV{'REQUEST_URI'}; + + # collapse multiple leading slashes so the first part doesn't look like + # a hostname of a schema-less URI + $req_uri =~ s{^/+}{/}; + } + + my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL'); + + # sanitize $next + my $uri = URI->new($next); + + # You get undef scheme with a relative uri like "/Search/Build.html" + unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') { + $next = RT->Config->Get('WebURL'); + } + + # Make sure we're logging in to the same domain + # You can get an undef authority with a relative uri like "index.html" + my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL')); + unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) { + $next = RT->Config->Get('WebURL'); + } + + return $next; +} + +=head2 MaybeShowInstallModePage + +This function, called exclusively by RT's autohandler, dispatches +a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file. + +If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler + +=cut + +sub MaybeShowInstallModePage { + return unless RT->InstallMode; + + my $m = $HTML::Mason::Commands::m; + if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) { + $m->call_next(); + } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) { + RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" ); + } else { + $m->call_next(); + } + $m->abort(); +} + +=head2 MaybeShowNoAuthPage \%ARGS + +This function, called exclusively by RT's autohandler, dispatches +a request to the page a user requested (but only if it matches the "noauth" regex. + +If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler + +=cut + +sub MaybeShowNoAuthPage { + my $ARGS = shift; + + my $m = $HTML::Mason::Commands::m; + + return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex'); + + # Don't show the login page to logged in users + Redirect(RT->Config->Get('WebURL')) + if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn(); + + # If it's a noauth file, don't ask for auth. + $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS ); + $m->abort; +} + +=head2 MaybeRejectPrivateComponentRequest + +This function will reject calls to private components, like those under +C</Elements>. If the requested path is a private component then we will +abort with a C<403> error. + +=cut + +sub MaybeRejectPrivateComponentRequest { + my $m = $HTML::Mason::Commands::m; + my $path = $m->request_comp->path; + + # We do not check for dhandler here, because requesting our dhandlers + # directly is okay. Mason will invoke the dhandler with a dhandler_arg of + # 'dhandler'. + + if ($path =~ m{ + / # leading slash + ( Elements | + _elements | # mobile UI + Callbacks | + Widgets | + autohandler | # requesting this directly is suspicious + l (_unsafe)? ) # loc component + ( $ | / ) # trailing slash or end of path + }xi + && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi + ) + { + warn "rejecting private component $path\n"; + $m->abort(403); + } + + return; +} + +sub InitializeMenu { + $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new()); + $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new()); + $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new()); + +} + + +=head2 ShowRequestedPage \%ARGS + +This function, called exclusively by RT's autohandler, dispatches +a request to the page a user requested (making sure that unpriviled users +can only see self-service pages. + +=cut + +sub ShowRequestedPage { + my $ARGS = shift; + + my $m = $HTML::Mason::Commands::m; + + # Ensure that the cookie that we send is up-to-date, in case the + # session-id has been modified in any way + SendSessionCookie(); + + # precache all system level rights for the current user + $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System ); + + # If the user isn't privileged, they can only see SelfService + unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) { + + # if the user is trying to access a ticket, redirect them + if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) { + RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} ); + } + + # otherwise, drop the user at the SelfService default page + elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) { + RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" ); + } + + # if user is in SelfService dir let him do anything + else { + $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS ); + } + } else { + $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS ); + } + +} + +sub AttemptExternalAuth { + my $ARGS = shift; + + return unless ( RT->Config->Get('WebExternalAuth') ); + + my $user = $ARGS->{user}; + my $m = $HTML::Mason::Commands::m; + + # If RT is configured for external auth, let's go through and get REMOTE_USER + + # do we actually have a REMOTE_USER equivlent? + if ( RT::Interface::Web::WebCanonicalizeInfo() ) { + my $orig_user = $user; + + $user = RT::Interface::Web::WebCanonicalizeInfo(); + my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load'; + + if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) { + my $NodeName = Win32::NodeName(); + $user =~ s/^\Q$NodeName\E\\//i; + } + + my $next = RemoveNextPage($ARGS->{'next'}); + $next = $next->{'url'} if ref $next; + InstantiateNewSession() unless _UserLoggedIn; + $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new(); + $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user); + + if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) { + + # Create users on-the-fly + my $UserObj = RT::User->new(RT->SystemUser); + my ( $val, $msg ) = $UserObj->Create( + %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} }, + Name => $user, + Gecos => $user, + ); + + if ($val) { + + # now get user specific information, to better create our user. + my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user); + + # set the attributes that have been defined. + foreach my $attribute ( $UserObj->WritableAttributes ) { + $m->callback( + Attribute => $attribute, + User => $user, + UserInfo => $new_user_info, + CallbackName => 'NewUser', + CallbackPage => '/autohandler' + ); + my $method = "Set$attribute"; + $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute}; + } + $HTML::Mason::Commands::session{'CurrentUser'}->Load($user); + } else { + + # we failed to successfully create the user. abort abort abort. + delete $HTML::Mason::Commands::session{'CurrentUser'}; + + if (RT->Config->Get('WebFallbackToInternalAuth')) { + TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg); + } else { + $m->abort(); + } + } + } + + if ( _UserLoggedIn() ) { + $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' ); + # It is possible that we did a redirect to the login page, + # if the external auth allows lack of auth through with no + # REMOTE_USER set, instead of forcing a "permission + # denied" message. Honor the $next. + Redirect($next) if $next; + # Unlike AttemptPasswordAuthentication below, we do not + # force a redirect to / if $next is not set -- otherwise, + # straight-up external auth would always redirect to / + # when you first hit it. + } else { + delete $HTML::Mason::Commands::session{'CurrentUser'}; + $user = $orig_user; + + unless ( RT->Config->Get('WebFallbackToInternalAuth') ) { + TangentForLoginWithError($ARGS, 'You are not an authorized user'); + } + } + } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) { + unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) { + # XXX unreachable due to prior defaulting in HandleRequest (check c34d108) + TangentForLoginWithError($ARGS, 'You are not an authorized user'); + } + } else { + + # WebExternalAuth is set, but we don't have a REMOTE_USER. abort + # XXX: we must return AUTH_REQUIRED status or we fallback to + # internal auth here too. + delete $HTML::Mason::Commands::session{'CurrentUser'} + if defined $HTML::Mason::Commands::session{'CurrentUser'}; + } +} + +sub AttemptPasswordAuthentication { + my $ARGS = shift; + return unless defined $ARGS->{user} && defined $ARGS->{pass}; + + my $user_obj = RT::CurrentUser->new(); + $user_obj->Load( $ARGS->{user} ); + + my $m = $HTML::Mason::Commands::m; + + unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) { + $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}"); + $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' ); + return (0, HTML::Mason::Commands::loc('Your username or password is incorrect')); + } + else { + $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}"); + + # It's important to nab the next page from the session before we blow + # the session away + my $next = RemoveNextPage($ARGS->{'next'}); + $next = $next->{'url'} if ref $next; + + InstantiateNewSession(); + $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj; + + $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' ); + + # Really the only time we don't want to redirect here is if we were + # passed user and pass as query params in the URL. + if ($next) { + Redirect($next); + } + elsif ($ARGS->{'next'}) { + # Invalid hash, but still wants to go somewhere, take them to / + Redirect(RT->Config->Get('WebURL')); + } + + return (1, HTML::Mason::Commands::loc('Logged in')); + } +} + +=head2 LoadSessionFromCookie + +Load or setup a session cookie for the current user. + +=cut + +sub _SessionCookieName { + my $cookiename = "RT_SID_" . RT->Config->Get('rtname'); + $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'}; + return $cookiename; +} + +sub LoadSessionFromCookie { + + my %cookies = CGI::Cookie->fetch; + my $cookiename = _SessionCookieName(); + my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef ); + tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie; + unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) { + InstantiateNewSession(); + } + if ( int RT->Config->Get('AutoLogoff') ) { + my $now = int( time / 60 ); + my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0; + + if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) { + InstantiateNewSession(); + } + + # save session on each request when AutoLogoff is turned on + $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update; + } +} + +sub InstantiateNewSession { + tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session); + tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef; + SendSessionCookie(); +} + +sub SendSessionCookie { + my $cookie = CGI::Cookie->new( + -name => _SessionCookieName(), + -value => $HTML::Mason::Commands::session{_session_id}, + -path => RT->Config->Get('WebPath'), + -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ), + -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ), + ); + + $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string; +} + +=head2 Redirect URL + +This routine ells the current user's browser to redirect to URL. +Additionally, it unties the user's currently active session, helping to avoid +A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use +a cached DBI statement handle twice at the same time. + +=cut + +sub Redirect { + my $redir_to = shift; + untie $HTML::Mason::Commands::session; + my $uri = URI->new($redir_to); + my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) ); + + # Make relative URIs absolute from the server host and scheme + $uri->scheme($server_uri->scheme) if not defined $uri->scheme; + if (not defined $uri->host) { + $uri->host($server_uri->host); + $uri->port($server_uri->port); + } + + # If the user is coming in via a non-canonical + # hostname, don't redirect them to the canonical host, + # it will just upset them (and invalidate their credentials) + # don't do this if $RT::CanonicalizeRedirectURLs is true + if ( !RT->Config->Get('CanonicalizeRedirectURLs') + && $uri->host eq $server_uri->host + && $uri->port eq $server_uri->port ) + { + if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) { + $uri->scheme('https'); + } else { + $uri->scheme('http'); + } + + # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST + $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'}); + $uri->port( $ENV{'SERVER_PORT'} ); + } + + # not sure why, but on some systems without this call mason doesn't + # set status to 302, but 200 instead and people see blank pages + $HTML::Mason::Commands::r->status(302); + + # Perlbal expects a status message, but Mason's default redirect status + # doesn't provide one. See also rt.cpan.org #36689. + $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" ); + + $HTML::Mason::Commands::m->abort; +} + +=head2 CacheControlExpiresHeaders + +set both Cache-Control and Expires http headers + +=cut + +sub CacheControlExpiresHeaders { + my %args = @_; + + my $Visibility = 'private'; + if ( ! defined $args{Time} ) { + $args{Time} = 0; + } elsif ( $args{Time} eq 'no-cache' ) { + $args{Time} = 0; + } elsif ( $args{Time} eq 'forever' ) { + $args{Time} = 30 * 24 * 60 * 60; + $Visibility = 'public'; + } + + my $CacheControl = $args{Time} + ? sprintf "max-age=%d, %s", $args{Time}, $Visibility + : 'no-cache' + ; + $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl; + + my $expires = RT::Date->new(RT->SystemUser); + $expires->SetToNow; + $expires->AddSeconds( $args{Time} ) if $args{Time}; + + $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616; +} + +=head2 StaticFileHeaders + +Send the browser a few headers to try to get it to (somewhat agressively) +cache RT's static Javascript and CSS files. + +This routine could really use _accurate_ heuristics. (XXX TODO) + +=cut + +sub StaticFileHeaders { + my $date = RT::Date->new(RT->SystemUser); + + # remove any cookie headers -- if it is cached publicly, it + # shouldn't include anyone's cookie! + delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'}; + + # Expire things in a month. + CacheControlExpiresHeaders( Time => 'forever' ); + + # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since' + # request, but we don't handle it and generate full reply again + # Last modified at server start time + # $date->Set( Value => $^T ); + # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616; +} + +=head2 ComponentPathIsSafe PATH + +Takes C<PATH> and returns a boolean indicating that the user-specified partial +component path is safe. + +Currently "safe" means that the path does not start with a dot (C<.>), does +not contain a slash-dot C</.>, and does not contain any nulls. + +=cut + +sub ComponentPathIsSafe { + my $self = shift; + my $path = shift; + return($path !~ m{(?:^|/)\.} and $path !~ m{\0}); +} + +=head2 PathIsSafe + +Takes a C<< Path => path >> and returns a boolean indicating that +the path is safely within RT's control or not. The path I<must> be +relative. + +This function does not consult the filesystem at all; it is merely +a logical sanity checking of the path. This explicitly does not handle +symlinks; if you have symlinks in RT's webroot pointing outside of it, +then we assume you know what you are doing. + +=cut + +sub PathIsSafe { + my $self = shift; + my %args = @_; + my $path = $args{Path}; + + # Get File::Spec to clean up extra /s, ./, etc + my $cleaned_up = File::Spec->canonpath($path); + + if (!defined($cleaned_up)) { + $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path"); + return 0; + } + + # Forbid too many ..s. We can't just sum then check because + # "../foo/bar/baz" should be illegal even though it has more + # downdirs than updirs. So as soon as we get a negative score + # (which means "breaking out" of the top level) we reject the path. + + my @components = split '/', $cleaned_up; + my $score = 0; + for my $component (@components) { + if ($component eq '..') { + $score--; + if ($score < 0) { + $RT::Logger->info("Rejecting unsafe path: $path"); + return 0; + } + } + elsif ($component eq '.' || $component eq '') { + # these two have no effect on $score + } + else { + $score++; + } + } + + return 1; +} + +=head2 SendStaticFile + +Takes a File => path and a Type => Content-type + +If Type isn't provided and File is an image, it will +figure out a sane Content-type, otherwise it will +send application/octet-stream + +Will set caching headers using StaticFileHeaders + +=cut + +sub SendStaticFile { + my $self = shift; + my %args = @_; + my $file = $args{File}; + my $type = $args{Type}; + my $relfile = $args{RelativeFile}; + + if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) { + $HTML::Mason::Commands::r->status(400); + $HTML::Mason::Commands::m->abort; + } + + $self->StaticFileHeaders(); + + unless ($type) { + if ( $file =~ /\.(gif|png|jpe?g)$/i ) { + $type = "image/$1"; + $type =~ s/jpg/jpeg/gi; + } + $type ||= "application/octet-stream"; + } + $HTML::Mason::Commands::r->content_type($type); + open( my $fh, '<', $file ) or die "couldn't open file: $!"; + binmode($fh); + { + local $/ = \16384; + $HTML::Mason::Commands::m->out($_) while (<$fh>); + $HTML::Mason::Commands::m->flush_buffer; + } + close $fh; +} + + + +sub MobileClient { + my $self = shift; + + +if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) { + return 1; +} else { + return undef; +} + +} + + +sub StripContent { + my %args = @_; + my $content = $args{Content}; + return '' unless $content; + + # Make the content have no 'weird' newlines in it + $content =~ s/\r+\n/\n/g; + + my $return_content = $content; + + my $html = $args{ContentType} && $args{ContentType} eq "text/html"; + my $sigonly = $args{StripSignature}; + + # massage content to easily detect if there's any real content + $content =~ s/\s+//g; # yes! remove all the spaces + if ( $html ) { + # remove html version of spaces and newlines + $content =~ s! !!g; + $content =~ s!<br/?>!!g; + } + + # Filter empty content when type is text/html + return '' if $html && $content !~ /\S/; + + # If we aren't supposed to strip the sig, just bail now. + return $return_content unless $sigonly; + + # Find the signature + my $sig = $args{'CurrentUser'}->UserObj->Signature || ''; + $sig =~ s/\s+//g; + + # Check for plaintext sig + return '' if not $html and $content =~ /^(--)?\Q$sig\E$/; + + # Check for html-formatted sig; we don't use EscapeUTF8 here + # because we want to precisely match the escapting that FCKEditor + # uses. + $sig =~ s/&/&/g; + $sig =~ s/</</g; + $sig =~ s/>/>/g; + $sig =~ s/"/"/g; + $sig =~ s/'/'/g; + return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s; + + # Pass it through + return $return_content; +} + +sub DecodeARGS { + my $ARGS = shift; + + %{$ARGS} = map { + + # if they've passed multiple values, they'll be an array. if they've + # passed just one, a scalar whatever they are, mark them as utf8 + my $type = ref($_); + ( !$type ) + ? Encode::is_utf8($_) + ? $_ + : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) + : ( $type eq 'ARRAY' ) + ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } + @$_ ] + : ( $type eq 'HASH' ) + ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } + %$_ } + : $_ + } %$ARGS; +} + +sub PreprocessTimeUpdates { + my $ARGS = shift; + + # Later in the code we use + # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS ); + # instead of $m->call_next to avoid problems with UTF8 keys in arguments. + # The call_next method pass through original arguments and if you have + # an argument with unicode key then in a next component you'll get two + # records in the args hash: one with key without UTF8 flag and another + # with the flag, which may result into errors. "{ base_comp => $m->request_comp }" + # is copied from mason's source to get the same results as we get from + # call_next method, this feature is not documented, so we just leave it + # here to avoid possible side effects. + + # This code canonicalizes time inputs in hours into minutes + foreach my $field ( keys %$ARGS ) { + next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1}; + my $local = $1; + $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b} + {($1 || 0) + $3 ? $2 / $3 : 0}xe; + if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) { + $ARGS->{$local} *= 60; + } + delete $ARGS->{$field}; + } + +} + +sub MaybeEnableSQLStatementLog { + + my $log_sql_statements = RT->Config->Get('StatementLog'); + + if ($log_sql_statements) { + $RT::Handle->ClearSQLStatementLog; + $RT::Handle->LogSQLStatements(1); + } + +} + +sub LogRecordedSQLStatements { + my %args = @_; + + my $log_sql_statements = RT->Config->Get('StatementLog'); + + return unless ($log_sql_statements); + + my @log = $RT::Handle->SQLStatementLog; + $RT::Handle->ClearSQLStatementLog; + + $RT::Handle->AddRequestToHistory({ + %{ $args{RequestData} }, + Queries => \@log, + }); + + for my $stmt (@log) { + my ( $time, $sql, $bind, $duration ) = @{$stmt}; + my @bind; + if ( ref $bind ) { + @bind = @{$bind}; + } else { + + # Older DBIx-SB + $duration = $bind; + } + $RT::Logger->log( + level => $log_sql_statements, + message => "SQL(" + . sprintf( "%.6f", $duration ) + . "s): $sql;" + . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" ) + ); + } + +} + +my $_has_validated_web_config = 0; +sub ValidateWebConfig { + my $self = shift; + + # do this once per server instance, not once per request + return if $_has_validated_web_config; + $_has_validated_web_config = 1; + + my $port = $ENV{SERVER_PORT}; + my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER} + || $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; + ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/; + + if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) { + $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). " + ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, " + ."otherwise your internal links may be broken."); + } + + if ( $host ne RT->Config->Get('WebDomain') ) { + $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). " + ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, " + ."otherwise your internal links may be broken."); + } + + return; #next warning flooding our logs, doesn't seem applicable to our use + # (SCRIPT_NAME is the full path, WebPath is just the beginning) + #in vanilla RT does something eat the local part of SCRIPT_NAME 1st? + + # Unfortunately, there is no reliable way to get the _path_ that was + # requested at the proxy level; simply disable this warning if we're + # proxied and there's a mismatch. + my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}; + if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) { + $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). " + ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, " + ."otherwise your internal links may be broken."); + } +} + +sub ComponentRoots { + my $self = shift; + my %args = ( Names => 0, @_ ); + my @roots; + if (defined $HTML::Mason::Commands::m) { + @roots = $HTML::Mason::Commands::m->interp->comp_root_array; + } else { + @roots = ( + [ local => $RT::MasonLocalComponentRoot ], + (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}), + [ standard => $RT::MasonComponentRoot ] + ); + } + @roots = map { $_->[1] } @roots unless $args{Names}; + return @roots; +} + +our %is_whitelisted_component = ( + # The RSS feed embeds an auth token in the path, but query + # information for the search. Because it's a straight-up read, in + # addition to embedding its own auth, it's fine. + '/NoAuth/rss/dhandler' => 1, + + # While these can be used for denial-of-service against RT + # (construct a very inefficient query and trick lots of users into + # running them against RT) it's incredibly useful to be able to link + # to a search result (or chart) or bookmark a result page. + '/Search/Results.html' => 1, + '/Search/Simple.html' => 1, + '/m/tickets/search' => 1, + '/Search/Chart.html' => 1, + + # This page takes Attachment and Transaction argument to figure + # out what to show, but it's read only and will deny information if you + # don't have ShowOutgoingEmail. + '/Ticket/ShowEmailRecord.html' => 1, +); + +# Components which are blacklisted from automatic, argument-based whitelisting. +# These pages are not idempotent when called with just an id. +our %is_blacklisted_component = ( + # Takes only id and toggles bookmark state + '/Helpers/Toggle/TicketBookmark' => 1, +); + +sub IsCompCSRFWhitelisted { + my $comp = shift; + my $ARGS = shift; + + return 1 if $is_whitelisted_component{$comp}; + + my %args = %{ $ARGS }; + + # If the user specifies a *correct* user and pass then they are + # golden. This acts on the presumption that external forms may + # hardcode a username and password -- if a malicious attacker knew + # both already, CSRF is the least of your problems. + my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin'); + if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) { + my $user_obj = RT::CurrentUser->new(); + $user_obj->Load($args{user}); + return 1 if $user_obj->id && $user_obj->IsPassword($args{pass}); + + delete $args{user}; + delete $args{pass}; + } + + # Some pages aren't idempotent even with safe args like id; blacklist + # them from the automatic whitelisting below. + return 0 if $is_blacklisted_component{$comp}; + + # Eliminate arguments that do not indicate an effectful request. + # For example, "id" is acceptable because that is how RT retrieves a + # record. + delete $args{id}; + + # If they have a results= from MaybeRedirectForResults, that's also fine. + delete $args{results}; + + # The homepage refresh, which uses the Refresh header, doesn't send + # a referer in most browsers; whitelist the one parameter it reloads + # with, HomeRefreshInterval, which is safe + delete $args{HomeRefreshInterval}; + + # The NotMobile flag is fine for any page; it's only used to toggle a flag + # in the session related to which interface you get. + delete $args{NotMobile}; + + # If there are no arguments, then it's likely to be an idempotent + # request, which are not susceptible to CSRF + return 1 if !%args; + + return 0; +} + +sub IsRefererCSRFWhitelisted { + my $referer = _NormalizeHost(shift); + my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL')); + $base_url = $base_url->host_port; + + my $configs; + for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) { + push @$configs,$config; + + my $host_port = $referer->host_port; + if ($config =~ /\*/) { + # Turn a literal * into a domain component or partial component match. + # Refer to http://tools.ietf.org/html/rfc2818#page-5 + my $regex = join "[a-zA-Z0-9\-]*", + map { quotemeta($_) } + split /\*/, $config; + + return 1 if $host_port =~ /^$regex$/i; + } else { + return 1 if $host_port eq $config; + } + } + + return (0,$referer,$configs); +} + +=head3 _NormalizeHost + +Takes a URI and creates a URI object that's been normalized +to handle common problems such as localhost vs 127.0.0.1 + +=cut + +sub _NormalizeHost { + my $s = shift; + $s = "http://$s" unless $s =~ /^http/i; + my $uri= URI->new($s); + $uri->host('127.0.0.1') if $uri->host eq 'localhost'; + + return $uri; + +} + +sub IsPossibleCSRF { + my $ARGS = shift; + + # If first request on this session is to a REST endpoint, then + # whitelist the REST endpoints -- and explicitly deny non-REST + # endpoints. We do this because using a REST cookie in a browser + # would open the user to CSRF attacks to the REST endpoints. + my $path = $HTML::Mason::Commands::r->path_info; + $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)} + unless defined $HTML::Mason::Commands::session{'REST'}; + + if ($HTML::Mason::Commands::session{'REST'}) { + return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)}; + my $why = <<EOT; +This login session belongs to a REST client, and cannot be used to +access non-REST interfaces of RT for security reasons. +EOT + my $details = <<EOT; +Please log out and back in to obtain a session for normal browsing. If +you understand the security implications, disabling RT's CSRF protection +will remove this restriction. +EOT + chomp $details; + HTML::Mason::Commands::Abort( $why, Details => $details ); + } + + return 0 if IsCompCSRFWhitelisted( + $HTML::Mason::Commands::m->request_comp->path, + $ARGS + ); + + # if there is no Referer header then assume the worst + return (1, + "your browser did not supply a Referrer header", # loc + ) if !$ENV{HTTP_REFERER}; + + my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER}); + return 0 if $whitelisted; + + if ( @$configs > 1 ) { + return (1, + "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc + $browser->host_port, + shift @$configs, + join(', ', @$configs) ); + } + + return (1, + "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc + $browser->host_port, + $configs->[0]); +} + +sub ExpandCSRFToken { + my $ARGS = shift; + + my $token = delete $ARGS->{CSRF_Token}; + return unless $token; + + my $data = $HTML::Mason::Commands::session{'CSRF'}{$token}; + return unless $data; + return unless $data->{path} eq $HTML::Mason::Commands::r->path_info; + + my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj; + return unless $user->ValidateAuthString( $data->{auth}, $token ); + + %{$ARGS} = %{$data->{args}}; + $HTML::Mason::Commands::DECODED_ARGS = $ARGS; + + # We explicitly stored file attachments with the request, but not in + # the session yet, as that would itself be an attack. Put them into + # the session now, so they'll be visible. + if ($data->{attach}) { + my $filename = $data->{attach}{filename}; + my $mime = $data->{attach}{mime}; + $HTML::Mason::Commands::session{'Attachments'}{$filename} + = $mime; + } + + return 1; +} + +sub StoreRequestToken { + my $ARGS = shift; + + my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024)); + my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj; + my $data = { + auth => $user->GenerateAuthString( $token ), + path => $HTML::Mason::Commands::r->path_info, + args => $ARGS, + }; + if ($ARGS->{Attach}) { + my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' ); + my $file_path = delete $ARGS->{'Attach'}; + $data->{attach} = { + filename => Encode::decode_utf8("$file_path"), + mime => $attachment, + }; + } + + $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data; + $HTML::Mason::Commands::session{'i'}++; + return $token; +} + +sub MaybeShowInterstitialCSRFPage { + my $ARGS = shift; + + return unless RT->Config->Get('RestrictReferrer'); + + # Deal with the form token provided by the interstitial, which lets + # browsers which never set referer headers still use RT, if + # painfully. This blows values into ARGS + return if ExpandCSRFToken($ARGS); + + my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS); + return if !$is_csrf; + + $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc)); + + my $token = StoreRequestToken($ARGS); + $HTML::Mason::Commands::m->comp( + '/Elements/CSRF', + OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info, + Reason => HTML::Mason::Commands::loc( $msg, @loc ), + Token => $token, + ); + # Calls abort, never gets here +} + +our @POTENTIAL_PAGE_ACTIONS = ( + qr'/Ticket/Create.html' => "create a ticket", # loc + qr'/Ticket/' => "update a ticket", # loc + qr'/Admin/' => "modify RT's configuration", # loc + qr'/Approval/' => "update an approval", # loc + qr'/Articles/' => "update an article", # loc + qr'/Dashboards/' => "modify a dashboard", # loc + qr'/m/ticket/' => "update a ticket", # loc + qr'Prefs' => "modify your preferences", # loc + qr'/Search/' => "modify or access a search", # loc + qr'/SelfService/Create' => "create a ticket", # loc + qr'/SelfService/' => "update a ticket", # loc +); + +sub PotentialPageAction { + my $page = shift; + my @potentials = @POTENTIAL_PAGE_ACTIONS; + while (my ($pattern, $result) = splice @potentials, 0, 2) { + return HTML::Mason::Commands::loc($result) + if $page =~ $pattern; + } + return ""; +} + +package HTML::Mason::Commands; + +use vars qw/$r $m %session/; + +sub Menu { + return $HTML::Mason::Commands::m->notes('menu'); +} + +sub PageMenu { + return $HTML::Mason::Commands::m->notes('page-menu'); +} + +sub PageWidgets { + return $HTML::Mason::Commands::m->notes('page-widgets'); +} + + + +=head2 loc ARRAY + +loc is a nice clean global routine which calls $session{'CurrentUser'}->loc() +with whatever it's called with. If there is no $session{'CurrentUser'}, +it creates a temporary user, so we have something to get a localisation handle +through + +=cut + +sub loc { + + if ( $session{'CurrentUser'} + && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) ) + { + return ( $session{'CurrentUser'}->loc(@_) ); + } elsif ( + my $u = eval { + RT::CurrentUser->new(); + } + ) + { + return ( $u->loc(@_) ); + } else { + + # pathetic case -- SystemUser is gone. + return $_[0]; + } +} + + + +=head2 loc_fuzzy STRING + +loc_fuzzy is for handling localizations of messages that may already +contain interpolated variables, typically returned from libraries +outside RT's control. It takes the message string and extracts the +variable array automatically by matching against the candidate entries +inside the lexicon file. + +=cut + +sub loc_fuzzy { + my $msg = shift; + + if ( $session{'CurrentUser'} + && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) ) + { + return ( $session{'CurrentUser'}->loc_fuzzy($msg) ); + } else { + my $u = RT::CurrentUser->new( RT->SystemUser->Id ); + return ( $u->loc_fuzzy($msg) ); + } +} + + +# Error - calls Error and aborts +sub Abort { + my $why = shift; + my %args = @_; + + if ( $session{'ErrorDocument'} + && $session{'ErrorDocumentType'} ) + { + $r->content_type( $session{'ErrorDocumentType'} ); + $m->comp( $session{'ErrorDocument'}, Why => $why, %args ); + $m->abort; + } else { + $m->comp( "/Elements/Error", Why => $why, %args ); + $m->abort; + } +} + +sub MaybeRedirectForResults { + my %args = ( + Path => $HTML::Mason::Commands::m->request_comp->path, + Arguments => {}, + Anchor => undef, + Actions => undef, + Force => 0, + @_ + ); + my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } ); + return unless $has_actions || $args{'Force'}; + + my %arguments = %{ $args{'Arguments'} }; + + if ( $has_actions ) { + my $key = Digest::MD5::md5_hex( rand(1024) ); + push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} }; + $session{'i'}++; + $arguments{'results'} = $key; + } + + $args{'Path'} =~ s!^/+!!; + my $url = RT->Config->Get('WebURL') . $args{Path}; + + if ( keys %arguments ) { + $url .= '?'. $m->comp( '/Elements/QueryString', %arguments ); + } + if ( $args{'Anchor'} ) { + $url .= "#". $args{'Anchor'}; + } + return RT::Interface::Web::Redirect($url); +} + +=head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF + +If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket, +redirect to the approvals display page, preserving any arguments. + +C<Path>s matching C<Whitelist> are let through. + +This is a no-op if the C<ForceApprovalsView> option isn't enabled. + +=cut + +sub MaybeRedirectToApproval { + my %args = ( + Path => $HTML::Mason::Commands::m->request_comp->path, + ARGSRef => {}, + Whitelist => undef, + @_ + ); + + return unless $ENV{REQUEST_METHOD} eq 'GET'; + + my $id = $args{ARGSRef}->{id}; + + if ( $id + and RT->Config->Get('ForceApprovalsView') + and not $args{Path} =~ /$args{Whitelist}/) + { + my $ticket = RT::Ticket->new( $session{'CurrentUser'} ); + $ticket->Load($id); + + if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') { + MaybeRedirectForResults( + Path => "/Approvals/Display.html", + Force => 1, + Anchor => $args{ARGSRef}->{Anchor}, + Arguments => $args{ARGSRef}, + ); + } + } +} + +=head2 CreateTicket ARGS + +Create a new ticket, using Mason's %ARGS. returns @results. + +=cut + +sub CreateTicket { + my %ARGS = (@_); + + my (@Actions); + + my $Ticket = RT::Ticket->new( $session{'CurrentUser'} ); + + my $Queue = RT::Queue->new( $session{'CurrentUser'} ); + unless ( $Queue->Load( $ARGS{'Queue'} ) ) { + Abort('Queue not found'); + } + + unless ( $Queue->CurrentUserHasRight('CreateTicket') ) { + Abort('You have no permission to create tickets in that queue.'); + } + + my $due; + if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) { + $due = RT::Date->new( $session{'CurrentUser'} ); + $due->Set( Format => 'unknown', Value => $ARGS{'Due'} ); + } + my $starts; + if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) { + $starts = RT::Date->new( $session{'CurrentUser'} ); + $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} ); + } + + my $sigless = RT::Interface::Web::StripContent( + Content => $ARGS{Content}, + ContentType => $ARGS{ContentType}, + StripSignature => 1, + CurrentUser => $session{'CurrentUser'}, + ); + + my $MIMEObj = MakeMIMEEntity( + Subject => $ARGS{'Subject'}, + From => $ARGS{'From'}, + Cc => $ARGS{'Cc'}, + Body => $sigless, + Type => $ARGS{'ContentType'}, + Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web', + ); + + if ( $ARGS{'Attachments'} ) { + my $rv = $MIMEObj->make_multipart; + $RT::Logger->error("Couldn't make multipart message") + if !$rv || $rv !~ /^(?:DONE|ALREADY)$/; + + foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) { + unless ($_) { + $RT::Logger->error("Couldn't add empty attachemnt"); + next; + } + $MIMEObj->add_part($_); + } + } + + for my $argument (qw(Encrypt Sign)) { + $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 ); + } + + my %create_args = ( + Type => $ARGS{'Type'} || 'ticket', + Queue => $ARGS{'Queue'}, + Owner => $ARGS{'Owner'}, + + # note: name change + Requestor => $ARGS{'Requestors'}, + Cc => $ARGS{'Cc'}, + AdminCc => $ARGS{'AdminCc'}, + InitialPriority => $ARGS{'InitialPriority'}, + FinalPriority => $ARGS{'FinalPriority'}, + TimeLeft => $ARGS{'TimeLeft'}, + TimeEstimated => $ARGS{'TimeEstimated'}, + TimeWorked => $ARGS{'TimeWorked'}, + Subject => $ARGS{'Subject'}, + Status => $ARGS{'Status'}, + Due => $due ? $due->ISO : undef, + Starts => $starts ? $starts->ISO : undef, + MIMEObj => $MIMEObj + ); + + my @txn_squelch; + foreach my $type (qw(Requestor Cc AdminCc)) { + push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} ) + if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] }; + } + $create_args{TransSquelchMailTo} = \@txn_squelch + if @txn_squelch; + + if ( $ARGS{'AttachTickets'} ) { + require RT::Action::SendEmail; + RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets, + ref $ARGS{'AttachTickets'} + ? @{ $ARGS{'AttachTickets'} } + : ( $ARGS{'AttachTickets'} ) ); + } + + foreach my $arg ( keys %ARGS ) { + next if $arg =~ /-(?:Magic|Category)$/; + + if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) { + $create_args{$arg} = $ARGS{$arg}; + } + + # Object-RT::Ticket--CustomField-3-Values + elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) { + my $cfid = $1; + + my $cf = RT::CustomField->new( $session{'CurrentUser'} ); + $cf->SetContextObject( $Queue ); + $cf->Load($cfid); + unless ( $cf->id ) { + $RT::Logger->error( "Couldn't load custom field #" . $cfid ); + next; + } + + if ( $arg =~ /-Upload$/ ) { + $create_args{"CustomField-$cfid"} = _UploadedFile($arg); + next; + } + + my $type = $cf->Type; + + my @values = (); + if ( ref $ARGS{$arg} eq 'ARRAY' ) { + @values = @{ $ARGS{$arg} }; + } elsif ( $type =~ /text/i ) { + @values = ( $ARGS{$arg} ); + } else { + no warnings 'uninitialized'; + @values = split /\r*\n/, $ARGS{$arg}; + } + @values = grep length, map { + s/\r+\n/\n/g; + s/^\s+//; + s/\s+$//; + $_; + } + grep defined, @values; + + $create_args{"CustomField-$cfid"} = \@values; + } + } + + # turn new link lists into arrays, and pass in the proper arguments + my %map = ( + 'new-DependsOn' => 'DependsOn', + 'DependsOn-new' => 'DependedOnBy', + 'new-MemberOf' => 'Parents', + 'MemberOf-new' => 'Children', + 'new-RefersTo' => 'RefersTo', + 'RefersTo-new' => 'ReferredToBy', + ); + foreach my $key ( keys %map ) { + next unless $ARGS{$key}; + $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ]; + + } + + my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args); + unless ($id) { + Abort($ErrMsg); + } + + push( @Actions, split( "\n", $ErrMsg ) ); + unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) { + Abort( "No permission to view newly created ticket #" . $Ticket->id . "." ); + } + return ( $Ticket, @Actions ); + +} + + + +=head2 LoadTicket id + +Takes a ticket id as its only variable. if it's handed an array, it takes +the first value. + +Returns an RT::Ticket object as the current user. + +=cut + +sub LoadTicket { + my $id = shift; + + if ( ref($id) eq "ARRAY" ) { + $id = $id->[0]; + } + + unless ($id) { + Abort("No ticket specified"); + } + + my $Ticket = RT::Ticket->new( $session{'CurrentUser'} ); + $Ticket->Load($id); + unless ( $Ticket->id ) { + Abort("Could not load ticket $id"); + } + return $Ticket; +} + + + +=head2 ProcessUpdateMessage + +Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly. + +Don't write message if it only contains current user's signature and +SkipSignatureOnly argument is true. Function anyway adds attachments +and updates time worked field even if skips message. The default value +is true. + +=cut + +# change from stock: if txn custom fields are set but there's no content +# or attachment, create a Touch txn instead of doing nothing + +sub ProcessUpdateMessage { + + my %args = ( + ARGSRef => undef, + TicketObj => undef, + SkipSignatureOnly => 1, + @_ + ); + + if ( $args{ARGSRef}->{'UpdateAttachments'} + && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } ) + { + delete $args{ARGSRef}->{'UpdateAttachments'}; + } + + # Strip the signature + $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent( + Content => $args{ARGSRef}->{UpdateContent}, + ContentType => $args{ARGSRef}->{UpdateContentType}, + StripSignature => $args{SkipSignatureOnly}, + CurrentUser => $args{'TicketObj'}->CurrentUser, + ); + + my %txn_customfields; + + foreach my $key ( keys %{ $args{ARGSRef} } ) { + if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) { + next if $key =~ /(TimeUnits|Magic)$/; + $txn_customfields{$key} = $args{ARGSRef}->{$key}; + } + } + + # If, after stripping the signature, we have no message, create a + # Touch transaction if necessary + if ( not $args{ARGSRef}->{'UpdateAttachments'} + and not length $args{ARGSRef}->{'UpdateContent'} ) + { + #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) { + # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + + # delete $args{ARGSRef}->{'UpdateTimeWorked'}; + # } + + my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'}; + if ( $timetaken or grep {length $_} values %txn_customfields ) { + my ( $Transaction, $Description, $Object ) = + $args{TicketObj}->Touch( + CustomFields => \%txn_customfields, + TimeTaken => $timetaken + ); + return $Description; + } + return; + } + + if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) { + $args{ARGSRef}->{'UpdateSubject'} = undef; + } + + my $Message = MakeMIMEEntity( + Subject => $args{ARGSRef}->{'UpdateSubject'}, + Body => $args{ARGSRef}->{'UpdateContent'}, + Type => $args{ARGSRef}->{'UpdateContentType'}, + Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web', + ); + + $Message->head->replace( 'Message-ID' => Encode::encode_utf8( + RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} ) + ) ); + my $old_txn = RT::Transaction->new( $session{'CurrentUser'} ); + if ( $args{ARGSRef}->{'QuoteTransaction'} ) { + $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} ); + } else { + $old_txn = $args{TicketObj}->Transactions->First(); + } + + if ( my $msg = $old_txn->Message->First ) { + RT::Interface::Email::SetInReplyTo( + Message => $Message, + InReplyTo => $msg + ); + } + + if ( $args{ARGSRef}->{'UpdateAttachments'} ) { + $Message->make_multipart; + $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_}, + sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} }; + } + + if ( $args{ARGSRef}->{'AttachTickets'} ) { + require RT::Action::SendEmail; + RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets, + ref $args{ARGSRef}->{'AttachTickets'} + ? @{ $args{ARGSRef}->{'AttachTickets'} } + : ( $args{ARGSRef}->{'AttachTickets'} ) ); + } + + my %message_args = ( + Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ), + Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ), + MIMEObj => $Message, + TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}, + CustomFields => \%txn_customfields, + ); + + _ProcessUpdateMessageRecipients( + MessageArgs => \%message_args, + %args, + ); + + my @results; + if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) { + my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args); + push( @results, $Description ); + $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; + } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) { + my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args); + push( @results, $Description ); + $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; + } else { + push( @results, + loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") ); + } + return @results; +} + +sub _ProcessUpdateMessageRecipients { + my %args = ( + ARGSRef => undef, + TicketObj => undef, + MessageArgs => undef, + @_, + ); + + my $bcc = $args{ARGSRef}->{'UpdateBcc'}; + my $cc = $args{ARGSRef}->{'UpdateCc'}; + + my $message_args = $args{MessageArgs}; + + $message_args->{CcMessageTo} = $cc; + $message_args->{BccMessageTo} = $bcc; + + my @txn_squelch; + foreach my $type (qw(Cc AdminCc)) { + if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) { + push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} ); + push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses; + push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses; + } + } + if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) { + push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} ); + push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses; + } + + push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo}; + $message_args->{SquelchMailTo} = \@txn_squelch + if @txn_squelch; + + unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) { + foreach my $key ( keys %{ $args{ARGSRef} } ) { + next unless $key =~ /^Update(Cc|Bcc)-(.*)$/; + + my $var = ucfirst($1) . 'MessageTo'; + my $value = $2; + if ( $message_args->{$var} ) { + $message_args->{$var} .= ", $value"; + } else { + $message_args->{$var} = $value; + } + } + } +} + +sub ProcessAttachments { + my %args = ( + ARGSRef => {}, + @_ + ); + + my $ARGSRef = $args{ARGSRef} || {}; + # deal with deleting uploaded attachments + foreach my $key ( keys %$ARGSRef ) { + if ( $key =~ m/^DeleteAttach-(.+)$/ ) { + delete $session{'Attachments'}{$1}; + } + $session{'Attachments'} = { %{ $session{'Attachments'} || {} } }; + } + + # store the uploaded attachment in session + if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} ) + { # attachment? + my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' ); + + my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}"); + $session{'Attachments'} = + { %{ $session{'Attachments'} || {} }, $file_path => $attachment, }; + } + + # delete temporary storage entry to make WebUI clean + unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} ) + { + delete $session{'Attachments'}; + } +} + + +=head2 MakeMIMEEntity PARAMHASH + +Takes a paramhash Subject, Body and AttachmentFieldName. + +Also takes Form, Cc and Type as optional paramhash keys. + + Returns a MIME::Entity. + +=cut + +sub MakeMIMEEntity { + + #TODO document what else this takes. + my %args = ( + Subject => undef, + From => undef, + Cc => undef, + Body => undef, + AttachmentFieldName => undef, + Type => undef, + Interface => 'API', + @_, + ); + my $Message = MIME::Entity->build( + Type => 'multipart/mixed', + "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ), + "X-RT-Interface" => $args{Interface}, + map { $_ => Encode::encode_utf8( $args{ $_} ) } + grep defined $args{$_}, qw(Subject From Cc) + ); + + if ( defined $args{'Body'} && length $args{'Body'} ) { + + # Make the update content have no 'weird' newlines in it + $args{'Body'} =~ s/\r\n/\n/gs; + + $Message->attach( + Type => $args{'Type'} || 'text/plain', + Charset => 'UTF-8', + Data => $args{'Body'}, + ); + } + + if ( $args{'AttachmentFieldName'} ) { + + my $cgi_object = $m->cgi_object; + my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ); + if ( defined $filehandle && length $filehandle ) { + + my ( @content, $buffer ); + while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) { + push @content, $buffer; + } + + my $uploadinfo = $cgi_object->uploadInfo($filehandle); + + my $filename = "$filehandle"; + $filename =~ s{^.*[\\/]}{}; + + $Message->attach( + Type => $uploadinfo->{'Content-Type'}, + Filename => $filename, + Data => \@content, + ); + if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) { + $Message->head->set( 'Subject' => $filename ); + } + + # Attachment parts really shouldn't get a Message-ID or "interface" + $Message->head->delete('Message-ID'); + $Message->head->delete('X-RT-Interface'); + } + } + + $Message->make_singlepart; + + RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8 + + return ($Message); + +} + + + +=head2 ParseDateToISO + +Takes a date in an arbitrary format. +Returns an ISO date and time in GMT + +=cut + +sub ParseDateToISO { + my $date = shift; + + my $date_obj = RT::Date->new( $session{'CurrentUser'} ); + $date_obj->Set( + Format => 'unknown', + Value => $date + ); + return ( $date_obj->ISO ); +} + + + +sub ProcessACLChanges { + my $ARGSref = shift; + + my @results; + + foreach my $arg ( keys %$ARGSref ) { + next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ ); + + my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 ); + + my @rights; + if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) { + @rights = @{ $ARGSref->{$arg} }; + } else { + @rights = $ARGSref->{$arg}; + } + @rights = grep $_, @rights; + next unless @rights; + + my $principal = RT::Principal->new( $session{'CurrentUser'} ); + $principal->Load($principal_id); + + my $obj; + if ( $object_type eq 'RT::System' ) { + $obj = $RT::System; + } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) { + $obj = $object_type->new( $session{'CurrentUser'} ); + $obj->Load($object_id); + unless ( $obj->id ) { + $RT::Logger->error("couldn't load $object_type #$object_id"); + next; + } + } else { + $RT::Logger->error("object type '$object_type' is incorrect"); + push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) ); + next; + } + + foreach my $right (@rights) { + my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right ); + push( @results, $msg ); + } + } + + return (@results); +} + + +=head2 ProcessACLs + +ProcessACLs expects values from a series of checkboxes that describe the full +set of rights a principal should have on an object. + +It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId +instead of with the prefixes Grant/RevokeRight. Each input should be an array +listing the rights the principal should have, and ProcessACLs will modify the +current rights to match. Additionally, the previously unused CheckACL input +listing PrincipalId-ObjType-ObjId is now used to catch cases when all the +rights are removed from a principal and as such no SetRights input is +submitted. + +=cut + +sub ProcessACLs { + my $ARGSref = shift; + my (%state, @results); + + my $CheckACL = $ARGSref->{'CheckACL'}; + my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL); + + # Check if we want to grant rights to a previously rights-less user + for my $type (qw(user group)) { + my $principal = _ParseACLNewPrincipal($ARGSref, $type) + or next; + + unless ($principal->PrincipalId) { + push @results, loc("Couldn't load the specified principal"); + next; + } + + my $principal_id = $principal->PrincipalId; + + # Turn our addprincipal rights spec into a real one + for my $arg (keys %$ARGSref) { + next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/; + + my $tuple = "$principal_id-$1"; + my $key = "SetRights-$tuple"; + + # If we have it already, that's odd, but merge them + if (grep { $_ eq $tuple } @check) { + $ARGSref->{$key} = [ + (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}), + (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}), + ]; + } else { + $ARGSref->{$key} = $ARGSref->{$arg}; + push @check, $tuple; + } + } + } + + # Build our rights state for each Principal-Object tuple + foreach my $arg ( keys %$ARGSref ) { + next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/; + + my $tuple = $1; + my $value = $ARGSref->{$arg}; + my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value); + next unless @rights; + + $state{$tuple} = { map { $_ => 1 } @rights }; + } + + foreach my $tuple (List::MoreUtils::uniq @check) { + next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/; + + my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 ); + + my $principal = RT::Principal->new( $session{'CurrentUser'} ); + $principal->Load($principal_id); + + my $obj; + if ( $object_type eq 'RT::System' ) { + $obj = $RT::System; + } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) { + $obj = $object_type->new( $session{'CurrentUser'} ); + $obj->Load($object_id); + unless ( $obj->id ) { + $RT::Logger->error("couldn't load $object_type #$object_id"); + next; + } + } else { + $RT::Logger->error("object type '$object_type' is incorrect"); + push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) ); + next; + } + + my $acls = RT::ACL->new($session{'CurrentUser'}); + $acls->LimitToObject( $obj ); + $acls->LimitToPrincipal( Id => $principal_id ); + + while ( my $ace = $acls->Next ) { + my $right = $ace->RightName; + + # Has right and should have right + next if delete $state{$tuple}->{$right}; + + # Has right and shouldn't have right + my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right ); + push @results, $msg; + } + + # For everything left, they don't have the right but they should + for my $right (keys %{ $state{$tuple} || {} }) { + delete $state{$tuple}->{$right}; + my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right ); + push @results, $msg; + } + + # Check our state for leftovers + if ( keys %{ $state{$tuple} || {} } ) { + my $missed = join '|', %{$state{$tuple} || {}}; + $RT::Logger->warn( + "Uh-oh, it looks like we somehow missed a right in " + ."ProcessACLs. Here's what was leftover: $missed" + ); + } + } + + return (@results); +} + +=head2 _ParseACLNewPrincipal + +Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks +for the presence of rights being added on a principal of the specified type, +and returns undef if no new principal is being granted rights. Otherwise loads +up an L<RT::User> or L<RT::Group> object and returns it. Note that the object +may not be successfully loaded, and you should check C<->id> yourself. + +=cut + +sub _ParseACLNewPrincipal { + my $ARGSref = shift; + my $type = lc shift; + my $key = "AddPrincipalForRights-$type"; + + return unless $ARGSref->{$key}; + + my $principal; + if ( $type eq 'user' ) { + $principal = RT::User->new( $session{'CurrentUser'} ); + $principal->LoadByCol( Name => $ARGSref->{$key} ); + } + elsif ( $type eq 'group' ) { + $principal = RT::Group->new( $session{'CurrentUser'} ); + $principal->LoadUserDefinedGroup( $ARGSref->{$key} ); + } + return $principal; +} + + +=head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs) + +@attribs is a list of ticket fields to check and update if they differ from the B<Object>'s current values. ARGSRef is a ref to HTML::Mason's %ARGS. + +Returns an array of success/failure messages + +=cut + +sub UpdateRecordObject { + my %args = ( + ARGSRef => undef, + AttributesRef => undef, + Object => undef, + AttributePrefix => undef, + @_ + ); + + my $Object = $args{'Object'}; + my @results = $Object->Update( + AttributesRef => $args{'AttributesRef'}, + ARGSRef => $args{'ARGSRef'}, + AttributePrefix => $args{'AttributePrefix'}, + ); + + return (@results); +} + + + +sub ProcessCustomFieldUpdates { + my %args = ( + CustomFieldObj => undef, + ARGSRef => undef, + @_ + ); + + my $Object = $args{'CustomFieldObj'}; + my $ARGSRef = $args{'ARGSRef'}; + + my @attribs = qw(Name Type Description Queue SortOrder); + my @results = UpdateRecordObject( + AttributesRef => \@attribs, + Object => $Object, + ARGSRef => $ARGSRef + ); + + my $prefix = "CustomField-" . $Object->Id; + if ( $ARGSRef->{"$prefix-AddValue-Name"} ) { + my ( $addval, $addmsg ) = $Object->AddValue( + Name => $ARGSRef->{"$prefix-AddValue-Name"}, + Description => $ARGSRef->{"$prefix-AddValue-Description"}, + SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"}, + ); + push( @results, $addmsg ); + } + + my @delete_values + = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' ) + ? @{ $ARGSRef->{"$prefix-DeleteValue"} } + : ( $ARGSRef->{"$prefix-DeleteValue"} ); + + foreach my $id (@delete_values) { + next unless defined $id; + my ( $err, $msg ) = $Object->DeleteValue($id); + push( @results, $msg ); + } + + my $vals = $Object->Values(); + while ( my $cfv = $vals->Next() ) { + if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) { + if ( $cfv->SortOrder != $so ) { + my ( $err, $msg ) = $cfv->SetSortOrder($so); + push( @results, $msg ); + } + } + } + + return (@results); +} + + + +=head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS ); + +Returns an array of results messages. + +=cut + +sub ProcessTicketBasics { + + my %args = ( + TicketObj => undef, + ARGSRef => undef, + @_ + ); + + my $TicketObj = $args{'TicketObj'}; + my $ARGSRef = $args{'ARGSRef'}; + + my $OrigOwner = $TicketObj->Owner; + + # Set basic fields + my @attribs = qw( + Subject + FinalPriority + Priority + TimeEstimated + TimeWorked + TimeLeft + Type + Status + Queue + ); + + # Canonicalize Queue and Owner to their IDs if they aren't numeric + for my $field (qw(Queue Owner)) { + if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) { + my $class = $field eq 'Owner' ? "RT::User" : "RT::$field"; + my $temp = $class->new(RT->SystemUser); + $temp->Load( $ARGSRef->{$field} ); + if ( $temp->id ) { + $ARGSRef->{$field} = $temp->id; + } + } + } + + # Status isn't a field that can be set to a null value. + # RT core complains if you try + delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'}; + + my @results = UpdateRecordObject( + AttributesRef => \@attribs, + Object => $TicketObj, + ARGSRef => $ARGSRef, + ); + + # We special case owner changing, so we can use ForceOwnerChange + if ( $ARGSRef->{'Owner'} + && $ARGSRef->{'Owner'} !~ /\D/ + && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) { + my ($ChownType); + if ( $ARGSRef->{'ForceOwnerChange'} ) { + $ChownType = "Force"; + } + else { + $ChownType = "Set"; + } + + my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType ); + push( @results, $msg ); + } + + # }}} + + return (@results); +} + +sub ProcessTicketReminders { + my %args = ( + TicketObj => undef, + ARGSRef => undef, + @_ + ); + + my $Ticket = $args{'TicketObj'}; + my $args = $args{'ARGSRef'}; + my @results; + + my $reminder_collection = $Ticket->Reminders->Collection; + + if ( $args->{'update-reminders'} ) { + while ( my $reminder = $reminder_collection->Next ) { + my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve; + if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) { + my ($status, $msg) = $Ticket->Reminders->Resolve($reminder); + push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg); + + } + elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) { + my ($status, $msg) = $Ticket->Reminders->Open($reminder); + push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg); + } + + if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) { + my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ; + push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg); + } + + if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) { + my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ; + push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg); + } + + if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) { + my $DateObj = RT::Date->new( $session{'CurrentUser'} ); + $DateObj->Set( + Format => 'unknown', + Value => $args->{ 'Reminder-Due-' . $reminder->id } + ); + if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) { + my ($status, $msg) = $reminder->SetDue( $DateObj->ISO ); + push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg); + } + } + } + } + + if ( $args->{'NewReminder-Subject'} ) { + my $due_obj = RT::Date->new( $session{'CurrentUser'} ); + $due_obj->Set( + Format => 'unknown', + Value => $args->{'NewReminder-Due'} + ); + my ( $add_id, $msg ) = $Ticket->Reminders->Add( + Subject => $args->{'NewReminder-Subject'}, + Owner => $args->{'NewReminder-Owner'}, + Due => $due_obj->ISO + ); + if ( $add_id ) { + push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'}); + } + else { + push @results, $msg; + } + } + return @results; +} + +sub ProcessTicketCustomFieldUpdates { + my %args = @_; + $args{'Object'} = delete $args{'TicketObj'}; + my $ARGSRef = { %{ $args{'ARGSRef'} } }; + + # Build up a list of objects that we want to work with + my %custom_fields_to_mod; + foreach my $arg ( keys %$ARGSRef ) { + if ( $arg =~ /^Ticket-(\d+-.*)/ ) { + $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg}; + } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) { + $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg}; + } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) { + delete $ARGSRef->{$arg}; # don't try to update transaction fields + } + } + + return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef ); +} + +sub ProcessObjectCustomFieldUpdates { + my %args = @_; + my $ARGSRef = $args{'ARGSRef'}; + my @results; + + # Build up a list of objects that we want to work with + my %custom_fields_to_mod; + foreach my $arg ( keys %$ARGSRef ) { + + # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands> + next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/; + + # For each of those objects, find out what custom fields we want to work with. + $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg}; + } + + # For each of those objects + foreach my $class ( keys %custom_fields_to_mod ) { + foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) { + my $Object = $args{'Object'}; + $Object = $class->new( $session{'CurrentUser'} ) + unless $Object && ref $Object eq $class; + + $Object->Load($id) unless ( $Object->id || 0 ) == $id; + unless ( $Object->id ) { + $RT::Logger->warning("Couldn't load object $class #$id"); + next; + } + + foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) { + my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} ); + $CustomFieldObj->SetContextObject($Object); + $CustomFieldObj->LoadById($cf); + unless ( $CustomFieldObj->id ) { + $RT::Logger->warning("Couldn't load custom field #$cf"); + next; + } + push @results, + _ProcessObjectCustomFieldUpdates( + Prefix => "Object-$class-$id-CustomField-$cf-", + Object => $Object, + CustomField => $CustomFieldObj, + ARGS => $custom_fields_to_mod{$class}{$id}{$cf}, + ); + } + } + } + return @results; +} + +sub _ProcessObjectCustomFieldUpdates { + my %args = @_; + my $cf = $args{'CustomField'}; + my $cf_type = $cf->Type || ''; + + # Remove blank Values since the magic field will take care of this. Sometimes + # the browser gives you a blank value which causes CFs to be processed twice + if ( defined $args{'ARGS'}->{'Values'} + && !length $args{'ARGS'}->{'Values'} + && $args{'ARGS'}->{'Values-Magic'} ) + { + delete $args{'ARGS'}->{'Values'}; + } + + my @results; + foreach my $arg ( keys %{ $args{'ARGS'} } ) { + + # skip category argument + next if $arg eq 'Category'; + + # and TimeUnits + next if $arg eq 'Value-TimeUnits'; + + # since http won't pass in a form element with a null value, we need + # to fake it + if ( $arg eq 'Values-Magic' ) { + + # We don't care about the magic, if there's really a values element; + next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'}; + next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'}; + + # "Empty" values does not mean anything for Image and Binary fields + next if $cf_type =~ /^(?:Image|Binary)$/; + + $arg = 'Values'; + $args{'ARGS'}->{'Values'} = undef; + } + + my @values = (); + if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) { + @values = @{ $args{'ARGS'}->{$arg} }; + } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext + @values = ( $args{'ARGS'}->{$arg} ); + } else { + @values = split /\r*\n/, $args{'ARGS'}->{$arg} + if defined $args{'ARGS'}->{$arg}; + } + @values = grep length, map { + s/\r+\n/\n/g; + s/^\s+//; + s/\s+$//; + $_; + } + grep defined, @values; + + if ( $arg eq 'AddValue' || $arg eq 'Value' ) { + foreach my $value (@values) { + my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( + Field => $cf->id, + Value => $value + ); + push( @results, $msg ); + } + } elsif ( $arg eq 'Upload' ) { + my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next; + my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, ); + push( @results, $msg ); + } elsif ( $arg eq 'DeleteValues' ) { + foreach my $value (@values) { + my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue( + Field => $cf, + Value => $value, + ); + push( @results, $msg ); + } + } elsif ( $arg eq 'DeleteValueIds' ) { + foreach my $value (@values) { + my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue( + Field => $cf, + ValueId => $value, + ); + push( @results, $msg ); + } + } elsif ( $arg eq 'Values' && !$cf->Repeated ) { + my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id ); + + my %values_hash; + foreach my $value (@values) { + if ( my $entry = $cf_values->HasEntry($value) ) { + $values_hash{ $entry->id } = 1; + next; + } + + my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( + Field => $cf, + Value => $value + ); + push( @results, $msg ); + $values_hash{$val} = 1 if $val; + } + + # For Date Cfs, @values is empty when there is no changes (no datas in form input) + return @results if ( $cf->Type eq 'Date' && ! @values ); + + # For Date Cfs, @values is empty when there is no changes (no datas in form input) + return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values ); + + $cf_values->RedoSearch; + while ( my $cf_value = $cf_values->Next ) { + next if $values_hash{ $cf_value->id }; + + my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue( + Field => $cf, + ValueId => $cf_value->id + ); + push( @results, $msg ); + } + } elsif ( $arg eq 'Values' ) { + my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id ); + + # keep everything up to the point of difference, delete the rest + my $delete_flag; + foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) { + if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) { + shift @values; + next; + } + + $delete_flag ||= 1; + $old_cf->Delete; + } + + # now add/replace extra things, if any + foreach my $value (@values) { + my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( + Field => $cf, + Value => $value + ); + push( @results, $msg ); + } + } else { + push( + @results, + loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]", + $cf->Name, ref $args{'Object'}, + $args{'Object'}->id + ) + ); + } + } + return @results; +} + + +=head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS ); + +Returns an array of results messages. + +=cut + +sub ProcessTicketWatchers { + my %args = ( + TicketObj => undef, + ARGSRef => undef, + @_ + ); + my (@results); + + my $Ticket = $args{'TicketObj'}; + my $ARGSRef = $args{'ARGSRef'}; + + # Munge watchers + + foreach my $key ( keys %$ARGSRef ) { + + # Delete deletable watchers + if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) { + my ( $code, $msg ) = $Ticket->DeleteWatcher( + PrincipalId => $2, + Type => $1 + ); + push @results, $msg; + } + + # Delete watchers in the simple style demanded by the bulk manipulator + elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) { + my ( $code, $msg ) = $Ticket->DeleteWatcher( + Email => $ARGSRef->{$key}, + Type => $1 + ); + push @results, $msg; + } + + # Add new wathchers by email address + elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/ + and $key =~ /^WatcherTypeEmail(\d*)$/ ) + { + + #They're in this order because otherwise $1 gets clobbered :/ + my ( $code, $msg ) = $Ticket->AddWatcher( + Type => $ARGSRef->{$key}, + Email => $ARGSRef->{ "WatcherAddressEmail" . $1 } + ); + push @results, $msg; + } + + #Add requestors in the simple style demanded by the bulk manipulator + elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) { + my ( $code, $msg ) = $Ticket->AddWatcher( + Type => $1, + Email => $ARGSRef->{$key} + ); + push @results, $msg; + } + + # Add new watchers by owner + elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) { + my $principal_id = $1; + my $form = $ARGSRef->{$key}; + foreach my $value ( ref($form) ? @{$form} : ($form) ) { + next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i; + + my ( $code, $msg ) = $Ticket->AddWatcher( + Type => $value, + PrincipalId => $principal_id + ); + push @results, $msg; + } + } + + } + return (@results); +} + + + +=head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS ); + +Returns an array of results messages. + +=cut + +sub ProcessTicketDates { + my %args = ( + TicketObj => undef, + ARGSRef => undef, + @_ + ); + + my $Ticket = $args{'TicketObj'}; + my $ARGSRef = $args{'ARGSRef'}; + + my (@results); + + # Set date fields + my @date_fields = qw( + Told + Resolved + Starts + Started + Due + WillResolve + ); + + #Run through each field in this list. update the value if apropriate + foreach my $field (@date_fields) { + next unless exists $ARGSRef->{ $field . '_Date' }; + next if $ARGSRef->{ $field . '_Date' } eq ''; + + my ( $code, $msg ); + + my $DateObj = RT::Date->new( $session{'CurrentUser'} ); + $DateObj->Set( + Format => 'unknown', + Value => $ARGSRef->{ $field . '_Date' } + ); + + my $obj = $field . "Obj"; + if ( ( defined $DateObj->Unix ) + and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) ) + { + my $method = "Set$field"; + my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO ); + push @results, "$msg"; + } + } + + # }}} + return (@results); +} + + + +=head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS ); + +Returns an array of results messages. + +=cut + +sub ProcessTicketLinks { + my %args = ( + TicketObj => undef, + ARGSRef => undef, + @_ + ); + + my $Ticket = $args{'TicketObj'}; + my $ARGSRef = $args{'ARGSRef'}; + + my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef ); + + #Merge if we need to + if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) { + $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g; + my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ); + push @results, $msg; + } + + return (@results); +} + + +sub ProcessRecordLinks { + my %args = ( + RecordObj => undef, + ARGSRef => undef, + @_ + ); + + my $Record = $args{'RecordObj'}; + my $ARGSRef = $args{'ARGSRef'}; + + my (@results); + + # Delete links that are gone gone gone. + foreach my $arg ( keys %$ARGSRef ) { + if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) { + my $base = $1; + my $type = $2; + my $target = $3; + + my ( $val, $msg ) = $Record->DeleteLink( + Base => $base, + Type => $type, + Target => $target + ); + + push @results, $msg; + + } + + } + + my @linktypes = qw( DependsOn MemberOf RefersTo ); + + foreach my $linktype (@linktypes) { + if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) { + $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } ) + if ref( $ARGSRef->{ $Record->Id . "-$linktype" } ); + + for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) { + next unless $luri; + $luri =~ s/\s+$//; # Strip trailing whitespace + my ( $val, $msg ) = $Record->AddLink( + Target => $luri, + Type => $linktype + ); + push @results, $msg; + } + } + if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) { + $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } ) + if ref( $ARGSRef->{ "$linktype-" . $Record->Id } ); + + for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) { + next unless $luri; + my ( $val, $msg ) = $Record->AddLink( + Base => $luri, + Type => $linktype + ); + + push @results, $msg; + } + } + } + + return (@results); +} + +=head2 ProcessTransactionSquelching + +Takes a hashref of the submitted form arguments, C<%ARGS>. + +Returns a hash of squelched addresses. + +=cut + +sub ProcessTransactionSquelching { + my $args = shift; + my %checked = map { $_ => 1 } grep { defined } + ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} : + defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) : + () ); + my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||''); + return %squelched; +} + +=head2 _UploadedFile ( $arg ); + +Takes a CGI parameter name; if a file is uploaded under that name, +return a hash reference suitable for AddCustomFieldValue's use: +C<( Value => $filename, LargeContent => $content, ContentType => $type )>. + +Returns C<undef> if no files were uploaded in the C<$arg> field. + +=cut + +sub _UploadedFile { + my $arg = shift; + my $cgi_object = $m->cgi_object; + my $fh = $cgi_object->upload($arg) or return undef; + my $upload_info = $cgi_object->uploadInfo($fh); + + my $filename = "$fh"; + $filename =~ s#^.*[\\/]##; + binmode($fh); + + return { + Value => $filename, + LargeContent => do { local $/; scalar <$fh> }, + ContentType => $upload_info->{'Content-Type'}, + }; +} + +sub GetColumnMapEntry { + my %args = ( Map => {}, Name => '', Attribute => undef, @_ ); + + # deal with the simplest thing first + if ( $args{'Map'}{ $args{'Name'} } ) { + return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} }; + } + + # complex things + elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) { + $subkey =~ s/^\{(.*)\}$/$1/; + return undef unless $args{'Map'}->{$mainkey}; + return $args{'Map'}{$mainkey}{ $args{'Attribute'} } + unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE'; + + return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) }; + } + return undef; +} + +sub ProcessColumnMapValue { + my $value = shift; + my %args = ( Arguments => [], Escape => 1, @_ ); + + if ( ref $value ) { + if ( UNIVERSAL::isa( $value, 'CODE' ) ) { + my @tmp = $value->( @{ $args{'Arguments'} } ); + return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args ); + } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) { + return join '', map ProcessColumnMapValue( $_, %args ), @$value; + } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) { + return $$value; + } + } + + return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'}; + return $value; +} + +=head2 GetPrincipalsMap OBJECT, CATEGORIES + +Returns an array suitable for passing to /Admin/Elements/EditRights with the +principal collections mapped from the categories given. + +=cut + +sub GetPrincipalsMap { + my $object = shift; + my @map; + for (@_) { + if (/System/) { + my $system = RT::Groups->new($session{'CurrentUser'}); + $system->LimitToSystemInternalGroups(); + $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); + push @map, [ + 'System' => $system, # loc_left_pair + 'Type' => 1, + ]; + } + elsif (/Groups/) { + my $groups = RT::Groups->new($session{'CurrentUser'}); + $groups->LimitToUserDefinedGroups(); + $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); + + # Only show groups who have rights granted on this object + $groups->WithGroupRight( + Right => '', + Object => $object, + IncludeSystemRights => 0, + IncludeSubgroupMembers => 0, + ); + + push @map, [ + 'User Groups' => $groups, # loc_left_pair + 'Name' => 0 + ]; + } + elsif (/Roles/) { + my $roles = RT::Groups->new($session{'CurrentUser'}); + + if ($object->isa('RT::System')) { + $roles->LimitToRolesForSystem(); + } + elsif ($object->isa('RT::Queue')) { + $roles->LimitToRolesForQueue($object->Id); + } + else { + $RT::Logger->warn("Skipping unknown object type ($object) for Role principals"); + next; + } + $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); + push @map, [ + 'Roles' => $roles, # loc_left_pair + 'Type' => 1 + ]; + } + elsif (/Users/) { + my $Users = RT->PrivilegedUsers->UserMembersObj(); + $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); + + # Only show users who have rights granted on this object + my $group_members = $Users->WhoHaveGroupRight( + Right => '', + Object => $object, + IncludeSystemRights => 0, + IncludeSubgroupMembers => 0, + ); + + # Limit to UserEquiv groups + my $groups = $Users->NewAlias('Groups'); + $Users->Join( + ALIAS1 => $groups, + FIELD1 => 'id', + ALIAS2 => $group_members, + FIELD2 => 'GroupId' + ); + $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' ); + $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' ); + + + my $display = sub { + $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1) + }; + push @map, [ + 'Users' => $Users, # loc_left_pair + $display => 0 + ]; + } + } + return @map; +} + +=head2 _load_container_object ( $type, $id ); + +Instantiate container object for saving searches. + +=cut + +sub _load_container_object { + my ( $obj_type, $obj_id ) = @_; + return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id ); +} + +=head2 _parse_saved_search ( $arg ); + +Given a serialization string for saved search, and returns the +container object and the search id. + +=cut + +sub _parse_saved_search { + my $spec = shift; + return unless $spec; + if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) { + return; + } + my $obj_type = $1; + my $obj_id = $2; + my $search_id = $3; + + return ( _load_container_object( $obj_type, $obj_id ), $search_id ); +} + +=head2 ScrubHTML content + +Removes unsafe and undesired HTML from the passed content + +=cut + +my $SCRUBBER; +sub ScrubHTML { + my $Content = shift; + $SCRUBBER = _NewScrubber() unless $SCRUBBER; + + $Content = '' if !defined($Content); + return $SCRUBBER->scrub($Content); +} + +=head2 _NewScrubber + +Returns a new L<HTML::Scrubber> object. + +If you need to be more lax about what HTML tags and attributes are allowed, +create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the +following: + + package HTML::Mason::Commands; + # Let tables through + push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH); + 1; + +=cut + +our @SCRUBBER_ALLOWED_TAGS = qw( + A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5 + H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO +); + +our %SCRUBBER_ALLOWED_ATTRIBUTES = ( + # Match http, https, ftp, mailto and relative urls + # XXX: we also scrub format strings with this module then allow simple config options + href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i, + face => 1, + size => 1, + target => 1, + style => qr{ + ^(?:\s* + (?:(?:background-)?color: \s* + (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d) + \#[a-f0-9]{3,6} | # #fff or #ffffff + [\w\-]+ # green, light-blue, etc. + ) | + text-align: \s* \w+ | + font-size: \s* [\w.\-]+ | + font-family: \s* [\w\s"',.\-]+ | + font-weight: \s* [\w\-]+ | + + # MS Office styles, which are probably fine. If we don't, then any + # associated styles in the same attribute get stripped. + mso-[\w\-]+?: \s* [\w\s"',.\-]+ + )\s* ;? \s*) + +$ # one or more of these allowed properties from here 'till sunset + }ix, + dir => qr/^(rtl|ltr)$/i, + lang => qr/^\w+(-\w+)?$/, +); + +our %SCRUBBER_RULES = (); + +sub _NewScrubber { + require HTML::Scrubber; + my $scrubber = HTML::Scrubber->new(); + $scrubber->default( + 0, + { + %SCRUBBER_ALLOWED_ATTRIBUTES, + '*' => 0, # require attributes be explicitly allowed + }, + ); + $scrubber->deny(qw[*]); + $scrubber->allow(@SCRUBBER_ALLOWED_TAGS); + $scrubber->rules(%SCRUBBER_RULES); + + # Scrubbing comments is vital since IE conditional comments can contain + # arbitrary HTML and we'd pass it right on through. + $scrubber->comment(0); + + return $scrubber; +} + +=head2 JSON + +Redispatches to L<RT::Interface::Web/EncodeJSON> + +=cut + +sub JSON { + RT::Interface::Web::EncodeJSON(@_); +} + +package RT::Interface::Web; +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Interface/Web/Handler.pm b/rt/lib/RT/Interface/Web/Handler.pm index 07e770724..7cf18d1ab 100644 --- a/rt/lib/RT/Interface/Web/Handler.pm +++ b/rt/lib/RT/Interface/Web/Handler.pm @@ -251,7 +251,6 @@ use CGI::Emulate::PSGI; use Plack::Request; use Plack::Response; use Plack::Util; -use Encode qw(encode_utf8); sub PSGIApp { my $self = shift; @@ -328,7 +327,10 @@ sub _psgi_response_cb { $cleanup->(); return ''; } - return utf8::is_utf8($_[0]) ? encode_utf8($_[0]) : $_[0]; + # XXX: Ideally, responses should flag if they need + # to be encoded, rather than relying on the UTF-8 + # flag + return Encode::encode("UTF-8",$_[0]) if utf8::is_utf8($_[0]); return $_[0]; }; }); diff --git a/rt/lib/RT/ObjectCustomFieldValue.pm b/rt/lib/RT/ObjectCustomFieldValue.pm index 0e63ced1b..af740e967 100644 --- a/rt/lib/RT/ObjectCustomFieldValue.pm +++ b/rt/lib/RT/ObjectCustomFieldValue.pm @@ -90,7 +90,8 @@ sub Create { my ($val, $msg) = $cf->_CanonicalizeValue(\%args); return ($val, $msg) unless $val; - if ( defined $args{'Content'} && length( Encode::encode_utf8($args{'Content'}) ) > 255 ) { + my $encoded = Encode::encode("UTF-8", $args{'Content'}); + if ( defined $args{'Content'} && length( $encoded ) > 255 ) { if ( defined $args{'LargeContent'} && length $args{'LargeContent'} ) { $RT::Logger->error("Content is longer than 255 bytes and LargeContent specified"); } diff --git a/rt/lib/RT/Record.pm b/rt/lib/RT/Record.pm index 7adfc2678..1cc63ec7f 100755 --- a/rt/lib/RT/Record.pm +++ b/rt/lib/RT/Record.pm @@ -71,7 +71,6 @@ use RT::Date; use RT::I18N; use RT::User; use RT::Attributes; -use Encode qw(); our $_TABLE_ATTR = { }; use base RT->Config->Get('RecordBaseClass'); @@ -646,12 +645,16 @@ sub __Value { return undef if (!defined $value); + # Pg returns character columns as character strings; mysql and + # sqlite return them as bytes. While mysql can be made to return + # characters, using the mysql_enable_utf8 flag, the "Content" column + # is bytes on mysql and characters on Postgres, making true + # consistency impossible. if ( $args{'decode_utf8'} ) { - if ( !utf8::is_utf8($value) ) { + if ( !utf8::is_utf8($value) ) { # mysql/sqlite utf8::decode($value); } - } - else { + } else { if ( utf8::is_utf8($value) ) { utf8::encode($value); } @@ -748,75 +751,72 @@ evaluate and encode it. It will return an octet string. =cut sub _EncodeLOB { - my $self = shift; - my $Body = shift; - my $MIMEType = shift || ''; - my $Filename = shift; - - my $ContentEncoding = 'none'; + my $self = shift; + my $Body = shift; + my $MIMEType = shift || ''; + my $Filename = shift; - #get the max attachment length from RT - my $MaxSize = RT->Config->Get('MaxAttachmentSize'); + my $ContentEncoding = 'none'; - #if the current attachment contains nulls and the - #database doesn't support embedded nulls + RT::Util::assert_bytes( $Body ); - if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) { + #get the max attachment length from RT + my $MaxSize = RT->Config->Get('MaxAttachmentSize'); - # set a flag telling us to mimencode the attachment - $ContentEncoding = 'base64'; + #if the current attachment contains nulls and the + #database doesn't support embedded nulls - #cut the max attchment size by 25% (for mime-encoding overhead. - $RT::Logger->debug("Max size is $MaxSize"); - $MaxSize = $MaxSize * 3 / 4; - # Some databases (postgres) can't handle non-utf8 data - } elsif ( !$RT::Handle->BinarySafeBLOBs - && $Body =~ /\P{ASCII}/ - && !Encode::is_utf8( $Body, 1 ) ) { - $ContentEncoding = 'quoted-printable'; - } + if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) { - #if the attachment is larger than the maximum size - if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) { + # set a flag telling us to mimencode the attachment + $ContentEncoding = 'base64'; - # if we're supposed to truncate large attachments - if (RT->Config->Get('TruncateLongAttachments')) { + #cut the max attchment size by 25% (for mime-encoding overhead. + $RT::Logger->debug("Max size is $MaxSize"); + $MaxSize = $MaxSize * 3 / 4; + # Some databases (postgres) can't handle non-utf8 data + } elsif ( !$RT::Handle->BinarySafeBLOBs + && $Body =~ /\P{ASCII}/ + && !Encode::is_utf8( $Body, 1 ) ) { + $ContentEncoding = 'quoted-printable'; + } - # truncate the attachment to that length. - $Body = substr( $Body, 0, $MaxSize ); + #if the attachment is larger than the maximum size + if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) { - } + # if we're supposed to truncate large attachments + if (RT->Config->Get('TruncateLongAttachments')) { - # elsif we're supposed to drop large attachments on the floor, - elsif (RT->Config->Get('DropLongAttachments')) { + # truncate the attachment to that length. + $Body = substr( $Body, 0, $MaxSize ); - # drop the attachment on the floor - $RT::Logger->info( "$self: Dropped an attachment of size " - . length($Body)); - $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) ); - $Filename .= ".txt" if $Filename; - return ("none", "Large attachment dropped", "text/plain", $Filename ); - } } - # if we need to mimencode the attachment - if ( $ContentEncoding eq 'base64' ) { - - # base64 encode the attachment - Encode::_utf8_off($Body); - $Body = MIME::Base64::encode_base64($Body); + # elsif we're supposed to drop large attachments on the floor, + elsif (RT->Config->Get('DropLongAttachments')) { - } elsif ($ContentEncoding eq 'quoted-printable') { - Encode::_utf8_off($Body); - $Body = MIME::QuotedPrint::encode($Body); + # drop the attachment on the floor + $RT::Logger->info( "$self: Dropped an attachment of size " + . length($Body)); + $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) ); + $Filename .= ".txt" if $Filename; + return ("none", "Large attachment dropped", "text/plain", $Filename ); } + } + # if we need to mimencode the attachment + if ( $ContentEncoding eq 'base64' ) { + # base64 encode the attachment + $Body = MIME::Base64::encode_base64($Body); - return ($ContentEncoding, $Body, $MIMEType, $Filename ); + } elsif ($ContentEncoding eq 'quoted-printable') { + $Body = MIME::QuotedPrint::encode($Body); + } + return ($ContentEncoding, $Body, $MIMEType, $Filename ); } -=head2 _DecodeLOB +=head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content> Unpacks data stored in the database, which may be base64 or QP encoded because of our need to store binary and badly encoded data in columns @@ -832,6 +832,12 @@ This is similar to how we filter all data coming in via the web UI in RT::Interface::Web::DecodeARGS. This filter should only end up being applied to old data from less UTF-8-safe versions of RT. +If the passed C<ContentType> includes a character set, that will be used +to decode textual data; the default character set is UTF-8. This is +necessary because while we attempt to store textual data as UTF-8, the +definition of "textual" has migrated over time, and thus we may now need +to attempt to decode data that was previously not trancoded on insertion. + Important Note - This function expects an octet string and returns a character string for non-binary data. @@ -843,6 +849,8 @@ sub _DecodeLOB { my $ContentEncoding = shift || 'none'; my $Content = shift; + RT::Util::assert_bytes( $Content ); + if ( $ContentEncoding eq 'base64' ) { $Content = MIME::Base64::decode_base64($Content); } @@ -853,9 +861,15 @@ sub _DecodeLOB { return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) ); } if ( RT::I18N::IsTextualContentType($ContentType) ) { - $Content = Encode::decode('UTF-8',$Content,Encode::FB_PERLQQ) unless Encode::is_utf8($Content); + my $entity = MIME::Entity->new(); + $entity->head->add("Content-Type", $ContentType); + $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) ); + my $charset = RT::I18N::_FindOrGuessCharset($entity); + $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset); + + $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ); } - return ($Content); + return ($Content); } # A helper table for links mapping to make it easier diff --git a/rt/lib/RT/Record.pm.orig b/rt/lib/RT/Record.pm.orig new file mode 100755 index 000000000..7adfc2678 --- /dev/null +++ b/rt/lib/RT/Record.pm.orig @@ -0,0 +1,2102 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +=head1 NAME + + RT::Record - Base class for RT record objects + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + + +=head1 METHODS + +=cut + +package RT::Record; + +use strict; +use warnings; + + +use RT::Date; +use RT::I18N; +use RT::User; +use RT::Attributes; +use Encode qw(); + +our $_TABLE_ATTR = { }; +use base RT->Config->Get('RecordBaseClass'); +use base 'RT::Base'; + + +sub _Init { + my $self = shift; + $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)}); + $self->CurrentUser(@_); +} + + + +=head2 _PrimaryKeys + +The primary keys for RT classes is 'id' + +=cut + +sub _PrimaryKeys { return ['id'] } +# short circuit many, many thousands of calls from searchbuilder +sub _PrimaryKey { 'id' } + +=head2 Id + +Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do +on a very common codepath + +C<id> is an alias to C<Id> and is the preferred way to call this method. + +=cut + +sub Id { + return shift->{'values'}->{id}; +} + +*id = \&Id; + +=head2 Delete + +Delete this record object from the database. + +=cut + +sub Delete { + my $self = shift; + my ($rv) = $self->SUPER::Delete; + if ($rv) { + return ($rv, $self->loc("Object deleted")); + } else { + + return(0, $self->loc("Object could not be deleted")) + } +} + +=head2 ObjectTypeStr + +Returns a string which is this object's type. The type is the class, +without the "RT::" prefix. + + +=cut + +sub ObjectTypeStr { + my $self = shift; + if (ref($self) =~ /^.*::(\w+)$/) { + return $self->loc($1); + } else { + return $self->loc(ref($self)); + } +} + +=head2 Attributes + +Return this object's attributes as an RT::Attributes object + +=cut + +sub Attributes { + my $self = shift; + unless ($self->{'attributes'}) { + $self->{'attributes'} = RT::Attributes->new($self->CurrentUser); + $self->{'attributes'}->LimitToObject($self); + $self->{'attributes'}->OrderByCols({FIELD => 'id'}); + } + return ($self->{'attributes'}); +} + + +=head2 AddAttribute { Name, Description, Content } + +Adds a new attribute for this object. + +=cut + +sub AddAttribute { + my $self = shift; + my %args = ( Name => undef, + Description => undef, + Content => undef, + @_ ); + + my $attr = RT::Attribute->new( $self->CurrentUser ); + my ( $id, $msg ) = $attr->Create( + Object => $self, + Name => $args{'Name'}, + Description => $args{'Description'}, + Content => $args{'Content'} ); + + + # XXX TODO: Why won't RedoSearch work here? + $self->Attributes->_DoSearch; + + return ($id, $msg); +} + + +=head2 SetAttribute { Name, Description, Content } + +Like AddAttribute, but replaces all existing attributes with the same Name. + +=cut + +sub SetAttribute { + my $self = shift; + my %args = ( Name => undef, + Description => undef, + Content => undef, + @_ ); + + my @AttributeObjs = $self->Attributes->Named( $args{'Name'} ) + or return $self->AddAttribute( %args ); + + my $AttributeObj = pop( @AttributeObjs ); + $_->Delete foreach @AttributeObjs; + + $AttributeObj->SetDescription( $args{'Description'} ); + $AttributeObj->SetContent( $args{'Content'} ); + + $self->Attributes->RedoSearch; + return 1; +} + +=head2 DeleteAttribute NAME + +Deletes all attributes with the matching name for this object. + +=cut + +sub DeleteAttribute { + my $self = shift; + my $name = shift; + my ($val,$msg) = $self->Attributes->DeleteEntry( Name => $name ); + $self->ClearAttributes; + return ($val,$msg); +} + +=head2 FirstAttribute NAME + +Returns the first attribute with the matching name for this object (as an +L<RT::Attribute> object), or C<undef> if no such attributes exist. +If there is more than one attribute with the matching name on the +object, the first value that was set is returned. + +=cut + +sub FirstAttribute { + my $self = shift; + my $name = shift; + return ($self->Attributes->Named( $name ))[0]; +} + + +sub ClearAttributes { + my $self = shift; + delete $self->{'attributes'}; + +} + +sub _Handle { return $RT::Handle } + + + +=head2 Create PARAMHASH + +Takes a PARAMHASH of Column -> Value pairs. +If any Column has a Validate$PARAMNAME subroutine defined and the +value provided doesn't pass validation, this routine returns +an error. + +If this object's table has any of the following atetributes defined as +'Auto', this routine will automatically fill in their values. + +=over + +=item Created + +=item Creator + +=item LastUpdated + +=item LastUpdatedBy + +=back + +=cut + +sub Create { + my $self = shift; + my %attribs = (@_); + foreach my $key ( keys %attribs ) { + if (my $method = $self->can("Validate$key")) { + if (! $method->( $self, $attribs{$key} ) ) { + if (wantarray) { + return ( 0, $self->loc('Invalid value for [_1]', $key) ); + } + else { + return (0); + } + } + } + } + + + + my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime(); + + my $now_iso = + sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec); + + $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'}); + + if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) { + $attribs{'Creator'} = $self->CurrentUser->id || '0'; + } + $attribs{'LastUpdated'} = $now_iso + if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'}); + + $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0' + if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'}); + + my $id = $self->SUPER::Create(%attribs); + if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) { + if ( $id->errno ) { + if (wantarray) { + return ( 0, + $self->loc( "Internal Error: [_1]", $id->{error_message} ) ); + } + else { + return (0); + } + } + } + # If the object was created in the database, + # load it up now, so we're sure we get what the database + # has. Arguably, this should not be necessary, but there + # isn't much we can do about it. + + unless ($id) { + if (wantarray) { + return ( $id, $self->loc('Object could not be created') ); + } + else { + return ($id); + } + + } + + if (UNIVERSAL::isa('errno',$id)) { + return(undef); + } + + $self->Load($id) if ($id); + + + + if (wantarray) { + return ( $id, $self->loc('Object created') ); + } + else { + return ($id); + } + +} + + + +=head2 LoadByCols + +Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the +DB is case sensitive + +=cut + +sub LoadByCols { + my $self = shift; + + # We don't want to hang onto this + $self->ClearAttributes; + + return $self->SUPER::LoadByCols( @_ ) unless $self->_Handle->CaseSensitive; + + # If this database is case sensitive we need to uncase objects for + # explicit loading + my %hash = (@_); + foreach my $key ( keys %hash ) { + + # If we've been passed an empty value, we can't do the lookup. + # We don't need to explicitly downcase integers or an id. + if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) { + my ($op, $val, $func); + ($key, $op, $val, $func) = + $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } ); + $hash{$key}->{operator} = $op; + $hash{$key}->{value} = $val; + $hash{$key}->{function} = $func; + } + } + return $self->SUPER::LoadByCols( %hash ); +} + + + +# There is room for optimizations in most of those subs: + + +sub LastUpdatedObj { + my $self = shift; + my $obj = RT::Date->new( $self->CurrentUser ); + + $obj->Set( Format => 'sql', Value => $self->LastUpdated ); + return $obj; +} + + + +sub CreatedObj { + my $self = shift; + my $obj = RT::Date->new( $self->CurrentUser ); + + $obj->Set( Format => 'sql', Value => $self->Created ); + + return $obj; +} + + +# +# TODO: This should be deprecated +# +sub AgeAsString { + my $self = shift; + return ( $self->CreatedObj->AgeAsString() ); +} + + + +# TODO this should be deprecated + +sub LastUpdatedAsString { + my $self = shift; + if ( $self->LastUpdated ) { + return ( $self->LastUpdatedObj->AsString() ); + + } + else { + return "never"; + } +} + + +# +# TODO This should be deprecated +# +sub CreatedAsString { + my $self = shift; + return ( $self->CreatedObj->AsString() ); +} + + +# +# TODO This should be deprecated +# +sub LongSinceUpdateAsString { + my $self = shift; + if ( $self->LastUpdated ) { + + return ( $self->LastUpdatedObj->AgeAsString() ); + + } + else { + return "never"; + } +} + + + +# +sub _Set { + my $self = shift; + + my %args = ( + Field => undef, + Value => undef, + IsSQL => undef, + @_ + ); + + #if the user is trying to modify the record + # TODO: document _why_ this code is here + + if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) { + $args{'Value'} = 0; + } + + my $old_val = $self->__Value($args{'Field'}); + $self->_SetLastUpdated(); + my $ret = $self->SUPER::_Set( + Field => $args{'Field'}, + Value => $args{'Value'}, + IsSQL => $args{'IsSQL'} + ); + my ($status, $msg) = $ret->as_array(); + + # @values has two values, a status code and a message. + + # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool + # we want to change the standard "success" message + if ($status) { + if ($self->SQLType( $args{'Field'}) =~ /text/) { + $msg = $self->loc( + "[_1] updated", + $self->loc( $args{'Field'} ), + ); + } else { + $msg = $self->loc( + "[_1] changed from [_2] to [_3]", + $self->loc( $args{'Field'} ), + ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ), + '"' . $self->__Value( $args{'Field'}) . '"', + ); + } + } else { + $msg = $self->CurrentUser->loc_fuzzy($msg); + } + + return wantarray ? ($status, $msg) : $ret; +} + + + +=head2 _SetLastUpdated + +This routine updates the LastUpdated and LastUpdatedBy columns of the row in question +It takes no options. Arguably, this is a bug + +=cut + +sub _SetLastUpdated { + my $self = shift; + use RT::Date; + my $now = RT::Date->new( $self->CurrentUser ); + $now->SetToNow(); + + if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) { + my ( $msg, $val ) = $self->__Set( + Field => 'LastUpdated', + Value => $now->ISO + ); + } + if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) { + my ( $msg, $val ) = $self->__Set( + Field => 'LastUpdatedBy', + Value => $self->CurrentUser->id + ); + } +} + + + +=head2 CreatorObj + +Returns an RT::User object with the RT account of the creator of this row + +=cut + +sub CreatorObj { + my $self = shift; + unless ( exists $self->{'CreatorObj'} ) { + + $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser ); + $self->{'CreatorObj'}->Load( $self->Creator ); + } + return ( $self->{'CreatorObj'} ); +} + + + +=head2 LastUpdatedByObj + + Returns an RT::User object of the last user to touch this object + +=cut + +sub LastUpdatedByObj { + my $self = shift; + unless ( exists $self->{LastUpdatedByObj} ) { + $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser ); + $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy ); + } + return $self->{'LastUpdatedByObj'}; +} + + + +=head2 URI + +Returns this record's URI + +=cut + +sub URI { + my $self = shift; + my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser); + return($uri->URIForObject($self)); +} + + +=head2 ValidateName NAME + +Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name + +=cut + +sub ValidateName { + my $self = shift; + my $value = shift; + if (defined $value && $value=~ /^\d+$/) { + return(0); + } else { + return(1); + } +} + + + +=head2 SQLType attribute + +return the SQL type for the attribute 'attribute' as stored in _ClassAccessible + +=cut + +sub SQLType { + my $self = shift; + my $field = shift; + + return ($self->_Accessible($field, 'type')); + + +} + +sub __Value { + my $self = shift; + my $field = shift; + my %args = ( decode_utf8 => 1, @_ ); + + unless ($field) { + $RT::Logger->error("__Value called with undef field"); + } + + my $value = $self->SUPER::__Value($field); + + return undef if (!defined $value); + + if ( $args{'decode_utf8'} ) { + if ( !utf8::is_utf8($value) ) { + utf8::decode($value); + } + } + else { + if ( utf8::is_utf8($value) ) { + utf8::encode($value); + } + } + + return $value; + +} + +# Set up defaults for DBIx::SearchBuilder::Record::Cachable + +sub _CacheConfig { + { + 'cache_p' => 1, + 'cache_for_sec' => 30, + } +} + + + +sub _BuildTableAttributes { + my $self = shift; + my $class = ref($self) || $self; + + my $attributes; + if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) { + $attributes = $self->_CoreAccessible(); + } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) { + $attributes = $self->_ClassAccessible(); + + } + + foreach my $column (keys %$attributes) { + foreach my $attr ( keys %{ $attributes->{$column} } ) { + $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr}; + } + } + foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) { + next unless UNIVERSAL::can( $self, $method ); + $attributes = $self->$method(); + + foreach my $column ( keys %$attributes ) { + foreach my $attr ( keys %{ $attributes->{$column} } ) { + $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr}; + } + } + } +} + + +=head2 _ClassAccessible + +Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in +DBIx::SearchBuilder::Record + +=cut + +sub _ClassAccessible { + my $self = shift; + return $_TABLE_ATTR->{ref($self) || $self}; +} + +=head2 _Accessible COLUMN ATTRIBUTE + +returns the value of ATTRIBUTE for COLUMN + + +=cut + +sub _Accessible { + my $self = shift; + my $column = shift; + my $attribute = lc(shift); + return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column}); + return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0; + +} + +=head2 _EncodeLOB BODY MIME_TYPE FILENAME + +Takes a potentially large attachment. Returns (ContentEncoding, +EncodedBody, MimeType, Filename) based on system configuration and +selected database. Returns a custom (short) text/plain message if +DropLongAttachments causes an attachment to not be stored. + +Encodes your data as base64 or Quoted-Printable as needed based on your +Databases's restrictions and the UTF-8ness of the data being passed in. Since +we are storing in columns marked UTF8, we must ensure that binary data is +encoded on databases which are strict. + +This function expects to receive an octet string in order to properly +evaluate and encode it. It will return an octet string. + +=cut + +sub _EncodeLOB { + my $self = shift; + my $Body = shift; + my $MIMEType = shift || ''; + my $Filename = shift; + + my $ContentEncoding = 'none'; + + #get the max attachment length from RT + my $MaxSize = RT->Config->Get('MaxAttachmentSize'); + + #if the current attachment contains nulls and the + #database doesn't support embedded nulls + + if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) { + + # set a flag telling us to mimencode the attachment + $ContentEncoding = 'base64'; + + #cut the max attchment size by 25% (for mime-encoding overhead. + $RT::Logger->debug("Max size is $MaxSize"); + $MaxSize = $MaxSize * 3 / 4; + # Some databases (postgres) can't handle non-utf8 data + } elsif ( !$RT::Handle->BinarySafeBLOBs + && $Body =~ /\P{ASCII}/ + && !Encode::is_utf8( $Body, 1 ) ) { + $ContentEncoding = 'quoted-printable'; + } + + #if the attachment is larger than the maximum size + if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) { + + # if we're supposed to truncate large attachments + if (RT->Config->Get('TruncateLongAttachments')) { + + # truncate the attachment to that length. + $Body = substr( $Body, 0, $MaxSize ); + + } + + # elsif we're supposed to drop large attachments on the floor, + elsif (RT->Config->Get('DropLongAttachments')) { + + # drop the attachment on the floor + $RT::Logger->info( "$self: Dropped an attachment of size " + . length($Body)); + $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) ); + $Filename .= ".txt" if $Filename; + return ("none", "Large attachment dropped", "text/plain", $Filename ); + } + } + + # if we need to mimencode the attachment + if ( $ContentEncoding eq 'base64' ) { + + # base64 encode the attachment + Encode::_utf8_off($Body); + $Body = MIME::Base64::encode_base64($Body); + + } elsif ($ContentEncoding eq 'quoted-printable') { + Encode::_utf8_off($Body); + $Body = MIME::QuotedPrint::encode($Body); + } + + + return ($ContentEncoding, $Body, $MIMEType, $Filename ); + +} + +=head2 _DecodeLOB + +Unpacks data stored in the database, which may be base64 or QP encoded +because of our need to store binary and badly encoded data in columns +marked as UTF-8. Databases such as PostgreSQL and Oracle care that you +are feeding them invalid UTF-8 and will refuse the content. This +function handles unpacking the encoded data. + +It returns textual data as a UTF-8 string which has been processed by Encode's +PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see +the invalid byte but won't run into problems treating the data as UTF-8 later. + +This is similar to how we filter all data coming in via the web UI in +RT::Interface::Web::DecodeARGS. This filter should only end up being +applied to old data from less UTF-8-safe versions of RT. + +Important Note - This function expects an octet string and returns a +character string for non-binary data. + +=cut + +sub _DecodeLOB { + my $self = shift; + my $ContentType = shift || ''; + my $ContentEncoding = shift || 'none'; + my $Content = shift; + + if ( $ContentEncoding eq 'base64' ) { + $Content = MIME::Base64::decode_base64($Content); + } + elsif ( $ContentEncoding eq 'quoted-printable' ) { + $Content = MIME::QuotedPrint::decode($Content); + } + elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) { + return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) ); + } + if ( RT::I18N::IsTextualContentType($ContentType) ) { + $Content = Encode::decode('UTF-8',$Content,Encode::FB_PERLQQ) unless Encode::is_utf8($Content); + } + return ($Content); +} + +# A helper table for links mapping to make it easier +# to build and parse links between tickets + +use vars '%LINKDIRMAP'; + +%LINKDIRMAP = ( + MemberOf => { Base => 'MemberOf', + Target => 'HasMember', }, + RefersTo => { Base => 'RefersTo', + Target => 'ReferredToBy', }, + DependsOn => { Base => 'DependsOn', + Target => 'DependedOnBy', }, + MergedInto => { Base => 'MergedInto', + Target => 'MergedInto', }, + +); + +=head2 Update ARGSHASH + +Updates fields on an object for you using the proper Set methods, +skipping unchanged values. + + ARGSRef => a hashref of attributes => value for the update + AttributesRef => an arrayref of keys in ARGSRef that should be updated + AttributePrefix => a prefix that should be added to the attributes in AttributesRef + when looking up values in ARGSRef + Bare attributes are tried before prefixed attributes + +Returns a list of localized results of the update + +=cut + +sub Update { + my $self = shift; + + my %args = ( + ARGSRef => undef, + AttributesRef => undef, + AttributePrefix => undef, + @_ + ); + + my $attributes = $args{'AttributesRef'}; + my $ARGSRef = $args{'ARGSRef'}; + my %new_values; + + # gather all new values + 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; + + my $truncated_value = $self->TruncateValue($attribute, $value); + + # If Queue is 'General', we want to resolve the queue name for + # the object. + + # This is in an eval block because $object might not exist. + # and might not have a Name method. But "can" won't find autoloaded + # items. If it fails, we don't care + do { + no warnings "uninitialized"; + local $@; + eval { + my $object = $attribute . "Obj"; + my $name = $self->$object->Name; + next if $name eq $value || $name eq ($value || 0); + }; + + my $current = $self->$attribute(); + # RT::Queue->Lifecycle returns a Lifecycle object instead of name + $current = eval { $current->Name } if ref $current; + next if $truncated_value eq $current; + next if ( $truncated_value || 0 ) eq $current; + }; + + $new_values{$attribute} = $value; + } + + return $self->_UpdateAttributes( + Attributes => $attributes, + NewValues => \%new_values, + ); +} + +sub _UpdateAttributes { + my $self = shift; + my %args = ( + Attributes => [], + NewValues => {}, + @_, + ); + + my @results; + + foreach my $attribute (@{ $args{Attributes} }) { + next if !exists($args{NewValues}{$attribute}); + + my $value = $args{NewValues}{$attribute}; + my $method = "Set$attribute"; + my ( $code, $msg ) = $self->$method($value); + my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/; + + # Default to $id, but use name if we can get it. + my $label = $self->id; + $label = $self->Name if (UNIVERSAL::can($self,'Name')); + # this requires model names to be loc'ed. + +=for loc + + "Ticket" # loc + "User" # loc + "Group" # loc + "Queue" # loc + +=cut + + push @results, $self->loc( $prefix ) . " $label: ". $msg; + +=for loc + + "[_1] could not be set to [_2].", # loc + "That is already the current value", # loc + "No value sent to _Set!", # 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; +} + + + + +=head2 Members + + This returns an RT::Links object which references all the tickets +which are 'MembersOf' this ticket + +=cut + +sub Members { + my $self = shift; + return ( $self->_Links( 'Target', 'MemberOf' ) ); +} + + + +=head2 MemberOf + + This returns an RT::Links object which references all the tickets that this +ticket is a 'MemberOf' + +=cut + +sub MemberOf { + my $self = shift; + return ( $self->_Links( 'Base', 'MemberOf' ) ); +} + + + +=head2 RefersTo + + This returns an RT::Links object which shows all references for which this ticket is a base + +=cut + +sub RefersTo { + my $self = shift; + return ( $self->_Links( 'Base', 'RefersTo' ) ); +} + + + +=head2 ReferredToBy + +This returns an L<RT::Links> object which shows all references for which this ticket is a target + +=cut + +sub ReferredToBy { + my $self = shift; + return ( $self->_Links( 'Target', 'RefersTo' ) ); +} + + + +=head2 DependedOnBy + + This returns an RT::Links object which references all the tickets that depend on this one + +=cut + +sub DependedOnBy { + my $self = shift; + return ( $self->_Links( 'Target', 'DependsOn' ) ); +} + + + + +=head2 HasUnresolvedDependencies + +Takes a paramhash of Type (default to '__any'). Returns the number of +unresolved dependencies, if $self->UnresolvedDependencies returns an +object with one or more members of that type. Returns false +otherwise. + +=cut + +sub HasUnresolvedDependencies { + my $self = shift; + my %args = ( + Type => undef, + @_ + ); + + my $deps = $self->UnresolvedDependencies; + + if ($args{Type}) { + $deps->Limit( FIELD => 'Type', + OPERATOR => '=', + VALUE => $args{Type}); + } + else { + $deps->IgnoreType; + } + + if ($deps->Count > 0) { + return $deps->Count; + } + else { + return (undef); + } +} + + + +=head2 UnresolvedDependencies + +Returns an RT::Tickets object of tickets which this ticket depends on +and which have a status of new, open or stalled. (That list comes from +RT::Queue->ActiveStatusArray + +=cut + + +sub UnresolvedDependencies { + my $self = shift; + my $deps = RT::Tickets->new($self->CurrentUser); + + my @live_statuses = RT::Queue->ActiveStatusArray(); + foreach my $status (@live_statuses) { + $deps->LimitStatus(VALUE => $status); + } + $deps->LimitDependedOnBy($self->Id); + + return($deps); + +} + + + +=head2 AllDependedOnBy + +Returns an array of RT::Ticket objects which (directly or indirectly) +depends on this ticket; takes an optional 'Type' argument in the param +hash, which will limit returned tickets to that type, as well as cause +tickets with that type to serve as 'leaf' nodes that stops the recursive +dependency search. + +=cut + +sub AllDependedOnBy { + my $self = shift; + return $self->_AllLinkedTickets( LinkType => 'DependsOn', + Direction => 'Target', @_ ); +} + +=head2 AllDependsOn + +Returns an array of RT::Ticket objects which this ticket (directly or +indirectly) depends on; takes an optional 'Type' argument in the param +hash, which will limit returned tickets to that type, as well as cause +tickets with that type to serve as 'leaf' nodes that stops the +recursive dependency search. + +=cut + +sub AllDependsOn { + my $self = shift; + return $self->_AllLinkedTickets( LinkType => 'DependsOn', + Direction => 'Base', @_ ); +} + +sub _AllLinkedTickets { + my $self = shift; + + my %args = ( + LinkType => undef, + Direction => undef, + Type => undef, + _found => {}, + _top => 1, + @_ + ); + + my $dep = $self->_Links( $args{Direction}, $args{LinkType}); + while (my $link = $dep->Next()) { + my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI; + next unless ($uri->IsLocal()); + my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj; + next if $args{_found}{$obj->Id}; + + if (!$args{Type}) { + $args{_found}{$obj->Id} = $obj; + $obj->_AllLinkedTickets( %args, _top => 0 ); + } + elsif ($obj->Type and $obj->Type eq $args{Type}) { + $args{_found}{$obj->Id} = $obj; + } + else { + $obj->_AllLinkedTickets( %args, _top => 0 ); + } + } + + if ($args{_top}) { + return map { $args{_found}{$_} } sort keys %{$args{_found}}; + } + else { + return 1; + } +} + + + +=head2 DependsOn + + This returns an RT::Links object which references all the tickets that this ticket depends on + +=cut + +sub DependsOn { + my $self = shift; + return ( $self->_Links( 'Base', 'DependsOn' ) ); +} + +# }}} + +# {{{ Customers + +=head2 Customers + + This returns an RT::Links object which references all the customers that + this object is a member of. This includes both explicitly linked customers + and links implied by services. + +=cut + +sub Customers { + my( $self, %opt ) = @_; + my $Debug = $opt{'Debug'}; + + unless ( $self->{'Customers'} ) { + + $self->{'Customers'} = $self->MemberOf->Clone; + + for my $fstable (qw(cust_main cust_svc)) { + + $self->{'Customers'}->Limit( + FIELD => 'Target', + OPERATOR => 'STARTSWITH', + VALUE => "freeside://freeside/$fstable", + ENTRYAGGREGATOR => 'OR', + SUBCLAUSE => 'customers', + ); + } + } + + warn "->Customers method called on $self; returning ". + ref($self->{'Customers'}). ' object' + if $Debug; + + return $self->{'Customers'}; +} + +# }}} + +# {{{ Services + +=head2 Services + + This returns an RT::Links object which references all the services this + object is a member of. + +=cut + +sub Services { + my( $self, %opt ) = @_; + + unless ( $self->{'Services'} ) { + + $self->{'Services'} = $self->MemberOf->Clone; + + $self->{'Services'}->Limit( + FIELD => 'Target', + OPERATOR => 'STARTSWITH', + VALUE => "freeside://freeside/cust_svc", + ); + } + + return $self->{'Services'}; +} + + + + + + +=head2 Links DIRECTION [TYPE] + +Return links (L<RT::Links>) to/from this object. + +DIRECTION is either 'Base' or 'Target'. + +TYPE is a type of links to return, it can be omitted to get +links of any type. + +=cut + +sub Links { shift->_Links(@_) } + +sub _Links { + my $self = shift; + + #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic --- + #tobias meant by $f + my $field = shift; + my $type = shift || ""; + + unless ( $self->{"$field$type"} ) { + $self->{"$field$type"} = RT::Links->new( $self->CurrentUser ); + # at least to myself + $self->{"$field$type"}->Limit( FIELD => $field, + VALUE => $self->URI, + ENTRYAGGREGATOR => 'OR' ); + $self->{"$field$type"}->Limit( FIELD => 'Type', + VALUE => $type ) + if ($type); + } + return ( $self->{"$field$type"} ); +} + + + + +=head2 FormatType + +Takes a Type and returns a string that is more human readable. + +=cut + +sub FormatType{ + my $self = shift; + my %args = ( Type => '', + @_ + ); + $args{Type} =~ s/([A-Z])/" " . lc $1/ge; + $args{Type} =~ s/^\s+//; + return $args{Type}; +} + + + + +=head2 FormatLink + +Takes either a Target or a Base and returns a string of human friendly text. + +=cut + +sub FormatLink { + my $self = shift; + my %args = ( Object => undef, + FallBack => '', + @_ + ); + my $text = "URI " . $args{FallBack}; + if ($args{Object} && $args{Object}->isa("RT::Ticket")) { + $text = "Ticket " . $args{Object}->id; + } + return $text; +} + + + +=head2 _AddLink + +Takes a paramhash of Type and one of Base or Target. Adds that link to this object. + +Returns C<link id>, C<message> and C<exist> flag. + + +=cut + +sub _AddLink { + my $self = shift; + my %args = ( Target => '', + Base => '', + Type => '', + Silent => undef, + @_ ); + + + # Remote_link is the URI of the object that is not this ticket + my $remote_link; + my $direction; + + if ( $args{'Base'} and $args{'Target'} ) { + $RT::Logger->debug( "$self tried to create a link. both base and target were specified" ); + return ( 0, $self->loc("Can't specify both base and target") ); + } + elsif ( $args{'Base'} ) { + $args{'Target'} = $self->URI(); + $remote_link = $args{'Base'}; + $direction = 'Target'; + } + elsif ( $args{'Target'} ) { + $args{'Base'} = $self->URI(); + $remote_link = $args{'Target'}; + $direction = 'Base'; + } + else { + return ( 0, $self->loc('Either base or target must be specified') ); + } + + # Check if the link already exists - we don't want duplicates + use RT::Link; + my $old_link = RT::Link->new( $self->CurrentUser ); + $old_link->LoadByParams( Base => $args{'Base'}, + Type => $args{'Type'}, + Target => $args{'Target'} ); + if ( $old_link->Id ) { + $RT::Logger->debug("$self Somebody tried to duplicate a link"); + return ( $old_link->id, $self->loc("Link already exists"), 1 ); + } + + # }}} + + + # Storing the link in the DB. + my $link = RT::Link->new( $self->CurrentUser ); + my ($linkid, $linkmsg) = $link->Create( Target => $args{Target}, + Base => $args{Base}, + Type => $args{Type} ); + + unless ($linkid) { + $RT::Logger->error("Link could not be created: ".$linkmsg); + return ( 0, $self->loc("Link could not be created") ); + } + + my $basetext = $self->FormatLink(Object => $link->BaseObj, + FallBack => $args{Base}); + my $targettext = $self->FormatLink(Object => $link->TargetObj, + FallBack => $args{Target}); + my $typetext = $self->FormatType(Type => $args{Type}); + my $TransString = + "$basetext $typetext $targettext."; + return ( $linkid, $TransString ) ; +} + + + +=head2 _DeleteLink + +Delete a link. takes a paramhash of Base, Target and Type. +Either Base or Target must be null. The null value will +be replaced with this ticket's id + +=cut + +sub _DeleteLink { + my $self = shift; + my %args = ( + Base => undef, + Target => undef, + Type => undef, + @_ + ); + + #we want one of base and target. we don't care which + #but we only want _one_ + + my $direction; + my $remote_link; + + if ( $args{'Base'} and $args{'Target'} ) { + $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target"); + return ( 0, $self->loc("Can't specify both base and target") ); + } + elsif ( $args{'Base'} ) { + $args{'Target'} = $self->URI(); + $remote_link = $args{'Base'}; + $direction = 'Target'; + } + elsif ( $args{'Target'} ) { + $args{'Base'} = $self->URI(); + $remote_link = $args{'Target'}; + $direction='Base'; + } + else { + $RT::Logger->error("Base or Target must be specified"); + return ( 0, $self->loc('Either base or target must be specified') ); + } + + my $link = RT::Link->new( $self->CurrentUser ); + $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} ); + + + $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=> $args{'Target'} ); + #it's a real link. + + if ( $link->id ) { + my $basetext = $self->FormatLink(Object => $link->BaseObj, + FallBack => $args{Base}); + my $targettext = $self->FormatLink(Object => $link->TargetObj, + FallBack => $args{Target}); + my $typetext = $self->FormatType(Type => $args{Type}); + my $linkid = $link->id; + $link->Delete(); + my $TransString = "$basetext no longer $typetext $targettext."; + return ( 1, $TransString); + } + + #if it's not a link we can find + else { + $RT::Logger->debug("Couldn't find that link"); + return ( 0, $self->loc("Link not found") ); + } +} + + +=head1 LockForUpdate + +In a database transaction, gains an exclusive lock on the row, to +prevent race conditions. On SQLite, this is a "RESERVED" lock on the +entire database. + +=cut + +sub LockForUpdate { + my $self = shift; + + my $pk = $self->_PrimaryKey; + my $id = @_ ? $_[0] : $self->$pk; + $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable"); + if (RT->Config->Get('DatabaseType') eq "SQLite") { + # SQLite does DB-level locking, upgrading the transaction to + # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op + # UPDATE to force the upgade. + return RT->DatabaseHandle->dbh->do( + "UPDATE " .$self->Table. + " SET $pk = $pk WHERE 1 = 0"); + } else { + return $self->_LoadFromSQL( + "SELECT * FROM ".$self->Table + ." WHERE $pk = ? FOR UPDATE", + $id, + ); + } +} + +=head2 _NewTransaction PARAMHASH + +Private function to create a new RT::Transaction object for this ticket update + +=cut + +sub _NewTransaction { + my $self = shift; + my %args = ( + TimeTaken => undef, + Type => undef, + OldValue => undef, + NewValue => undef, + OldReference => undef, + NewReference => undef, + ReferenceType => undef, + Data => undef, + Field => undef, + MIMEObj => undef, + ActivateScrips => 1, + CommitScrips => 1, + SquelchMailTo => undef, + CustomFields => {}, + @_ + ); + + my $in_txn = RT->DatabaseHandle->TransactionDepth; + RT->DatabaseHandle->BeginTransaction unless $in_txn; + + $self->LockForUpdate; + + my $old_ref = $args{'OldReference'}; + my $new_ref = $args{'NewReference'}; + my $ref_type = $args{'ReferenceType'}; + if ($old_ref or $new_ref) { + $ref_type ||= ref($old_ref) || ref($new_ref); + if (!$ref_type) { + $RT::Logger->error("Reference type not specified for transaction"); + return; + } + $old_ref = $old_ref->Id if ref($old_ref); + $new_ref = $new_ref->Id if ref($new_ref); + } + + require RT::Transaction; + my $trans = RT::Transaction->new( $self->CurrentUser ); + my ( $transaction, $msg ) = $trans->Create( + ObjectId => $self->Id, + ObjectType => ref($self), + TimeTaken => $args{'TimeTaken'}, + Type => $args{'Type'}, + Data => $args{'Data'}, + Field => $args{'Field'}, + NewValue => $args{'NewValue'}, + OldValue => $args{'OldValue'}, + NewReference => $new_ref, + OldReference => $old_ref, + ReferenceType => $ref_type, + MIMEObj => $args{'MIMEObj'}, + ActivateScrips => $args{'ActivateScrips'}, + CommitScrips => $args{'CommitScrips'}, + SquelchMailTo => $args{'SquelchMailTo'}, + CustomFields => $args{'CustomFields'}, + ); + + # Rationalize the object since we may have done things to it during the caching. + $self->Load($self->Id); + + $RT::Logger->warning($msg) unless $transaction; + + $self->_SetLastUpdated; + + if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) { + $self->_UpdateTimeTaken( $args{'TimeTaken'} ); + } + if ( RT->Config->Get('UseTransactionBatch') and $transaction ) { + push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'}; + } + + RT->DatabaseHandle->Commit unless $in_txn; + + return ( $transaction, $msg, $trans ); +} + + + +=head2 Transactions + + Returns an RT::Transactions object of all transactions on this record object + +=cut + +sub Transactions { + my $self = shift; + + use RT::Transactions; + my $transactions = RT::Transactions->new( $self->CurrentUser ); + + #If the user has no rights, return an empty object + $transactions->Limit( + FIELD => 'ObjectId', + VALUE => $self->id, + ); + $transactions->Limit( + FIELD => 'ObjectType', + VALUE => ref($self), + ); + + return ($transactions); +} + +# + +sub CustomFields { + my $self = shift; + my $cfs = RT::CustomFields->new( $self->CurrentUser ); + + $cfs->SetContextObject( $self ); + # XXX handle multiple types properly + $cfs->LimitToLookupType( $self->CustomFieldLookupType ); + $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId ); + $cfs->ApplySortOrder; + + return $cfs; +} + +# TODO: This _only_ works for RT::Foo classes. it doesn't work, for +# example, for RT::IR::Foo classes. + +sub CustomFieldLookupId { + my $self = shift; + my $lookup = shift || $self->CustomFieldLookupType; + my @classes = ($lookup =~ /RT::(\w+)-/g); + + # Work on "RT::Queue", for instance + return $self->Id unless @classes; + + my $object = $self; + # Save a ->Load call by not calling ->FooObj->Id, just ->Foo + my $final = shift @classes; + foreach my $class (reverse @classes) { + my $method = "${class}Obj"; + $object = $object->$method; + } + + my $id = $object->$final; + unless (defined $id) { + my $method = "${final}Obj"; + $id = $object->$method->Id; + } + return $id; +} + + +=head2 CustomFieldLookupType + +Returns the path RT uses to figure out which custom fields apply to this object. + +=cut + +sub CustomFieldLookupType { + my $self = shift; + return ref($self) || $self; +} + + +=head2 AddCustomFieldValue { Field => FIELD, Value => VALUE } + +VALUE should be a string. FIELD can be any identifier of a CustomField +supported by L</LoadCustomFieldByIdentifier> method. + +Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field, +deletes the old value. +If VALUE is not a valid value for the custom field, returns +(0, 'Error message' ) otherwise, returns ($id, 'Success Message') where +$id is ID of created L<ObjectCustomFieldValue> object. + +=cut + +sub AddCustomFieldValue { + my $self = shift; + $self->_AddCustomFieldValue(@_); +} + +sub _AddCustomFieldValue { + my $self = shift; + my %args = ( + Field => undef, + Value => undef, + LargeContent => undef, + ContentType => undef, + RecordTransaction => 1, + @_ + ); + + my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'}); + unless ( $cf->Id ) { + return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) ); + } + + my $OCFs = $self->CustomFields; + $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id ); + unless ( $OCFs->Count ) { + return ( + 0, + $self->loc( + "Custom field [_1] does not apply to this object", + ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'} + ) + ); + } + + # empty string is not correct value of any CF, so undef it + foreach ( qw(Value LargeContent) ) { + $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ }; + } + + unless ( $cf->ValidateValue( $args{'Value'} ) ) { + return ( 0, $self->loc("Invalid value for custom field") ); + } + + # If the custom field only accepts a certain # of values, delete the existing + # value and record a "changed from foo to bar" transaction + unless ( $cf->UnlimitedValues ) { + + # Load up a ObjectCustomFieldValues object for this custom field and this ticket + my $values = $cf->ValuesForObject($self); + + # We need to whack any old values here. In most cases, the custom field should + # only have one value to delete. In the pathalogical case, this custom field + # used to be a multiple and we have many values to whack.... + my $cf_values = $values->Count; + + if ( $cf_values > $cf->MaxValues ) { + my $i = 0; #We want to delete all but the max we can currently have , so we can then + # execute the same code to "change" the value from old to new + while ( my $value = $values->Next ) { + $i++; + if ( $i < $cf_values ) { + my ( $val, $msg ) = $cf->DeleteValueForObject( + Object => $self, + Id => $value->id, + ); + unless ($val) { + return ( 0, $msg ); + } + my ( $TransactionId, $Msg, $TransactionObj ) = + $self->_NewTransaction( + Type => 'CustomField', + Field => $cf->Id, + OldReference => $value, + ); + } + } + $values->RedoSearch if $i; # redo search if have deleted at least one value + } + + if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) { + return $entry->id; + } + + my $old_value = $values->First; + my $old_content; + $old_content = $old_value->Content if $old_value; + + my ( $new_value_id, $value_msg ) = $cf->AddValueForObject( + Object => $self, + Content => $args{'Value'}, + LargeContent => $args{'LargeContent'}, + ContentType => $args{'ContentType'}, + ); + + unless ( $new_value_id ) { + return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) ); + } + + my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser ); + $new_value->Load( $new_value_id ); + + # now that adding the new value was successful, delete the old one + if ( $old_value ) { + my ( $val, $msg ) = $old_value->Delete(); + return ( 0, $msg ) unless $val; + } + + if ( $args{'RecordTransaction'} ) { + my ( $TransactionId, $Msg, $TransactionObj ) = + $self->_NewTransaction( + Type => 'CustomField', + Field => $cf->Id, + OldReference => $old_value, + NewReference => $new_value, + ); + } + + my $new_content = $new_value->Content; + + # For datetime, we need to display them in "human" format in result message + #XXX TODO how about date without time? + if ($cf->Type eq 'DateTime') { + my $DateObj = RT::Date->new( $self->CurrentUser ); + $DateObj->Set( + Format => 'ISO', + Value => $new_content, + ); + $new_content = $DateObj->AsString; + + if ( defined $old_content && length $old_content ) { + $DateObj->Set( + Format => 'ISO', + Value => $old_content, + ); + $old_content = $DateObj->AsString; + } + } + + unless ( defined $old_content && length $old_content ) { + return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content )); + } + elsif ( !defined $new_content || !length $new_content ) { + return ( $new_value_id, + $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) ); + } + else { + return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content)); + } + + } + + # otherwise, just add a new value and record "new value added" + else { + if ( !$cf->Repeated ) { + my $values = $cf->ValuesForObject($self); + if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) { + return $entry->id; + } + } + + my ($new_value_id, $msg) = $cf->AddValueForObject( + Object => $self, + Content => $args{'Value'}, + LargeContent => $args{'LargeContent'}, + ContentType => $args{'ContentType'}, + ); + + unless ( $new_value_id ) { + return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) ); + } + if ( $args{'RecordTransaction'} ) { + my ( $tid, $msg ) = $self->_NewTransaction( + Type => 'CustomField', + Field => $cf->Id, + NewReference => $new_value_id, + ReferenceType => 'RT::ObjectCustomFieldValue', + ); + unless ( $tid ) { + return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) ); + } + } + return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) ); + } +} + + + +=head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE } + +Deletes VALUE as a value of CustomField FIELD. + +VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue. + +If VALUE is not a valid value for the custom field, returns +(0, 'Error message' ) otherwise, returns (1, 'Success Message') + +=cut + +sub DeleteCustomFieldValue { + my $self = shift; + my %args = ( + Field => undef, + Value => undef, + ValueId => undef, + @_ + ); + + my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'}); + unless ( $cf->Id ) { + return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) ); + } + + my ( $val, $msg ) = $cf->DeleteValueForObject( + Object => $self, + Id => $args{'ValueId'}, + Content => $args{'Value'}, + ); + unless ($val) { + return ( 0, $msg ); + } + + my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction( + Type => 'CustomField', + Field => $cf->Id, + OldReference => $val, + ReferenceType => 'RT::ObjectCustomFieldValue', + ); + unless ($TransactionId) { + return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) ); + } + + my $old_value = $TransactionObj->OldValue; + # For datetime, we need to display them in "human" format in result message + if ( $cf->Type eq 'DateTime' ) { + my $DateObj = RT::Date->new( $self->CurrentUser ); + $DateObj->Set( + Format => 'ISO', + Value => $old_value, + ); + $old_value = $DateObj->AsString; + } + return ( + $TransactionId, + $self->loc( + "[_1] is no longer a value for custom field [_2]", + $old_value, $cf->Name + ) + ); +} + + + +=head2 FirstCustomFieldValue FIELD + +Return the content of the first value of CustomField FIELD for this ticket +Takes a field id or name + +=cut + +sub FirstCustomFieldValue { + my $self = shift; + my $field = shift; + + my $values = $self->CustomFieldValues( $field ); + return undef unless my $first = $values->First; + return $first->Content; +} + +=head2 CustomFieldValuesAsString FIELD + +Return the content of the CustomField FIELD for this ticket. +If this is a multi-value custom field, values will be joined with newlines. + +Takes a field id or name as the first argument + +Takes an optional Separator => "," second and third argument +if you want to join the values using something other than a newline + +=cut + +sub CustomFieldValuesAsString { + my $self = shift; + my $field = shift; + my %args = @_; + my $separator = $args{Separator} || "\n"; + + my $values = $self->CustomFieldValues( $field ); + return join ($separator, grep { defined $_ } + map { $_->Content } @{$values->ItemsArrayRef}); +} + + + +=head2 CustomFieldValues FIELD + +Return a ObjectCustomFieldValues object of all values of the CustomField whose +id or Name is FIELD for this record. + +Returns an RT::ObjectCustomFieldValues object + +=cut + +sub CustomFieldValues { + my $self = shift; + my $field = shift; + + if ( $field ) { + my $cf = $self->LoadCustomFieldByIdentifier( $field ); + + # we were asked to search on a custom field we couldn't find + unless ( $cf->id ) { + $RT::Logger->warning("Couldn't load custom field by '$field' identifier"); + return RT::ObjectCustomFieldValues->new( $self->CurrentUser ); + } + return ( $cf->ValuesForObject($self) ); + } + + # we're not limiting to a specific custom field; + my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser ); + $ocfs->LimitToObject( $self ); + return $ocfs; +} + +=head2 LoadCustomFieldByIdentifier IDENTIFER + +Find the custom field has id or name IDENTIFIER for this object. + +If no valid field is found, returns an empty RT::CustomField object. + +=cut + +sub LoadCustomFieldByIdentifier { + my $self = shift; + my $field = shift; + + my $cf; + if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) { + $cf = RT::CustomField->new($self->CurrentUser); + $cf->SetContextObject( $self ); + $cf->LoadById( $field->id ); + } + elsif ($field =~ /^\d+$/) { + $cf = RT::CustomField->new($self->CurrentUser); + $cf->SetContextObject( $self ); + $cf->LoadById($field); + } else { + + my $cfs = $self->CustomFields($self->CurrentUser); + $cfs->SetContextObject( $self ); + $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0); + $cf = $cfs->First || RT::CustomField->new($self->CurrentUser); + } + return $cf; +} + +sub ACLEquivalenceObjects { } + +sub BasicColumns { } + +sub WikiBase { + return RT->Config->Get('WebPath'). "/index.html?q="; +} + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Shredder.pm b/rt/lib/RT/Shredder.pm index 125ed0dc4..8022775dd 100644 --- a/rt/lib/RT/Shredder.pm +++ b/rt/lib/RT/Shredder.pm @@ -180,6 +180,8 @@ shredding on most databases. CREATE INDEX SHREDDER_TXN3 ON Transactions(Type, OldValue); CREATE INDEX SHREDDER_TXN4 ON Transactions(Type, NewValue) + CREATE INDEX SHREDDER_ATTACHMENTS1 ON Attachments(Creator); + =head1 INFORMATION FOR DEVELOPERS =head2 General API diff --git a/rt/lib/RT/Template.pm b/rt/lib/RT/Template.pm index 050799714..a6c0f7d0b 100755 --- a/rt/lib/RT/Template.pm +++ b/rt/lib/RT/Template.pm @@ -307,10 +307,9 @@ sub IsEmpty { Returns L<MIME::Entity> object parsed using L</Parse> method. Returns undef if last call to L</Parse> failed or never be called. -Note that content of the template is UTF-8, but L<MIME::Parser> is not -good at handling it and all data of the entity should be treated as -octets and converted to perl strings using Encode::decode_utf8 or -something else. +Note that content of the template is characters, but the contents of all +L<MIME::Entity> objects (including the one returned by this function, +are bytes in UTF-8. =cut @@ -384,8 +383,8 @@ sub _Parse { ### Should we forgive normally-fatal errors? $parser->ignore_errors(1); - # MIME::Parser doesn't play well with perl strings - utf8::encode($content); + # Always provide bytes, not characters, to MIME objects + $content = Encode::encode( 'UTF-8', $content ); $self->{'MIMEObj'} = eval { $parser->parse_data( \$content ) }; if ( my $error = $@ || $parser->last_error ) { $RT::Logger->error( "$error" ); @@ -602,17 +601,17 @@ sub _DowngradeFromHTML { require HTML::FormatText; require HTML::TreeBuilder; - require Encode; - # need to decode_utf8, see the doc of MIMEObj method + # MIME objects are always bytes, not characters my $tree = HTML::TreeBuilder->new_from_content( - Encode::decode_utf8($new_entity->bodyhandle->as_string) + Encode::decode( 'UTF-8', $new_entity->bodyhandle->as_string) ); - $new_entity->bodyhandle(MIME::Body::InCore->new( - \(scalar HTML::FormatText->new( - leftmargin => 0, - rightmargin => 78, - )->format( $tree )) - )); + my $text = HTML::FormatText->new( + leftmargin => 0, + rightmargin => 78, + )->format( $tree ); + $text = Encode::encode( "UTF-8", $text ); + + $new_entity->bodyhandle(MIME::Body::InCore->new( \$text )); $tree->delete; $orig_entity->add_part($new_entity, 0); # plain comes before html diff --git a/rt/lib/RT/Test.pm b/rt/lib/RT/Test.pm index 19dc26378..104e93a63 100644 --- a/rt/lib/RT/Test.pm +++ b/rt/lib/RT/Test.pm @@ -164,6 +164,8 @@ sub import { $class->set_config_wrapper; + $class->encode_output; + my $screen_logger = $RT::Logger->remove( 'screen' ); require Log::Dispatch::Perl; $RT::Logger->add( Log::Dispatch::Perl->new @@ -417,6 +419,13 @@ sub set_config_wrapper { }; } +sub encode_output { + my $builder = Test::More->builder; + binmode $builder->output, ":encoding(utf8)"; + binmode $builder->failure_output, ":encoding(utf8)"; + binmode $builder->todo_output, ":encoding(utf8)"; +} + sub bootstrap_db { my $self = shift; my %args = @_; @@ -639,12 +648,7 @@ sub __init_logging { $filter = $SIG{__WARN__}; } $SIG{__WARN__} = sub { - if ($filter) { - my $status = $filter->(@_); - if ($status and $status eq 'IGNORE') { - return; # pretend the bad dream never happened - } - } + $filter->(@_) if $filter; # Avoid reporting this anonymous call frame as the source of the warning. goto &$Test_NoWarnings_Catcher; }; @@ -824,9 +828,11 @@ sub create_ticket { if ( my $content = delete $args{'Content'} ) { $args{'MIMEObj'} = MIME::Entity->build( - From => $args{'Requestor'}, - Subject => $args{'Subject'}, - Data => $content, + From => Encode::encode( "UTF-8", $args{'Requestor'} ), + Subject => RT::Interface::Email::EncodeToMIME( String => $args{'Subject'} ), + Type => "text/plain", + Charset => "UTF-8", + Data => Encode::encode( "UTF-8", $content ), ); } diff --git a/rt/lib/RT/Ticket.pm b/rt/lib/RT/Ticket.pm index c3d4c2773..91a7fb581 100755 --- a/rt/lib/RT/Ticket.pm +++ b/rt/lib/RT/Ticket.pm @@ -858,10 +858,10 @@ sub _Parse822HeadersForAttributes { } $args{$date} = $dateobj->ISO; } - $args{'mimeobj'} = MIME::Entity->new(); - $args{'mimeobj'}->build( - Type => ( $args{'contenttype'} || 'text/plain' ), - Data => ($args{'content'} || '') + $args{'mimeobj'} = MIME::Entity->build( + Type => ( $args{'contenttype'} || 'text/plain' ), + Charset => "UTF-8", + Data => Encode::encode("UTF-8", ($args{'content'} || '')) ); return (%args); @@ -2344,8 +2344,11 @@ sub _RecordNote { } unless ( $args{'MIMEObj'} ) { + my $data = ref $args{'Content'}? $args{'Content'} : [ $args{'Content'} ]; $args{'MIMEObj'} = MIME::Entity->build( - Data => ( ref $args{'Content'}? $args{'Content'}: [ $args{'Content'} ] ) + Type => "text/plain", + Charset => "UTF-8", + Data => [ map {Encode::encode("UTF-8", $_)} @{$data} ], ); } @@ -2367,13 +2370,13 @@ sub _RecordNote { my $addresses = join ', ', ( map { RT::User->CanonicalizeEmailAddress( $_->address ) } Email::Address->parse( $args{ $type . 'MessageTo' } ) ); - $args{'MIMEObj'}->head->replace( 'RT-Send-' . $type, Encode::encode_utf8( $addresses ) ); + $args{'MIMEObj'}->head->replace( 'RT-Send-' . $type, Encode::encode( "UTF-8", $addresses ) ); } } foreach my $argument (qw(Encrypt Sign)) { $args{'MIMEObj'}->head->replace( - "X-RT-$argument" => Encode::encode_utf8( $args{ $argument } ) + "X-RT-$argument" => Encode::encode( "UTF-8", $args{ $argument } ) ) if defined $args{ $argument }; } @@ -2381,10 +2384,10 @@ sub _RecordNote { # internal Message-ID now, so all emails sent because of this # message have a common Message-ID my $org = RT->Config->Get('Organization'); - my $msgid = $args{'MIMEObj'}->head->get('Message-ID'); + my $msgid = Encode::decode( "UTF-8", $args{'MIMEObj'}->head->get('Message-ID') ); unless (defined $msgid && $msgid =~ /<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>/) { $args{'MIMEObj'}->head->set( - 'RT-Message-ID' => Encode::encode_utf8( + 'RT-Message-ID' => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId( Ticket => $self ) ) ); @@ -2393,7 +2396,7 @@ sub _RecordNote { #Record the correspondence (write the transaction) my ( $Trans, $msg, $TransObj ) = $self->_NewTransaction( Type => $args{'NoteType'}, - Data => ( $args{'MIMEObj'}->head->get('subject') || 'No Subject' ), + Data => ( Encode::decode( "UTF-8", $args{'MIMEObj'}->head->get('Subject') ) || 'No Subject' ), TimeTaken => $args{'TimeTaken'}, MIMEObj => $args{'MIMEObj'}, CommitScrips => $args{'CommitScrips'}, @@ -2429,10 +2432,10 @@ sub DryRun { } my $Message = MIME::Entity->build( + Subject => defined $args{UpdateSubject} ? Encode::encode( "UTF-8", $args{UpdateSubject} ) : "", Type => 'text/plain', - Subject => defined $args{UpdateSubject} ? Encode::encode_utf8( $args{UpdateSubject} ) : "", Charset => 'UTF-8', - Data => $args{'UpdateContent'} || "", + Data => Encode::encode("UTF-8", $args{'UpdateContent'} || ""), ); my ( $Transaction, $Description, $Object ) = $self->$action( @@ -2461,12 +2464,12 @@ sub DryRunCreate { my $self = shift; my %args = @_; my $Message = MIME::Entity->build( - Type => 'text/plain', - Subject => defined $args{Subject} ? Encode::encode_utf8( $args{'Subject'} ) : "", + Subject => defined $args{Subject} ? Encode::encode( "UTF-8", $args{'Subject'} ) : "", (defined $args{'Cc'} ? - ( Cc => Encode::encode_utf8( $args{'Cc'} ) ) : ()), + ( Cc => Encode::encode( "UTF-8", $args{'Cc'} ) ) : ()), + Type => 'text/plain', Charset => 'UTF-8', - Data => $args{'Content'} || "", + Data => Encode::encode( "UTF-8", $args{'Content'} || ""), ); my ( $Transaction, $Object, $Description ) = $self->Create( diff --git a/rt/lib/RT/Ticket.pm.orig b/rt/lib/RT/Ticket.pm.orig new file mode 100755 index 000000000..c3d4c2773 --- /dev/null +++ b/rt/lib/RT/Ticket.pm.orig @@ -0,0 +1,4379 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +=head1 SYNOPSIS + + use RT::Ticket; + my $ticket = RT::Ticket->new($CurrentUser); + $ticket->Load($ticket_id); + +=head1 DESCRIPTION + +This module lets you manipulate RT's ticket object. + + +=head1 METHODS + + +=cut + + +package RT::Ticket; + +use strict; +use warnings; + + +use RT::Queue; +use RT::User; +use RT::Record; +use RT::Links; +use RT::Date; +use RT::CustomFields; +use RT::Tickets; +use RT::Transactions; +use RT::Reminders; +use RT::URI::fsck_com_rt; +use RT::URI; +use RT::URI::freeside; +use MIME::Entity; +use Devel::GlobalDestruction; + + +# A helper table for links mapping to make it easier +# to build and parse links between tickets + +our %LINKTYPEMAP = ( + MemberOf => { Type => 'MemberOf', + Mode => 'Target', }, + Parents => { Type => 'MemberOf', + Mode => 'Target', }, + Members => { Type => 'MemberOf', + Mode => 'Base', }, + Children => { Type => 'MemberOf', + Mode => 'Base', }, + HasMember => { Type => 'MemberOf', + Mode => 'Base', }, + RefersTo => { Type => 'RefersTo', + Mode => 'Target', }, + ReferredToBy => { Type => 'RefersTo', + Mode => 'Base', }, + DependsOn => { Type => 'DependsOn', + Mode => 'Target', }, + DependedOnBy => { Type => 'DependsOn', + Mode => 'Base', }, + MergedInto => { Type => 'MergedInto', + Mode => 'Target', }, + +); + + +# A helper table for links mapping to make it easier +# to build and parse links between tickets + +our %LINKDIRMAP = ( + MemberOf => { Base => 'MemberOf', + Target => 'HasMember', }, + RefersTo => { Base => 'RefersTo', + Target => 'ReferredToBy', }, + DependsOn => { Base => 'DependsOn', + Target => 'DependedOnBy', }, + MergedInto => { Base => 'MergedInto', + Target => 'MergedInto', }, + +); + + +sub LINKTYPEMAP { return \%LINKTYPEMAP } +sub LINKDIRMAP { return \%LINKDIRMAP } + +our %MERGE_CACHE = ( + effective => {}, + merged => {}, +); + + +=head2 Load + +Takes a single argument. This can be a ticket id, ticket alias or +local ticket uri. If the ticket can't be loaded, returns undef. +Otherwise, returns the ticket id. + +=cut + +sub Load { + my $self = shift; + my $id = shift; + $id = '' unless defined $id; + + # TODO: modify this routine to look at EffectiveId and + # do the recursive load thing. be careful to cache all + # the interim tickets we try so we don't loop forever. + + unless ( $id =~ /^\d+$/ ) { + $RT::Logger->debug("Tried to load a bogus ticket id: '$id'"); + return (undef); + } + + $id = $MERGE_CACHE{'effective'}{ $id } + if $MERGE_CACHE{'effective'}{ $id }; + + my ($ticketid, $msg) = $self->LoadById( $id ); + unless ( $self->Id ) { + $RT::Logger->debug("$self tried to load a bogus ticket: $id"); + return (undef); + } + + #If we're merged, resolve the merge. + if ( $self->EffectiveId && $self->EffectiveId != $self->Id ) { + $RT::Logger->debug( + "We found a merged ticket. " + . $self->id ."/". $self->EffectiveId + ); + my $real_id = $self->Load( $self->EffectiveId ); + $MERGE_CACHE{'effective'}{ $id } = $real_id; + return $real_id; + } + + #Ok. we're loaded. lets get outa here. + return $self->Id; +} + + + +=head2 Create (ARGS) + +Arguments: ARGS is a hash of named parameters. Valid parameters are: + + id + Queue - Either a Queue object or a Queue Name + Requestor - A reference to a list of email addresses or RT user Names + Cc - A reference to a list of email addresses or Names + AdminCc - A reference to a list of email addresses or Names + SquelchMailTo - A reference to a list of email addresses - + who should this ticket not mail + Type -- The ticket's type. ignore this for now + Owner -- This ticket's owner. either an RT::User object or this user's id + Subject -- A string describing the subject of the ticket + Priority -- an integer from 0 to 99 + InitialPriority -- an integer from 0 to 99 + FinalPriority -- an integer from 0 to 99 + Status -- any valid status for Queue's Lifecycle, otherwises uses on_create from Lifecycle default + TimeEstimated -- an integer. estimated time for this task in minutes + TimeWorked -- an integer. time worked so far in minutes + TimeLeft -- an integer. time remaining in minutes + Starts -- an ISO date describing the ticket's start date and time in GMT + Due -- an ISO date describing the ticket's due date and time in GMT + MIMEObj -- a MIME::Entity object with the content of the initial ticket request. + CustomField-<n> -- a scalar or array of values for the customfield with the id <n> + +Ticket links can be set up during create by passing the link type as a hask key and +the ticket id to be linked to as a value (or a URI when linking to other objects). +Multiple links of the same type can be created by passing an array ref. For example: + + Parents => 45, + DependsOn => [ 15, 22 ], + RefersTo => 'http://www.bestpractical.com', + +Supported link types are C<MemberOf>, C<HasMember>, C<RefersTo>, C<ReferredToBy>, +C<DependsOn> and C<DependedOnBy>. Also, C<Parents> is alias for C<MemberOf> and +C<Members> and C<Children> are aliases for C<HasMember>. + +Returns: TICKETID, Transaction Object, Error Message + + +=cut + +sub Create { + my $self = shift; + + my %args = ( + id => undef, + EffectiveId => undef, + Queue => undef, + Requestor => undef, + Cc => undef, + AdminCc => undef, + SquelchMailTo => undef, + TransSquelchMailTo => undef, + Type => 'ticket', + Owner => undef, + Subject => '', + InitialPriority => undef, + FinalPriority => undef, + Priority => undef, + Status => undef, + TimeWorked => "0", + TimeLeft => 0, + TimeEstimated => 0, + Due => undef, + Starts => undef, + Started => undef, + Resolved => undef, + WillResolve => undef, + MIMEObj => undef, + _RecordTransaction => 1, + DryRun => 0, + @_ + ); + + my ($ErrStr, @non_fatal_errors); + + my $QueueObj = RT::Queue->new( RT->SystemUser ); + if ( ref $args{'Queue'} eq 'RT::Queue' ) { + $QueueObj->Load( $args{'Queue'}->Id ); + } + elsif ( $args{'Queue'} ) { + $QueueObj->Load( $args{'Queue'} ); + } + else { + $RT::Logger->debug("'". ( $args{'Queue'} ||''). "' not a recognised queue object." ); + } + + #Can't create a ticket without a queue. + unless ( $QueueObj->Id ) { + $RT::Logger->debug("$self No queue given for ticket creation."); + return ( 0, 0, $self->loc('Could not create ticket. Queue not set') ); + } + + + #Now that we have a queue, Check the ACLS + unless ( + $self->CurrentUser->HasRight( + Right => 'CreateTicket', + Object => $QueueObj + ) + ) + { + return ( + 0, 0, + $self->loc( "No permission to create tickets in the queue '[_1]'", $QueueObj->Name)); + } + + my $cycle = $QueueObj->Lifecycle; + unless ( defined $args{'Status'} && length $args{'Status'} ) { + $args{'Status'} = $cycle->DefaultOnCreate; + } + + $args{'Status'} = lc $args{'Status'}; + unless ( $cycle->IsValid( $args{'Status'} ) ) { + return ( 0, 0, + $self->loc("Status '[_1]' isn't a valid status for tickets in this queue.", + $self->loc($args{'Status'})) + ); + } + + unless ( $cycle->IsTransition( '' => $args{'Status'} ) ) { + return ( 0, 0, + $self->loc("New tickets can not have status '[_1]' in this queue.", + $self->loc($args{'Status'})) + ); + } + + + + #Since we have a queue, we can set queue defaults + + #Initial Priority + # If there's no queue default initial priority and it's not set, set it to 0 + $args{'InitialPriority'} = $QueueObj->InitialPriority || 0 + unless defined $args{'InitialPriority'}; + + #Final priority + # If there's no queue default final priority and it's not set, set it to 0 + $args{'FinalPriority'} = $QueueObj->FinalPriority || 0 + unless defined $args{'FinalPriority'}; + + # Priority may have changed from InitialPriority, for the case + # where we're importing tickets (eg, from an older RT version.) + $args{'Priority'} = $args{'InitialPriority'} + unless defined $args{'Priority'}; + + # Dates + #TODO we should see what sort of due date we're getting, rather + + # than assuming it's in ISO format. + + #Set the due date. if we didn't get fed one, use the queue default due in + my $Due = RT::Date->new( $self->CurrentUser ); + if ( defined $args{'Due'} ) { + $Due->Set( Format => 'ISO', Value => $args{'Due'} ); + } + elsif ( my $due_in = $QueueObj->DefaultDueIn ) { + $Due->SetToNow; + $Due->AddDays( $due_in ); + } + + my $Starts = RT::Date->new( $self->CurrentUser ); + if ( defined $args{'Starts'} ) { + $Starts->Set( Format => 'ISO', Value => $args{'Starts'} ); + } + + my $Started = RT::Date->new( $self->CurrentUser ); + if ( defined $args{'Started'} ) { + $Started->Set( Format => 'ISO', Value => $args{'Started'} ); + } + + my $WillResolve = RT::Date->new($self->CurrentUser ); + if ( defined $args{'WillResolve'} ) { + $WillResolve->Set( Format => 'ISO', Value => $args{'WillResolve'} ); + } + + # If the status is not an initial status, set the started date + elsif ( !$cycle->IsInitial($args{'Status'}) ) { + $Started->SetToNow; + } + + my $Resolved = RT::Date->new( $self->CurrentUser ); + if ( defined $args{'Resolved'} ) { + $Resolved->Set( Format => 'ISO', Value => $args{'Resolved'} ); + } + + #If the status is an inactive status, set the resolved date + elsif ( $cycle->IsInactive( $args{'Status'} ) ) + { + $RT::Logger->debug( "Got a ". $args{'Status'} + ."(inactive) ticket with undefined resolved date. Setting to now." + ); + $Resolved->SetToNow; + } + + # }}} + + # Dealing with time fields + + $args{'TimeEstimated'} = 0 unless defined $args{'TimeEstimated'}; + $args{'TimeWorked'} = 0 unless defined $args{'TimeWorked'}; + $args{'TimeLeft'} = 0 unless defined $args{'TimeLeft'}; + + # }}} + + # Deal with setting the owner + + my $Owner; + if ( ref( $args{'Owner'} ) eq 'RT::User' ) { + if ( $args{'Owner'}->id ) { + $Owner = $args{'Owner'}; + } else { + $RT::Logger->error('Passed an empty RT::User for owner'); + push @non_fatal_errors, + $self->loc("Owner could not be set.") . " ". + $self->loc("Invalid value for [_1]",loc('owner')); + $Owner = undef; + } + } + + #If we've been handed something else, try to load the user. + elsif ( $args{'Owner'} ) { + $Owner = RT::User->new( $self->CurrentUser ); + $Owner->Load( $args{'Owner'} ); + if (!$Owner->id) { + $Owner->LoadByEmail( $args{'Owner'} ) + } + unless ( $Owner->Id ) { + push @non_fatal_errors, + $self->loc("Owner could not be set.") . " " + . $self->loc( "User '[_1]' could not be found.", $args{'Owner'} ); + $Owner = undef; + } + } + + #If we have a proposed owner and they don't have the right + #to own a ticket, scream about it and make them not the owner + + my $DeferOwner; + if ( $Owner && $Owner->Id != RT->Nobody->Id + && !$Owner->HasRight( Object => $QueueObj, Right => 'OwnTicket' ) ) + { + $DeferOwner = $Owner; + $Owner = undef; + $RT::Logger->debug('going to deffer setting owner'); + + } + + #If we haven't been handed a valid owner, make it nobody. + unless ( defined($Owner) && $Owner->Id ) { + $Owner = RT::User->new( $self->CurrentUser ); + $Owner->Load( RT->Nobody->Id ); + } + + # }}} + +# We attempt to load or create each of the people who might have a role for this ticket +# _outside_ the transaction, so we don't get into ticket creation races + foreach my $type ( "Cc", "AdminCc", "Requestor" ) { + $args{ $type } = [ $args{ $type } ] unless ref $args{ $type }; + foreach my $watcher ( splice @{ $args{$type} } ) { + next unless $watcher; + if ( $watcher =~ /^\d+$/ ) { + push @{ $args{$type} }, $watcher; + } else { + my @addresses = RT::EmailParser->ParseEmailAddress( $watcher ); + foreach my $address( @addresses ) { + my $user = RT::User->new( RT->SystemUser ); + my ($uid, $msg) = $user->LoadOrCreateByEmail( $address ); + unless ( $uid ) { + push @non_fatal_errors, + $self->loc("Couldn't load or create user: [_1]", $msg); + } else { + push @{ $args{$type} }, $user->id; + } + } + } + } + } + + $args{'Type'} = lc $args{'Type'} + if $args{'Type'} =~ /^(ticket|approval|reminder)$/i; + + $args{'Subject'} =~ s/\n//g; + + $RT::Handle->BeginTransaction(); + + my %params = ( + Queue => $QueueObj->Id, + Owner => $Owner->Id, + Subject => $args{'Subject'}, + InitialPriority => $args{'InitialPriority'}, + FinalPriority => $args{'FinalPriority'}, + Priority => $args{'Priority'}, + Status => $args{'Status'}, + TimeWorked => $args{'TimeWorked'}, + TimeEstimated => $args{'TimeEstimated'}, + TimeLeft => $args{'TimeLeft'}, + Type => $args{'Type'}, + Starts => $Starts->ISO, + Started => $Started->ISO, + Resolved => $Resolved->ISO, + WillResolve => $WillResolve->ISO, + Due => $Due->ISO + ); + +# Parameters passed in during an import that we probably don't want to touch, otherwise + foreach my $attr (qw(id Creator Created LastUpdated LastUpdatedBy)) { + $params{$attr} = $args{$attr} if $args{$attr}; + } + + # Delete null integer parameters + foreach my $attr + (qw(TimeWorked TimeLeft TimeEstimated InitialPriority FinalPriority)) + { + delete $params{$attr} + unless ( exists $params{$attr} && $params{$attr} ); + } + + # Delete the time worked if we're counting it in the transaction + delete $params{'TimeWorked'} if $args{'_RecordTransaction'}; + + my ($id,$ticket_message) = $self->SUPER::Create( %params ); + unless ($id) { + $RT::Logger->crit( "Couldn't create a ticket: " . $ticket_message ); + $RT::Handle->Rollback(); + return ( 0, 0, + $self->loc("Ticket could not be created due to an internal error") + ); + } + + #Set the ticket's effective ID now that we've created it. + my ( $val, $msg ) = $self->__Set( + Field => 'EffectiveId', + Value => ( $args{'EffectiveId'} || $id ) + ); + unless ( $val ) { + $RT::Logger->crit("Couldn't set EffectiveId: $msg"); + $RT::Handle->Rollback; + return ( 0, 0, + $self->loc("Ticket could not be created due to an internal error") + ); + } + + my $create_groups_ret = $self->_CreateTicketGroups(); + unless ($create_groups_ret) { + $RT::Logger->crit( "Couldn't create ticket groups for ticket " + . $self->Id + . ". aborting Ticket creation." ); + $RT::Handle->Rollback(); + return ( 0, 0, + $self->loc("Ticket could not be created due to an internal error") + ); + } + + # Set the owner in the Groups table + # We denormalize it into the Ticket table too because doing otherwise would + # kill performance, bigtime. It gets kept in lockstep thanks to the magic of transactionalization + $self->OwnerGroup->_AddMember( + PrincipalId => $Owner->PrincipalId, + InsideTransaction => 1 + ) unless $DeferOwner; + + + + # Deal with setting up watchers + + foreach my $type ( "Cc", "AdminCc", "Requestor" ) { + # we know it's an array ref + foreach my $watcher ( @{ $args{$type} } ) { + + # Note that we're using AddWatcher, rather than _AddWatcher, as we + # actually _want_ that ACL check. Otherwise, random ticket creators + # could make themselves adminccs and maybe get ticket rights. that would + # be poor + my $method = $type eq 'AdminCc'? 'AddWatcher': '_AddWatcher'; + + my ($val, $msg) = $self->$method( + Type => $type, + PrincipalId => $watcher, + Silent => 1, + ); + push @non_fatal_errors, $self->loc("Couldn't set [_1] watcher: [_2]", $type, $msg) + unless $val; + } + } + + if ($args{'SquelchMailTo'}) { + my @squelch = ref( $args{'SquelchMailTo'} ) ? @{ $args{'SquelchMailTo'} } + : $args{'SquelchMailTo'}; + $self->_SquelchMailTo( @squelch ); + } + + + # }}} + + # Add all the custom fields + + foreach my $arg ( keys %args ) { + next unless $arg =~ /^CustomField-(\d+)$/i; + my $cfid = $1; + + foreach my $value ( + UNIVERSAL::isa( $args{$arg} => 'ARRAY' ) ? @{ $args{$arg} } : ( $args{$arg} ) ) + { + next unless defined $value && length $value; + + # Allow passing in uploaded LargeContent etc by hash reference + my ($status, $msg) = $self->_AddCustomFieldValue( + (UNIVERSAL::isa( $value => 'HASH' ) + ? %$value + : (Value => $value) + ), + Field => $cfid, + RecordTransaction => 0, + ); + push @non_fatal_errors, $msg unless $status; + } + } + + # }}} + + # Deal with setting up links + + # TODO: Adding link may fire scrips on other end and those scrips + # could create transactions on this ticket before 'Create' transaction. + # + # We should implement different lifecycle: record 'Create' transaction, + # create links and only then fire create transaction's scrips. + # + # Ideal variant: add all links without firing scrips, record create + # transaction and only then fire scrips on the other ends of links. + # + # //RUZ + + foreach my $type ( keys %LINKTYPEMAP ) { + next unless ( defined $args{$type} ); + foreach my $link ( + ref( $args{$type} ) ? @{ $args{$type} } : ( $args{$type} ) ) + { + my ( $val, $msg, $obj ) = $self->__GetTicketFromURI( URI => $link ); + unless ($val) { + push @non_fatal_errors, $msg; + next; + } + + # Check rights on the other end of the link if we must + # then run _AddLink that doesn't check for ACLs + if ( RT->Config->Get( 'StrictLinkACL' ) ) { + if ( $obj && !$obj->CurrentUserHasRight('ModifyTicket') ) { + push @non_fatal_errors, $self->loc('Linking. Permission denied'); + next; + } + } + + if ( $obj && lc $obj->Status eq 'deleted' ) { + push @non_fatal_errors, + $self->loc("Linking. Can't link to a deleted ticket"); + next; + } + + my ( $wval, $wmsg ) = $self->_AddLink( + Type => $LINKTYPEMAP{$type}->{'Type'}, + $LINKTYPEMAP{$type}->{'Mode'} => $link, + Silent => !$args{'_RecordTransaction'} || $self->Type eq 'reminder', + 'Silent'. ( $LINKTYPEMAP{$type}->{'Mode'} eq 'Base'? 'Target': 'Base' ) + => 1, + ); + + push @non_fatal_errors, $wmsg unless ($wval); + } + } + + # }}} + + # {{{ Deal with auto-customer association + + #unless we already have (a) customer(s)... + unless ( $self->Customers->Count ) { + + #first find any requestors with emails but *without* customer targets + my @NoCust_Requestors = + grep { $_->EmailAddress && ! $_->Customers->Count } + @{ $self->_Requestors->UserMembersObj->ItemsArrayRef }; + + for my $Requestor (@NoCust_Requestors) { + + #perhaps the stuff in here should be in a User method?? + my @Customers = + &RT::URI::freeside::email_search( email=>$Requestor->EmailAddress ); + + foreach my $custnum ( map $_->{'custnum'}, @Customers ) { + + ## false laziness w/RT/Interface/Web_Vendor.pm + my @link = ( 'Type' => 'MemberOf', + 'Target' => "freeside://freeside/cust_main/$custnum", + ); + + my( $val, $msg ) = $Requestor->_AddLink(@link); + #XXX should do something with $msg# push @non_fatal_errors, $msg; + + } + + } + + #find any requestors with customer targets + + my %cust_target = (); + + my @Requestors = + grep { $_->Customers->Count } + @{ $self->_Requestors->UserMembersObj->ItemsArrayRef }; + + foreach my $Requestor ( @Requestors ) { + foreach my $cust_link ( @{ $Requestor->Customers->ItemsArrayRef } ) { + $cust_target{ $cust_link->Target } = 1; + } + } + + #and then auto-associate this ticket with those customers + + foreach my $cust_target ( keys %cust_target ) { + + my @link = ( 'Type' => 'MemberOf', + #'Target' => "freeside://freeside/cust_main/$custnum", + 'Target' => $cust_target, + ); + + my( $val, $msg ) = $self->_AddLink(@link); + push @non_fatal_errors, $msg; + + } + + } + + # }}} + + # Now that we've created the ticket and set up its metadata, we can actually go and check OwnTicket on the ticket itself. + # This might be different than before in cases where extensions like RTIR are doing clever things with RT's ACL system + if ( $DeferOwner ) { + if (!$DeferOwner->HasRight( Object => $self, Right => 'OwnTicket')) { + + $RT::Logger->warning( "User " . $DeferOwner->Name . "(" . $DeferOwner->id + . ") was proposed as a ticket owner but has no rights to own " + . "tickets in " . $QueueObj->Name ); + push @non_fatal_errors, $self->loc( + "Owner '[_1]' does not have rights to own this ticket.", + $DeferOwner->Name + ); + } else { + $Owner = $DeferOwner; + $self->__Set(Field => 'Owner', Value => $Owner->id); + + } + $self->OwnerGroup->_AddMember( + PrincipalId => $Owner->PrincipalId, + InsideTransaction => 1 + ); + } + + #don't make a transaction or fire off any scrips for reminders either + if ( $args{'_RecordTransaction'} && $self->Type ne 'reminder' ) { + + # Add a transaction for the create + my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction( + Type => "Create", + TimeTaken => $args{'TimeWorked'}, + MIMEObj => $args{'MIMEObj'}, + CommitScrips => !$args{'DryRun'}, + SquelchMailTo => $args{'TransSquelchMailTo'}, + ); + + if ( $self->Id && $Trans ) { + + #$TransObj->UpdateCustomFields(ARGSRef => \%args); + $TransObj->UpdateCustomFields(%args); + + $RT::Logger->info( "Ticket " . $self->Id . " created in queue '" . $QueueObj->Name . "' by " . $self->CurrentUser->Name ); + $ErrStr = $self->loc( "Ticket [_1] created in queue '[_2]'", $self->Id, $QueueObj->Name ); + $ErrStr = join( "\n", $ErrStr, @non_fatal_errors ); + } + else { + $RT::Handle->Rollback(); + + $ErrStr = join( "\n", $ErrStr, @non_fatal_errors ); + $RT::Logger->error("Ticket couldn't be created: $ErrStr"); + return ( 0, 0, $self->loc( "Ticket could not be created due to an internal error")); + } + + if ( $args{'DryRun'} ) { + $RT::Handle->Rollback(); + return ($self->id, $TransObj, $ErrStr); + } + $RT::Handle->Commit(); + return ( $self->Id, $TransObj->Id, $ErrStr ); + + # }}} + } + else { + + # Not going to record a transaction + $RT::Handle->Commit(); + $ErrStr = $self->loc( "Ticket [_1] created in queue '[_2]'", $self->Id, $QueueObj->Name ); + $ErrStr = join( "\n", $ErrStr, @non_fatal_errors ); + return ( $self->Id, 0, $ErrStr ); + + } +} + +sub SetType { + my $self = shift; + my $value = shift; + + # Force lowercase on internal RT types + $value = lc $value + if $value =~ /^(ticket|approval|reminder)$/i; + return $self->_Set(Field => 'Type', Value => $value, @_); +} + + + +=head2 _Parse822HeadersForAttributes Content + +Takes an RFC822 style message and parses its attributes into a hash. + +=cut + +sub _Parse822HeadersForAttributes { + my $self = shift; + my $content = shift; + my %args; + + my @lines = ( split ( /\n/, $content ) ); + while ( defined( my $line = shift @lines ) ) { + if ( $line =~ /^(.*?):(?:\s+(.*))?$/ ) { + my $value = $2; + my $tag = lc($1); + + $tag =~ s/-//g; + if ( defined( $args{$tag} ) ) + { #if we're about to get a second value, make it an array + $args{$tag} = [ $args{$tag} ]; + } + if ( ref( $args{$tag} ) ) + { #If it's an array, we want to push the value + push @{ $args{$tag} }, $value; + } + else { #if there's nothing there, just set the value + $args{$tag} = $value; + } + } elsif ($line =~ /^$/) { + + #TODO: this won't work, since "" isn't of the form "foo:value" + + while ( defined( my $l = shift @lines ) ) { + push @{ $args{'content'} }, $l; + } + } + + } + + foreach my $date (qw(due starts started resolved)) { + my $dateobj = RT::Date->new(RT->SystemUser); + if ( defined ($args{$date}) and $args{$date} =~ /^\d+$/ ) { + $dateobj->Set( Format => 'unix', Value => $args{$date} ); + } + else { + $dateobj->Set( Format => 'unknown', Value => $args{$date} ); + } + $args{$date} = $dateobj->ISO; + } + $args{'mimeobj'} = MIME::Entity->new(); + $args{'mimeobj'}->build( + Type => ( $args{'contenttype'} || 'text/plain' ), + Data => ($args{'content'} || '') + ); + + return (%args); +} + + + +=head2 Import PARAMHASH + +Import a ticket. +Doesn't create a transaction. +Doesn't supply queue defaults, etc. + +Returns: TICKETID + +=cut + +sub Import { + my $self = shift; + my ( $ErrStr, $QueueObj, $Owner ); + + my %args = ( + id => undef, + EffectiveId => undef, + Queue => undef, + Requestor => undef, + Type => 'ticket', + Owner => RT->Nobody->Id, + Subject => '[no subject]', + InitialPriority => undef, + FinalPriority => undef, + Status => 'new', + TimeWorked => "0", + Due => undef, + Created => undef, + Updated => undef, + Resolved => undef, + Told => undef, + @_ + ); + + if ( ( defined( $args{'Queue'} ) ) && ( !ref( $args{'Queue'} ) ) ) { + $QueueObj = RT::Queue->new(RT->SystemUser); + $QueueObj->Load( $args{'Queue'} ); + + #TODO error check this and return 0 if it's not loading properly +++ + } + elsif ( ref( $args{'Queue'} ) eq 'RT::Queue' ) { + $QueueObj = RT::Queue->new(RT->SystemUser); + $QueueObj->Load( $args{'Queue'}->Id ); + } + else { + $RT::Logger->debug( + "$self " . $args{'Queue'} . " not a recognised queue object." ); + } + + #Can't create a ticket without a queue. + unless ( defined($QueueObj) and $QueueObj->Id ) { + $RT::Logger->debug("$self No queue given for ticket creation."); + return ( 0, $self->loc('Could not create ticket. Queue not set') ); + } + + #Now that we have a queue, Check the ACLS + unless ( + $self->CurrentUser->HasRight( + Right => 'CreateTicket', + Object => $QueueObj + ) + ) + { + return ( 0, + $self->loc("No permission to create tickets in the queue '[_1]'" + , $QueueObj->Name)); + } + + # Deal with setting the owner + + # Attempt to take user object, user name or user id. + # Assign to nobody if lookup fails. + if ( defined( $args{'Owner'} ) ) { + if ( ref( $args{'Owner'} ) ) { + $Owner = $args{'Owner'}; + } + else { + $Owner = RT::User->new( $self->CurrentUser ); + $Owner->Load( $args{'Owner'} ); + if ( !defined( $Owner->id ) ) { + $Owner->Load( RT->Nobody->id ); + } + } + } + + #If we have a proposed owner and they don't have the right + #to own a ticket, scream about it and make them not the owner + if ( + ( defined($Owner) ) + and ( $Owner->Id != RT->Nobody->Id ) + and ( + !$Owner->HasRight( + Object => $QueueObj, + Right => 'OwnTicket' + ) + ) + ) + { + + $RT::Logger->warning( "$self user " + . $Owner->Name . "(" + . $Owner->id + . ") was proposed " + . "as a ticket owner but has no rights to own " + . "tickets in '" + . $QueueObj->Name . "'" ); + + $Owner = undef; + } + + #If we haven't been handed a valid owner, make it nobody. + unless ( defined($Owner) ) { + $Owner = RT::User->new( $self->CurrentUser ); + $Owner->Load( RT->Nobody->UserObj->Id ); + } + + # }}} + + unless ( $self->ValidateStatus( $args{'Status'} ) ) { + return ( 0, $self->loc("'[_1]' is an invalid value for status", $args{'Status'}) ); + } + + $self->{'_AccessibleCache'}{Created} = { 'read' => 1, 'write' => 1 }; + $self->{'_AccessibleCache'}{Creator} = { 'read' => 1, 'auto' => 1 }; + $self->{'_AccessibleCache'}{LastUpdated} = { 'read' => 1, 'write' => 1 }; + $self->{'_AccessibleCache'}{LastUpdatedBy} = { 'read' => 1, 'auto' => 1 }; + + # If we're coming in with an id, set that now. + my $EffectiveId = undef; + if ( $args{'id'} ) { + $EffectiveId = $args{'id'}; + + } + + my $id = $self->SUPER::Create( + id => $args{'id'}, + EffectiveId => $EffectiveId, + Queue => $QueueObj->Id, + Owner => $Owner->Id, + Subject => $args{'Subject'}, # loc + InitialPriority => $args{'InitialPriority'}, # loc + FinalPriority => $args{'FinalPriority'}, # loc + Priority => $args{'InitialPriority'}, # loc + Status => $args{'Status'}, # loc + TimeWorked => $args{'TimeWorked'}, # loc + Type => $args{'Type'}, # loc + Created => $args{'Created'}, # loc + Told => $args{'Told'}, # loc + LastUpdated => $args{'Updated'}, # loc + Resolved => $args{'Resolved'}, # loc + Due => $args{'Due'}, # loc + ); + + # If the ticket didn't have an id + # Set the ticket's effective ID now that we've created it. + if ( $args{'id'} ) { + $self->Load( $args{'id'} ); + } + else { + my ( $val, $msg ) = + $self->__Set( Field => 'EffectiveId', Value => $id ); + + unless ($val) { + $RT::Logger->err( + $self . "->Import couldn't set EffectiveId: $msg" ); + } + } + + my $create_groups_ret = $self->_CreateTicketGroups(); + unless ($create_groups_ret) { + $RT::Logger->crit( + "Couldn't create ticket groups for ticket " . $self->Id ); + } + + $self->OwnerGroup->_AddMember( PrincipalId => $Owner->PrincipalId ); + + foreach my $watcher ( @{ $args{'Cc'} } ) { + $self->_AddWatcher( Type => 'Cc', Email => $watcher, Silent => 1 ); + } + foreach my $watcher ( @{ $args{'AdminCc'} } ) { + $self->_AddWatcher( Type => 'AdminCc', Email => $watcher, + Silent => 1 ); + } + foreach my $watcher ( @{ $args{'Requestor'} } ) { + $self->_AddWatcher( Type => 'Requestor', Email => $watcher, + Silent => 1 ); + } + + return ( $self->Id, $ErrStr ); +} + + + + +=head2 _CreateTicketGroups + +Create the ticket groups and links for this ticket. +This routine expects to be called from Ticket->Create _inside of a transaction_ + +It will create four groups for this ticket: Requestor, Cc, AdminCc and Owner. + +It will return true on success and undef on failure. + + +=cut + + +sub _CreateTicketGroups { + my $self = shift; + + my @types = (qw(Requestor Owner Cc AdminCc)); + + foreach my $type (@types) { + my $type_obj = RT::Group->new($self->CurrentUser); + my ($id, $msg) = $type_obj->CreateRoleGroup(Domain => 'RT::Ticket-Role', + Instance => $self->Id, + Type => $type); + unless ($id) { + $RT::Logger->error("Couldn't create a ticket group of type '$type' for ticket ". + $self->Id.": ".$msg); + return(undef); + } + } + return(1); + +} + + + +=head2 OwnerGroup + +A constructor which returns an RT::Group object containing the owner of this ticket. + +=cut + +sub OwnerGroup { + my $self = shift; + my $owner_obj = RT::Group->new($self->CurrentUser); + $owner_obj->LoadTicketRoleGroup( Ticket => $self->Id, Type => 'Owner'); + return ($owner_obj); +} + + + + +=head2 AddWatcher + +AddWatcher takes a parameter hash. The keys are as follows: + +Type One of Requestor, Cc, AdminCc + +PrincipalId The RT::Principal id of the user or group that's being added as a watcher + +Email The email address of the new watcher. If a user with this + email address can't be found, a new nonprivileged user will be created. + +If the watcher you're trying to set has an RT account, set the PrincipalId paremeter to their User Id. Otherwise, set the Email parameter to their Email address. + +=cut + +sub AddWatcher { + my $self = shift; + my %args = ( + Type => undef, + PrincipalId => undef, + Email => undef, + @_ + ); + + # ModifyTicket works in any case + return $self->_AddWatcher( %args ) + if $self->CurrentUserHasRight('ModifyTicket'); + if ( $args{'Email'} ) { + my ($addr) = RT::EmailParser->ParseEmailAddress( $args{'Email'} ); + return (0, $self->loc("Couldn't parse address from '[_1]' string", $args{'Email'} )) + unless $addr; + + if ( lc $self->CurrentUser->EmailAddress + eq lc RT::User->CanonicalizeEmailAddress( $addr->address ) ) + { + $args{'PrincipalId'} = $self->CurrentUser->id; + delete $args{'Email'}; + } + } + + # If the watcher isn't the current user then the current user has no right + # bail + unless ( $args{'PrincipalId'} && $self->CurrentUser->id == $args{'PrincipalId'} ) { + return ( 0, $self->loc("Permission Denied") ); + } + + # If it's an AdminCc and they don't have 'WatchAsAdminCc', bail + if ( $args{'Type'} eq 'AdminCc' ) { + unless ( $self->CurrentUserHasRight('WatchAsAdminCc') ) { + return ( 0, $self->loc('Permission Denied') ); + } + } + + # If it's a Requestor or Cc and they don't have 'Watch', bail + elsif ( $args{'Type'} eq 'Cc' || $args{'Type'} eq 'Requestor' ) { + unless ( $self->CurrentUserHasRight('Watch') ) { + return ( 0, $self->loc('Permission Denied') ); + } + } + else { + $RT::Logger->warning( "AddWatcher got passed a bogus type"); + return ( 0, $self->loc('Error in parameters to Ticket->AddWatcher') ); + } + + return $self->_AddWatcher( %args ); +} + +#This contains the meat of AddWatcher. but can be called from a routine like +# Create, which doesn't need the additional acl check +sub _AddWatcher { + my $self = shift; + my %args = ( + Type => undef, + Silent => undef, + PrincipalId => undef, + Email => undef, + @_ + ); + + + my $principal = RT::Principal->new($self->CurrentUser); + if ($args{'Email'}) { + if ( RT::EmailParser->IsRTAddress( $args{'Email'} ) ) { + return (0, $self->loc("[_1] is an address RT receives mail at. Adding it as a '[_2]' would create a mail loop", $args{'Email'}, $self->loc($args{'Type'}))); + } + my $user = RT::User->new(RT->SystemUser); + my ($pid, $msg) = $user->LoadOrCreateByEmail( $args{'Email'} ); + $args{'PrincipalId'} = $pid if $pid; + } + if ($args{'PrincipalId'}) { + $principal->Load($args{'PrincipalId'}); + if ( $principal->id and $principal->IsUser and my $email = $principal->Object->EmailAddress ) { + return (0, $self->loc("[_1] is an address RT receives mail at. Adding it as a '[_2]' would create a mail loop", $email, $self->loc($args{'Type'}))) + if RT::EmailParser->IsRTAddress( $email ); + + } + } + + + # If we can't find this watcher, we need to bail. + unless ($principal->Id) { + $RT::Logger->error("Could not load create a user with the email address '".$args{'Email'}. "' to add as a watcher for ticket ".$self->Id); + return(0, $self->loc("Could not find or create that user")); + } + + + my $group = RT::Group->new($self->CurrentUser); + $group->LoadTicketRoleGroup(Type => $args{'Type'}, Ticket => $self->Id); + unless ($group->id) { + return(0,$self->loc("Group not found")); + } + + if ( $group->HasMember( $principal)) { + + return ( 0, $self->loc('[_1] is already a [_2] for this ticket', + $principal->Object->Name, $self->loc($args{'Type'})) ); + } + + + my ( $m_id, $m_msg ) = $group->_AddMember( PrincipalId => $principal->Id, + InsideTransaction => 1 ); + unless ($m_id) { + $RT::Logger->error("Failed to add ".$principal->Id." as a member of group ".$group->Id.": ".$m_msg); + + return ( 0, $self->loc('Could not make [_1] a [_2] for this ticket', + $principal->Object->Name, $self->loc($args{'Type'})) ); + } + + unless ( $args{'Silent'} ) { + $self->_NewTransaction( + Type => 'AddWatcher', + NewValue => $principal->Id, + Field => $args{'Type'} + ); + } + + return ( 1, $self->loc('Added [_1] as a [_2] for this ticket', + $principal->Object->Name, $self->loc($args{'Type'})) ); +} + + + + +=head2 DeleteWatcher { Type => TYPE, PrincipalId => PRINCIPAL_ID, Email => EMAIL_ADDRESS } + + +Deletes a Ticket watcher. Takes two arguments: + +Type (one of Requestor,Cc,AdminCc) + +and one of + +PrincipalId (an RT::Principal Id of the watcher you want to remove) + OR +Email (the email address of an existing wathcer) + + +=cut + + +sub DeleteWatcher { + my $self = shift; + + my %args = ( Type => undef, + PrincipalId => undef, + Email => undef, + @_ ); + + unless ( $args{'PrincipalId'} || $args{'Email'} ) { + return ( 0, $self->loc("No principal specified") ); + } + my $principal = RT::Principal->new( $self->CurrentUser ); + if ( $args{'PrincipalId'} ) { + + $principal->Load( $args{'PrincipalId'} ); + } + else { + my $user = RT::User->new( $self->CurrentUser ); + $user->LoadByEmail( $args{'Email'} ); + $principal->Load( $user->Id ); + } + + # If we can't find this watcher, we need to bail. + unless ( $principal->Id ) { + return ( 0, $self->loc("Could not find that principal") ); + } + + my $group = RT::Group->new( $self->CurrentUser ); + $group->LoadTicketRoleGroup( Type => $args{'Type'}, Ticket => $self->Id ); + unless ( $group->id ) { + return ( 0, $self->loc("Group not found") ); + } + + # Check ACLS + #If the watcher we're trying to add is for the current user + if ( $self->CurrentUser->PrincipalId == $principal->id ) { + + # If it's an AdminCc and they don't have + # 'WatchAsAdminCc' or 'ModifyTicket', bail + if ( $args{'Type'} eq 'AdminCc' ) { + unless ( $self->CurrentUserHasRight('ModifyTicket') + or $self->CurrentUserHasRight('WatchAsAdminCc') ) { + return ( 0, $self->loc('Permission Denied') ); + } + } + + # If it's a Requestor or Cc and they don't have + # 'Watch' or 'ModifyTicket', bail + elsif ( ( $args{'Type'} eq 'Cc' ) or ( $args{'Type'} eq 'Requestor' ) ) + { + unless ( $self->CurrentUserHasRight('ModifyTicket') + or $self->CurrentUserHasRight('Watch') ) { + return ( 0, $self->loc('Permission Denied') ); + } + } + else { + $RT::Logger->warning("$self -> DeleteWatcher got passed a bogus type"); + return ( 0, + $self->loc('Error in parameters to Ticket->DeleteWatcher') ); + } + } + + # If the watcher isn't the current user + # and the current user doesn't have 'ModifyTicket' bail + else { + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + return ( 0, $self->loc("Permission Denied") ); + } + } + + # }}} + + # see if this user is already a watcher. + + unless ( $group->HasMember($principal) ) { + return ( 0, + $self->loc( '[_1] is not a [_2] for this ticket', + $principal->Object->Name, $args{'Type'} ) ); + } + + my ( $m_id, $m_msg ) = $group->_DeleteMember( $principal->Id ); + unless ($m_id) { + $RT::Logger->error( "Failed to delete " + . $principal->Id + . " as a member of group " + . $group->Id . ": " + . $m_msg ); + + return (0, + $self->loc( + 'Could not remove [_1] as a [_2] for this ticket', + $principal->Object->Name, $args{'Type'} ) ); + } + + unless ( $args{'Silent'} ) { + $self->_NewTransaction( Type => 'DelWatcher', + OldValue => $principal->Id, + Field => $args{'Type'} ); + } + + return ( 1, + $self->loc( "[_1] is no longer a [_2] for this ticket.", + $principal->Object->Name, + $args{'Type'} ) ); +} + + + + + +=head2 SquelchMailTo [EMAIL] + +Takes an optional email address to never email about updates to this ticket. + + +Returns an array of the RT::Attribute objects for this ticket's 'SquelchMailTo' attributes. + + +=cut + +sub SquelchMailTo { + my $self = shift; + if (@_) { + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + return (); + } + } else { + unless ( $self->CurrentUserHasRight('ShowTicket') ) { + return (); + } + + } + return $self->_SquelchMailTo(@_); +} + +sub _SquelchMailTo { + my $self = shift; + if (@_) { + my $attr = shift; + $self->AddAttribute( Name => 'SquelchMailTo', Content => $attr ) + unless grep { $_->Content eq $attr } + $self->Attributes->Named('SquelchMailTo'); + } + my @attributes = $self->Attributes->Named('SquelchMailTo'); + return (@attributes); +} + + +=head2 UnsquelchMailTo ADDRESS + +Takes an address and removes it from this ticket's "SquelchMailTo" list. If an address appears multiple times, each instance is removed. + +Returns a tuple of (status, message) + +=cut + +sub UnsquelchMailTo { + my $self = shift; + + my $address = shift; + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + return ( 0, $self->loc("Permission Denied") ); + } + + my ($val, $msg) = $self->Attributes->DeleteEntry ( Name => 'SquelchMailTo', Content => $address); + return ($val, $msg); +} + + + +=head2 RequestorAddresses + +B<Returns> String: All Ticket Requestor email addresses as a string. + +=cut + +sub RequestorAddresses { + my $self = shift; + + unless ( $self->CurrentUserHasRight('ShowTicket') ) { + return undef; + } + + return ( $self->Requestors->MemberEmailAddressesAsString ); +} + + +=head2 AdminCcAddresses + +returns String: All Ticket AdminCc email addresses as a string + +=cut + +sub AdminCcAddresses { + my $self = shift; + + unless ( $self->CurrentUserHasRight('ShowTicket') ) { + return undef; + } + + return ( $self->AdminCc->MemberEmailAddressesAsString ) + +} + +=head2 CcAddresses + +returns String: All Ticket Ccs as a string of email addresses + +=cut + +sub CcAddresses { + my $self = shift; + + unless ( $self->CurrentUserHasRight('ShowTicket') ) { + return undef; + } + return ( $self->Cc->MemberEmailAddressesAsString); + +} + + + + +=head2 Requestors + +Takes nothing. +Returns this ticket's Requestors as an RT::Group object + +=cut + +sub Requestors { + my $self = shift; + + my $group = RT::Group->new($self->CurrentUser); + if ( $self->CurrentUserHasRight('ShowTicket') ) { + $group->LoadTicketRoleGroup(Type => 'Requestor', Ticket => $self->Id); + } + return ($group); + +} + +=head2 _Requestors + +Private non-ACLed variant of Reqeustors so that we can look them up for the +purposes of customer auto-association during create. + +=cut + +sub _Requestors { + my $self = shift; + + my $group = RT::Group->new($RT::SystemUser); + $group->LoadTicketRoleGroup(Type => 'Requestor', Ticket => $self->Id); + return ($group); +} + +=head2 Cc + +Takes nothing. +Returns an RT::Group object which contains this ticket's Ccs. +If the user doesn't have "ShowTicket" permission, returns an empty group + +=cut + +sub Cc { + my $self = shift; + + my $group = RT::Group->new($self->CurrentUser); + if ( $self->CurrentUserHasRight('ShowTicket') ) { + $group->LoadTicketRoleGroup(Type => 'Cc', Ticket => $self->Id); + } + return ($group); + +} + + + +=head2 AdminCc + +Takes nothing. +Returns an RT::Group object which contains this ticket's AdminCcs. +If the user doesn't have "ShowTicket" permission, returns an empty group + +=cut + +sub AdminCc { + my $self = shift; + + my $group = RT::Group->new($self->CurrentUser); + if ( $self->CurrentUserHasRight('ShowTicket') ) { + $group->LoadTicketRoleGroup(Type => 'AdminCc', Ticket => $self->Id); + } + return ($group); + +} + + + + +# a generic routine to be called by IsRequestor, IsCc and IsAdminCc + +=head2 IsWatcher { Type => TYPE, PrincipalId => PRINCIPAL_ID, Email => EMAIL } + +Takes a param hash with the attributes Type and either PrincipalId or Email + +Type is one of Requestor, Cc, AdminCc and Owner + +PrincipalId is an RT::Principal id, and Email is an email address. + +Returns true if the specified principal (or the one corresponding to the +specified address) is a member of the group Type for this ticket. + +XX TODO: This should be Memoized. + +=cut + +sub IsWatcher { + my $self = shift; + + my %args = ( Type => 'Requestor', + PrincipalId => undef, + Email => undef, + @_ + ); + + # Load the relevant group. + my $group = RT::Group->new($self->CurrentUser); + $group->LoadTicketRoleGroup(Type => $args{'Type'}, Ticket => $self->id); + + # Find the relevant principal. + if (!$args{PrincipalId} && $args{Email}) { + # Look up the specified user. + my $user = RT::User->new($self->CurrentUser); + $user->LoadByEmail($args{Email}); + if ($user->Id) { + $args{PrincipalId} = $user->PrincipalId; + } + else { + # A non-existent user can't be a group member. + return 0; + } + } + + # Ask if it has the member in question + return $group->HasMember( $args{'PrincipalId'} ); +} + + + +=head2 IsRequestor PRINCIPAL_ID + +Takes an L<RT::Principal> id. + +Returns true if the principal is a requestor of the current ticket. + +=cut + +sub IsRequestor { + my $self = shift; + my $person = shift; + + return ( $self->IsWatcher( Type => 'Requestor', PrincipalId => $person ) ); + +}; + + + +=head2 IsCc PRINCIPAL_ID + + Takes an RT::Principal id. + Returns true if the principal is a Cc of the current ticket. + + +=cut + +sub IsCc { + my $self = shift; + my $cc = shift; + + return ( $self->IsWatcher( Type => 'Cc', PrincipalId => $cc ) ); + +} + + + +=head2 IsAdminCc PRINCIPAL_ID + + Takes an RT::Principal id. + Returns true if the principal is an AdminCc of the current ticket. + +=cut + +sub IsAdminCc { + my $self = shift; + my $person = shift; + + return ( $self->IsWatcher( Type => 'AdminCc', PrincipalId => $person ) ); + +} + + + +=head2 IsOwner + + Takes an RT::User object. Returns true if that user is this ticket's owner. +returns undef otherwise + +=cut + +sub IsOwner { + my $self = shift; + my $person = shift; + + # no ACL check since this is used in acl decisions + # unless ($self->CurrentUserHasRight('ShowTicket')) { + # return(undef); + # } + + #Tickets won't yet have owners when they're being created. + unless ( $self->OwnerObj->id ) { + return (undef); + } + + if ( $person->id == $self->OwnerObj->id ) { + return (1); + } + else { + return (undef); + } +} + + + + + +=head2 TransactionAddresses + +Returns a composite hashref of the results of L<RT::Transaction/Addresses> for +all this ticket's Create, Comment or Correspond transactions. The keys are +stringified email addresses. Each value is an L<Email::Address> object. + +NOTE: For performance reasons, this method might want to skip transactions and go straight for attachments. But to make that work right, we're going to need to go and walk around the access control in Attachment.pm's sub _Value. + +=cut + + +sub TransactionAddresses { + my $self = shift; + my $txns = $self->Transactions; + + my %addresses = (); + + my $attachments = RT::Attachments->new( $self->CurrentUser ); + $attachments->LimitByTicket( $self->id ); + $attachments->Columns( qw( id Headers TransactionId)); + + + foreach my $type (qw(Create Comment Correspond)) { + $attachments->Limit( ALIAS => $attachments->TransactionAlias, + FIELD => 'Type', + OPERATOR => '=', + VALUE => $type, + ENTRYAGGREGATOR => 'OR', + CASESENSITIVE => 1 + ); + } + + while ( my $att = $attachments->Next ) { + foreach my $addrlist ( values %{$att->Addresses } ) { + foreach my $addr (@$addrlist) { + +# Skip addresses without a phrase (things that are just raw addresses) if we have a phrase + next + if ( $addresses{ $addr->address } + && $addresses{ $addr->address }->phrase + && not $addr->phrase ); + + # skips "comment-only" addresses + next unless ( $addr->address ); + $addresses{ $addr->address } = $addr; + } + } + } + + return \%addresses; + +} + + + + + + +sub ValidateQueue { + my $self = shift; + my $Value = shift; + + if ( !$Value ) { + $RT::Logger->warning( " RT:::Queue::ValidateQueue called with a null value. this isn't ok."); + return (1); + } + + my $QueueObj = RT::Queue->new( $self->CurrentUser ); + my $id = $QueueObj->Load($Value); + + if ($id) { + return (1); + } + else { + return (undef); + } +} + + + +sub SetQueue { + my $self = shift; + my $NewQueue = shift; + + #Redundant. ACL gets checked in _Set; + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + return ( 0, $self->loc("Permission Denied") ); + } + + my $NewQueueObj = RT::Queue->new( $self->CurrentUser ); + $NewQueueObj->Load($NewQueue); + + unless ( $NewQueueObj->Id() ) { + return ( 0, $self->loc("That queue does not exist") ); + } + + if ( $NewQueueObj->Id == $self->QueueObj->Id ) { + return ( 0, $self->loc('That is the same value') ); + } + unless ( $self->CurrentUser->HasRight( Right => 'CreateTicket', Object => $NewQueueObj)) { + return ( 0, $self->loc("You may not create requests in that queue.") ); + } + + my $new_status; + my $old_lifecycle = $self->QueueObj->Lifecycle; + my $new_lifecycle = $NewQueueObj->Lifecycle; + if ( $old_lifecycle->Name ne $new_lifecycle->Name ) { + unless ( $old_lifecycle->HasMoveMap( $new_lifecycle ) ) { + return ( 0, $self->loc("There is no mapping for statuses between these queues. Contact your system administrator.") ); + } + $new_status = $old_lifecycle->MoveMap( $new_lifecycle )->{ lc $self->Status }; + return ( 0, $self->loc("Mapping between queues' lifecycles is incomplete. Contact your system administrator.") ) + unless $new_status; + } + + if ( $new_status ) { + my $clone = RT::Ticket->new( RT->SystemUser ); + $clone->Load( $self->Id ); + unless ( $clone->Id ) { + return ( 0, $self->loc("Couldn't load copy of ticket #[_1].", $self->Id) ); + } + + my $now = RT::Date->new( $self->CurrentUser ); + $now->SetToNow; + + my $old_status = $clone->Status; + + #If we're changing the status from initial in old to not intial in new, + # record that we've started + if ( $old_lifecycle->IsInitial($old_status) && !$new_lifecycle->IsInitial($new_status) && $clone->StartedObj->Unix == 0 ) { + #Set the Started time to "now" + $clone->_Set( + Field => 'Started', + Value => $now->ISO, + RecordTransaction => 0 + ); + } + + #When we close a ticket, set the 'Resolved' attribute to now. + # It's misnamed, but that's just historical. + if ( $new_lifecycle->IsInactive($new_status) ) { + $clone->_Set( + Field => 'Resolved', + Value => $now->ISO, + RecordTransaction => 0, + ); + } + + #Actually update the status + my ($val, $msg)= $clone->_Set( + Field => 'Status', + Value => $new_status, + RecordTransaction => 0, + ); + $RT::Logger->error( 'Status change failed on queue change: '. $msg ) + unless $val; + } + + my ($status, $msg) = $self->_Set( Field => 'Queue', Value => $NewQueueObj->Id() ); + + if ( $status ) { + # Clear the queue object cache; + $self->{_queue_obj} = undef; + + # Untake the ticket if we have no permissions in the new queue + unless ( $self->OwnerObj->HasRight( Right => 'OwnTicket', Object => $NewQueueObj ) ) { + my $clone = RT::Ticket->new( RT->SystemUser ); + $clone->Load( $self->Id ); + unless ( $clone->Id ) { + return ( 0, $self->loc("Couldn't load copy of ticket #[_1].", $self->Id) ); + } + my ($status, $msg) = $clone->SetOwner( RT->Nobody->Id, 'Force' ); + $RT::Logger->error("Couldn't set owner on queue change: $msg") unless $status; + } + + # On queue change, change queue for reminders too + my $reminder_collection = $self->Reminders->Collection; + while ( my $reminder = $reminder_collection->Next ) { + my ($status, $msg) = $reminder->SetQueue($NewQueue); + $RT::Logger->error('Queue change failed for reminder #' . $reminder->Id . ': ' . $msg) unless $status; + } + } + + return ($status, $msg); +} + + + +=head2 QueueObj + +Takes nothing. returns this ticket's queue object + +=cut + +sub QueueObj { + my $self = shift; + + if(!$self->{_queue_obj} || ! $self->{_queue_obj}->id) { + + $self->{_queue_obj} = RT::Queue->new( $self->CurrentUser ); + + #We call __Value so that we can avoid the ACL decision and some deep recursion + my ($result) = $self->{_queue_obj}->Load( $self->__Value('Queue') ); + } + return ($self->{_queue_obj}); +} + +sub SetSubject { + my $self = shift; + my $value = shift; + $value =~ s/\n//g; + return $self->_Set( Field => 'Subject', Value => $value ); +} + +=head2 SubjectTag + +Takes nothing. Returns SubjectTag for this ticket. Includes +queue's subject tag or rtname if that is not set, ticket +id and braces, for example: + + [support.example.com #123456] + +=cut + +sub SubjectTag { + my $self = shift; + return + '[' + . ($self->QueueObj->SubjectTag || RT->Config->Get('rtname')) + .' #'. $self->id + .']' + ; +} + + +=head2 DueObj + + Returns an RT::Date object containing this ticket's due date + +=cut + +sub DueObj { + my $self = shift; + + my $time = RT::Date->new( $self->CurrentUser ); + + # -1 is RT::Date slang for never + if ( my $due = $self->Due ) { + $time->Set( Format => 'sql', Value => $due ); + } + else { + $time->Set( Format => 'unix', Value => -1 ); + } + + return $time; +} + + + +=head2 DueAsString + +Returns this ticket's due date as a human readable string + +=cut + +sub DueAsString { + my $self = shift; + return $self->DueObj->AsString(); +} + + + +=head2 ResolvedObj + + Returns an RT::Date object of this ticket's 'resolved' time. + +=cut + +sub ResolvedObj { + my $self = shift; + + my $time = RT::Date->new( $self->CurrentUser ); + $time->Set( Format => 'sql', Value => $self->Resolved ); + return $time; +} + + +=head2 FirstActiveStatus + +Returns the first active status that the ticket could transition to, +according to its current Queue's lifecycle. May return undef if there +is no such possible status to transition to, or we are already in it. +This is used in L<RT::Action::AutoOpen>, for instance. + +=cut + +sub FirstActiveStatus { + my $self = shift; + + my $lifecycle = $self->QueueObj->Lifecycle; + my $status = $self->Status; + my @active = $lifecycle->Active; + # no change if no active statuses in the lifecycle + return undef unless @active; + + # no change if the ticket is already has first status from the list of active + return undef if lc $status eq lc $active[0]; + + my ($next) = grep $lifecycle->IsActive($_), $lifecycle->Transitions($status); + return $next; +} + +=head2 FirstInactiveStatus + +Returns the first inactive status that the ticket could transition to, +according to its current Queue's lifecycle. May return undef if there +is no such possible status to transition to, or we are already in it. +This is used in resolve action in UnsafeEmailCommands, for instance. + +=cut + +sub FirstInactiveStatus { + my $self = shift; + + my $lifecycle = $self->QueueObj->Lifecycle; + my $status = $self->Status; + my @inactive = $lifecycle->Inactive; + # no change if no inactive statuses in the lifecycle + return undef unless @inactive; + + # no change if the ticket is already has first status from the list of inactive + return undef if lc $status eq lc $inactive[0]; + + my ($next) = grep $lifecycle->IsInactive($_), $lifecycle->Transitions($status); + return $next; +} + +=head2 SetStarted + +Takes a date in ISO format or undef +Returns a transaction id and a message +The client calls "Start" to note that the project was started on the date in $date. +A null date means "now" + +=cut + +sub SetStarted { + my $self = shift; + my $time = shift || 0; + + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + return ( 0, $self->loc("Permission Denied") ); + } + + #We create a date object to catch date weirdness + my $time_obj = RT::Date->new( $self->CurrentUser() ); + if ( $time ) { + $time_obj->Set( Format => 'ISO', Value => $time ); + } + else { + $time_obj->SetToNow(); + } + + # We need $TicketAsSystem, in case the current user doesn't have + # ShowTicket + my $TicketAsSystem = RT::Ticket->new(RT->SystemUser); + $TicketAsSystem->Load( $self->Id ); + # Now that we're starting, open this ticket + # TODO: do we really want to force this as policy? it should be a scrip + my $next = $TicketAsSystem->FirstActiveStatus; + + $self->SetStatus( $next ) if defined $next; + + return ( $self->_Set( Field => 'Started', Value => $time_obj->ISO ) ); + +} + + + +=head2 StartedObj + + Returns an RT::Date object which contains this ticket's +'Started' time. + +=cut + +sub StartedObj { + my $self = shift; + + my $time = RT::Date->new( $self->CurrentUser ); + $time->Set( Format => 'sql', Value => $self->Started ); + return $time; +} + + + +=head2 StartsObj + + Returns an RT::Date object which contains this ticket's +'Starts' time. + +=cut + +sub StartsObj { + my $self = shift; + + my $time = RT::Date->new( $self->CurrentUser ); + $time->Set( Format => 'sql', Value => $self->Starts ); + return $time; +} + + + +=head2 ToldObj + + Returns an RT::Date object which contains this ticket's +'Told' time. + +=cut + +sub ToldObj { + my $self = shift; + + my $time = RT::Date->new( $self->CurrentUser ); + $time->Set( Format => 'sql', Value => $self->Told ); + return $time; +} + + + +=head2 ToldAsString + +A convenience method that returns ToldObj->AsString + +TODO: This should be deprecated + +=cut + +sub ToldAsString { + my $self = shift; + if ( $self->Told ) { + return $self->ToldObj->AsString(); + } + else { + return ("Never"); + } +} + + + +=head2 TimeWorkedAsString + +Returns the amount of time worked on this ticket as a Text String + +=cut + +sub TimeWorkedAsString { + my $self = shift; + my $value = $self->TimeWorked; + + # return the # of minutes worked turned into seconds and written as + # a simple text string, this is not really a date object, but if we + # diff a number of seconds vs the epoch, we'll get a nice description + # of time worked. + return "" unless $value; + return RT::Date->new( $self->CurrentUser ) + ->DurationAsString( $value * 60 ); +} + + + +=head2 TimeLeftAsString + +Returns the amount of time left on this ticket as a Text String + +=cut + +sub TimeLeftAsString { + my $self = shift; + my $value = $self->TimeLeft; + return "" unless $value; + return RT::Date->new( $self->CurrentUser ) + ->DurationAsString( $value * 60 ); +} + + + + +=head2 Comment + +Comment on this ticket. +Takes a hash with the following attributes: +If MIMEObj is undefined, Content will be used to build a MIME::Entity for this +comment. + +MIMEObj, TimeTaken, CcMessageTo, BccMessageTo, Content, DryRun + +If DryRun is defined, this update WILL NOT BE RECORDED. Scrips will not be committed. +They will, however, be prepared and you'll be able to access them through the TransactionObj + +Returns: Transaction id, Error Message, Transaction Object +(note the different order from Create()!) + +=cut + +sub Comment { + my $self = shift; + + my %args = ( CcMessageTo => undef, + BccMessageTo => undef, + MIMEObj => undef, + Content => undef, + TimeTaken => 0, + DryRun => 0, + @_ ); + + unless ( ( $self->CurrentUserHasRight('CommentOnTicket') ) + or ( $self->CurrentUserHasRight('ModifyTicket') ) ) { + return ( 0, $self->loc("Permission Denied"), undef ); + } + $args{'NoteType'} = 'Comment'; + + $RT::Handle->BeginTransaction(); + if ($args{'DryRun'}) { + $args{'CommitScrips'} = 0; + } + + my @results = $self->_RecordNote(%args); + if ($args{'DryRun'}) { + $RT::Handle->Rollback(); + } else { + $RT::Handle->Commit(); + } + + return(@results); +} + + +=head2 Correspond + +Correspond on this ticket. +Takes a hashref with the following attributes: + + +MIMEObj, TimeTaken, CcMessageTo, BccMessageTo, Content, DryRun + +if there's no MIMEObj, Content is used to build a MIME::Entity object + +If DryRun is defined, this update WILL NOT BE RECORDED. Scrips will not be committed. +They will, however, be prepared and you'll be able to access them through the TransactionObj + +Returns: Transaction id, Error Message, Transaction Object +(note the different order from Create()!) + + +=cut + +sub Correspond { + my $self = shift; + my %args = ( CcMessageTo => undef, + BccMessageTo => undef, + MIMEObj => undef, + Content => undef, + TimeTaken => 0, + @_ ); + + unless ( ( $self->CurrentUserHasRight('ReplyToTicket') ) + or ( $self->CurrentUserHasRight('ModifyTicket') ) ) { + return ( 0, $self->loc("Permission Denied"), undef ); + } + $args{'NoteType'} = 'Correspond'; + + $RT::Handle->BeginTransaction(); + if ($args{'DryRun'}) { + $args{'CommitScrips'} = 0; + } + + my @results = $self->_RecordNote(%args); + + unless ( $results[0] ) { + $RT::Handle->Rollback(); + return @results; + } + + #Set the last told date to now if this isn't mail from the requestor. + #TODO: Note that this will wrongly ack mail from any non-requestor as a "told" + unless ( $self->IsRequestor($self->CurrentUser->id) ) { + my %squelch; + $squelch{$_}++ for map {$_->Content} $self->SquelchMailTo, $results[2]->SquelchMailTo; + $self->_SetTold + if grep {not $squelch{$_}} $self->Requestors->MemberEmailAddresses; + } + + if ($args{'DryRun'}) { + $RT::Handle->Rollback(); + } else { + $RT::Handle->Commit(); + } + + return (@results); + +} + + + +=head2 _RecordNote + +the meat of both comment and correspond. + +Performs no access control checks. hence, dangerous. + +=cut + +sub _RecordNote { + my $self = shift; + my %args = ( + CcMessageTo => undef, + BccMessageTo => undef, + Encrypt => undef, + Sign => undef, + MIMEObj => undef, + Content => undef, + NoteType => 'Correspond', + TimeTaken => 0, + CommitScrips => 1, + SquelchMailTo => undef, + CustomFields => {}, + @_ + ); + + unless ( $args{'MIMEObj'} || $args{'Content'} ) { + return ( 0, $self->loc("No message attached"), undef ); + } + + unless ( $args{'MIMEObj'} ) { + $args{'MIMEObj'} = MIME::Entity->build( + Data => ( ref $args{'Content'}? $args{'Content'}: [ $args{'Content'} ] ) + ); + } + + $args{'MIMEObj'}->head->replace('X-RT-Interface' => 'API') + unless $args{'MIMEObj'}->head->get('X-RT-Interface'); + + # convert text parts into utf-8 + RT::I18N::SetMIMEEntityToUTF8( $args{'MIMEObj'} ); + + # If we've been passed in CcMessageTo and BccMessageTo fields, + # add them to the mime object for passing on to the transaction handler + # The "NotifyOtherRecipients" scripAction will look for RT-Send-Cc: and + # RT-Send-Bcc: headers + + + foreach my $type (qw/Cc Bcc/) { + if ( defined $args{ $type . 'MessageTo' } ) { + + my $addresses = join ', ', ( + map { RT::User->CanonicalizeEmailAddress( $_->address ) } + Email::Address->parse( $args{ $type . 'MessageTo' } ) ); + $args{'MIMEObj'}->head->replace( 'RT-Send-' . $type, Encode::encode_utf8( $addresses ) ); + } + } + + foreach my $argument (qw(Encrypt Sign)) { + $args{'MIMEObj'}->head->replace( + "X-RT-$argument" => Encode::encode_utf8( $args{ $argument } ) + ) if defined $args{ $argument }; + } + + # If this is from an external source, we need to come up with its + # internal Message-ID now, so all emails sent because of this + # message have a common Message-ID + my $org = RT->Config->Get('Organization'); + my $msgid = $args{'MIMEObj'}->head->get('Message-ID'); + unless (defined $msgid && $msgid =~ /<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>/) { + $args{'MIMEObj'}->head->set( + 'RT-Message-ID' => Encode::encode_utf8( + RT::Interface::Email::GenMessageId( Ticket => $self ) + ) + ); + } + + #Record the correspondence (write the transaction) + my ( $Trans, $msg, $TransObj ) = $self->_NewTransaction( + Type => $args{'NoteType'}, + Data => ( $args{'MIMEObj'}->head->get('subject') || 'No Subject' ), + TimeTaken => $args{'TimeTaken'}, + MIMEObj => $args{'MIMEObj'}, + CommitScrips => $args{'CommitScrips'}, + SquelchMailTo => $args{'SquelchMailTo'}, + CustomFields => $args{'CustomFields'}, + ); + + unless ($Trans) { + $RT::Logger->err("$self couldn't init a transaction $msg"); + return ( $Trans, $self->loc("Message could not be recorded"), undef ); + } + + return ( $Trans, $self->loc("Message recorded"), $TransObj ); +} + + +=head2 DryRun + +Builds a MIME object from the given C<UpdateSubject> and +C<UpdateContent>, then calls L</Comment> or L</Correspond> with +C<< DryRun => 1 >>, and returns the transaction so produced. + +=cut + +sub DryRun { + my $self = shift; + my %args = @_; + my $action; + if (($args{'UpdateType'} || $args{Action}) =~ /^respon(d|se)$/i ) { + $action = 'Correspond'; + } else { + $action = 'Comment'; + } + + my $Message = MIME::Entity->build( + Type => 'text/plain', + Subject => defined $args{UpdateSubject} ? Encode::encode_utf8( $args{UpdateSubject} ) : "", + Charset => 'UTF-8', + Data => $args{'UpdateContent'} || "", + ); + + my ( $Transaction, $Description, $Object ) = $self->$action( + CcMessageTo => $args{'UpdateCc'}, + BccMessageTo => $args{'UpdateBcc'}, + MIMEObj => $Message, + TimeTaken => $args{'UpdateTimeWorked'}, + DryRun => 1, + ); + unless ( $Transaction ) { + $RT::Logger->error("Couldn't fire '$action' action: $Description"); + } + + return $Object; +} + +=head2 DryRunCreate + +Prepares a MIME mesage with the given C<Subject>, C<Cc>, and +C<Content>, then calls L</Create> with C<< DryRun => 1 >> and returns +the resulting L<RT::Transaction>. + +=cut + +sub DryRunCreate { + my $self = shift; + my %args = @_; + my $Message = MIME::Entity->build( + Type => 'text/plain', + Subject => defined $args{Subject} ? Encode::encode_utf8( $args{'Subject'} ) : "", + (defined $args{'Cc'} ? + ( Cc => Encode::encode_utf8( $args{'Cc'} ) ) : ()), + Charset => 'UTF-8', + Data => $args{'Content'} || "", + ); + + my ( $Transaction, $Object, $Description ) = $self->Create( + Type => $args{'Type'} || 'ticket', + Queue => $args{'Queue'}, + Owner => $args{'Owner'}, + Requestor => $args{'Requestors'}, + Cc => $args{'Cc'}, + AdminCc => $args{'AdminCc'}, + InitialPriority => $args{'InitialPriority'}, + FinalPriority => $args{'FinalPriority'}, + TimeLeft => $args{'TimeLeft'}, + TimeEstimated => $args{'TimeEstimated'}, + TimeWorked => $args{'TimeWorked'}, + Subject => $args{'Subject'}, + Status => $args{'Status'}, + MIMEObj => $Message, + DryRun => 1, + ); + unless ( $Transaction ) { + $RT::Logger->error("Couldn't fire Create action: $Description"); + } + + return $Object; +} + + + +sub _Links { + my $self = shift; + + #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic --- + #tobias meant by $f + my $field = shift; + my $type = shift || ""; + + my $cache_key = "$field$type"; + return $self->{ $cache_key } if $self->{ $cache_key }; + + my $links = $self->{ $cache_key } + = RT::Links->new( $self->CurrentUser ); + unless ( $self->CurrentUserHasRight('ShowTicket') ) { + $links->Limit( FIELD => 'id', VALUE => 0, SUBCLAUSE => 'acl' ); + return $links; + } + + # Maybe this ticket is a merge ticket + #my $limit_on = 'Local'. $field; + # at least to myself + $links->Limit( + FIELD => $field, #$limit_on, + OPERATOR => 'MATCHES', + VALUE => 'fsck.com-rt://%/ticket/'. $self->id, + ENTRYAGGREGATOR => 'OR', + ); + $links->Limit( + FIELD => $field, #$limit_on, + OPERATOR => 'MATCHES', + VALUE => 'fsck.com-rt://%/ticket/'. $_, + ENTRYAGGREGATOR => 'OR', + ) foreach $self->Merged; + $links->Limit( + FIELD => 'Type', + VALUE => $type, + ) if $type; + + return $links; +} + + + +=head2 DeleteLink + +Delete a link. takes a paramhash of Base, Target, Type, Silent, +SilentBase and SilentTarget. Either Base or Target must be null. +The null value will be replaced with this ticket's id. + +If Silent is true then no transaction would be recorded, in other +case you can control creation of transactions on both base and +target with SilentBase and SilentTarget respectively. By default +both transactions are created. + +=cut + +sub DeleteLink { + my $self = shift; + my %args = ( + Base => undef, + Target => undef, + Type => undef, + Silent => undef, + SilentBase => undef, + SilentTarget => undef, + @_ + ); + + unless ( $args{'Target'} || $args{'Base'} ) { + $RT::Logger->error("Base or Target must be specified"); + return ( 0, $self->loc('Either base or target must be specified') ); + } + + #check acls + my $right = 0; + $right++ if $self->CurrentUserHasRight('ModifyTicket'); + if ( !$right && RT->Config->Get( 'StrictLinkACL' ) ) { + return ( 0, $self->loc("Permission Denied") ); + } + + # If the other URI is an RT::Ticket, we want to make sure the user + # can modify it too... + my ($status, $msg, $other_ticket) = $self->__GetTicketFromURI( URI => $args{'Target'} || $args{'Base'} ); + return (0, $msg) unless $status; + if ( !$other_ticket || $other_ticket->CurrentUserHasRight('ModifyTicket') ) { + $right++; + } + if ( ( !RT->Config->Get( 'StrictLinkACL' ) && $right == 0 ) || + ( RT->Config->Get( 'StrictLinkACL' ) && $right < 2 ) ) + { + return ( 0, $self->loc("Permission Denied") ); + } + + my ($val, $Msg) = $self->SUPER::_DeleteLink(%args); + return ( 0, $Msg ) unless $val; + + return ( $val, $Msg ) if $args{'Silent'}; + + my ($direction, $remote_link); + + if ( $args{'Base'} ) { + $remote_link = $args{'Base'}; + $direction = 'Target'; + } + elsif ( $args{'Target'} ) { + $remote_link = $args{'Target'}; + $direction = 'Base'; + } + + my $remote_uri = RT::URI->new( $self->CurrentUser ); + $remote_uri->FromURI( $remote_link ); + + unless ( $args{ 'Silent'. $direction } ) { + my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction( + Type => 'DeleteLink', + Field => $LINKDIRMAP{$args{'Type'}}->{$direction}, + OldValue => $remote_uri->URI || $remote_link, + TimeTaken => 0 + ); + $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans; + } + + if ( !$args{ 'Silent'. ( $direction eq 'Target'? 'Base': 'Target' ) } && $remote_uri->IsLocal ) { + my $OtherObj = $remote_uri->Object; + my ( $val, $Msg ) = $OtherObj->_NewTransaction( + Type => 'DeleteLink', + Field => $direction eq 'Target' ? $LINKDIRMAP{$args{'Type'}}->{Base} + : $LINKDIRMAP{$args{'Type'}}->{Target}, + OldValue => $self->URI, + ActivateScrips => !RT->Config->Get('LinkTransactionsRun1Scrip'), + TimeTaken => 0, + ); + $RT::Logger->error("Couldn't create transaction: $Msg") unless $val; + } + + return ( $val, $Msg ); +} + + + +=head2 AddLink + +Takes a paramhash of Type and one of Base or Target. Adds that link to this ticket. + +If Silent is true then no transaction would be recorded, in other +case you can control creation of transactions on both base and +target with SilentBase and SilentTarget respectively. By default +both transactions are created. + +=cut + +sub AddLink { + my $self = shift; + my %args = ( Target => '', + Base => '', + Type => '', + Silent => undef, + SilentBase => undef, + SilentTarget => undef, + @_ ); + + unless ( $args{'Target'} || $args{'Base'} ) { + $RT::Logger->error("Base or Target must be specified"); + return ( 0, $self->loc('Either base or target must be specified') ); + } + + my $right = 0; + $right++ if $self->CurrentUserHasRight('ModifyTicket'); + if ( !$right && RT->Config->Get( 'StrictLinkACL' ) ) { + return ( 0, $self->loc("Permission Denied") ); + } + + # If the other URI is an RT::Ticket, we want to make sure the user + # can modify it too... + my ($status, $msg, $other_ticket) = $self->__GetTicketFromURI( URI => $args{'Target'} || $args{'Base'} ); + return (0, $msg) unless $status; + if ( !$other_ticket || $other_ticket->CurrentUserHasRight('ModifyTicket') ) { + $right++; + } + if ( ( !RT->Config->Get( 'StrictLinkACL' ) && $right == 0 ) || + ( RT->Config->Get( 'StrictLinkACL' ) && $right < 2 ) ) + { + return ( 0, $self->loc("Permission Denied") ); + } + + return ( 0, "Can't link to a deleted ticket" ) + if $other_ticket && lc $other_ticket->Status eq 'deleted'; + + return $self->_AddLink(%args); +} + +sub __GetTicketFromURI { + my $self = shift; + my %args = ( URI => '', @_ ); + + # If the other URI is an RT::Ticket, we want to make sure the user + # can modify it too... + my $uri_obj = RT::URI->new( $self->CurrentUser ); + unless ($uri_obj->FromURI( $args{'URI'} )) { + my $msg = $self->loc( "Couldn't resolve '[_1]' into a URI.", $args{'URI'} ); + $RT::Logger->warning( $msg ); + return( 0, $msg ); + } + my $obj = $uri_obj->Resolver->Object; + unless ( UNIVERSAL::isa($obj, 'RT::Ticket') && $obj->id ) { + return (1, 'Found not a ticket', undef); + } + return (1, 'Found ticket', $obj); +} + +=head2 _AddLink + +Private non-acled variant of AddLink so that links can be added during create. + +=cut + +sub _AddLink { + my $self = shift; + my %args = ( Target => '', + Base => '', + Type => '', + Silent => undef, + SilentBase => undef, + SilentTarget => undef, + @_ ); + + my ($val, $msg, $exist) = $self->SUPER::_AddLink(%args); + return ($val, $msg) if !$val || $exist; + return ($val, $msg) if $args{'Silent'}; + + my ($direction, $remote_link); + if ( $args{'Target'} ) { + $remote_link = $args{'Target'}; + $direction = 'Base'; + } elsif ( $args{'Base'} ) { + $remote_link = $args{'Base'}; + $direction = 'Target'; + } + + my $remote_uri = RT::URI->new( $self->CurrentUser ); + $remote_uri->FromURI( $remote_link ); + + unless ( $args{ 'Silent'. $direction } ) { + my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction( + Type => 'AddLink', + Field => $LINKDIRMAP{$args{'Type'}}->{$direction}, + NewValue => $remote_uri->URI || $remote_link, + TimeTaken => 0 + ); + $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans; + } + + if ( !$args{ 'Silent'. ( $direction eq 'Target'? 'Base': 'Target' ) } && $remote_uri->IsLocal ) { + my $OtherObj = $remote_uri->Object; + my ( $val, $msg ) = $OtherObj->_NewTransaction( + Type => 'AddLink', + Field => $direction eq 'Target' ? $LINKDIRMAP{$args{'Type'}}->{Base} + : $LINKDIRMAP{$args{'Type'}}->{Target}, + NewValue => $self->URI, + ActivateScrips => !RT->Config->Get('LinkTransactionsRun1Scrip'), + TimeTaken => 0, + ); + $RT::Logger->error("Couldn't create transaction: $msg") unless $val; + } + + return ( $val, $msg ); +} + + + + +=head2 MergeInto + +MergeInto take the id of the ticket to merge this ticket into. + +=cut + +sub MergeInto { + my $self = shift; + my $ticket_id = shift; + + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + return ( 0, $self->loc("Permission Denied") ); + } + + # Load up the new ticket. + my $MergeInto = RT::Ticket->new($self->CurrentUser); + $MergeInto->Load($ticket_id); + + # make sure it exists. + unless ( $MergeInto->Id ) { + return ( 0, $self->loc("New ticket doesn't exist") ); + } + + # Make sure the current user can modify the new ticket. + unless ( $MergeInto->CurrentUserHasRight('ModifyTicket') ) { + return ( 0, $self->loc("Permission Denied") ); + } + + delete $MERGE_CACHE{'effective'}{ $self->id }; + delete @{ $MERGE_CACHE{'merged'} }{ + $ticket_id, $MergeInto->id, $self->id + }; + + $RT::Handle->BeginTransaction(); + + $self->_MergeInto( $MergeInto ); + + $RT::Handle->Commit(); + + return ( 1, $self->loc("Merge Successful") ); +} + +sub _MergeInto { + my $self = shift; + my $MergeInto = shift; + + + # We use EffectiveId here even though it duplicates information from + # the links table becasue of the massive performance hit we'd take + # by trying to do a separate database query for merge info everytime + # loaded a ticket. + + #update this ticket's effective id to the new ticket's id. + my ( $id_val, $id_msg ) = $self->__Set( + Field => 'EffectiveId', + Value => $MergeInto->Id() + ); + + unless ($id_val) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("Merge failed. Couldn't set EffectiveId") ); + } + + + my $force_status = $self->QueueObj->Lifecycle->DefaultOnMerge; + if ( $force_status && $force_status ne $self->__Value('Status') ) { + my ( $status_val, $status_msg ) + = $self->__Set( Field => 'Status', Value => $force_status ); + + unless ($status_val) { + $RT::Handle->Rollback(); + $RT::Logger->error( + "Couldn't set status to $force_status. RT's Database may be inconsistent." + ); + return ( 0, $self->loc("Merge failed. Couldn't set Status") ); + } + } + + # update all the links that point to that old ticket + my $old_links_to = RT::Links->new($self->CurrentUser); + $old_links_to->Limit(FIELD => 'Target', VALUE => $self->URI); + + my %old_seen; + while (my $link = $old_links_to->Next) { + if (exists $old_seen{$link->Base."-".$link->Type}) { + $link->Delete; + } + elsif ($link->Base eq $MergeInto->URI) { + $link->Delete; + } else { + # First, make sure the link doesn't already exist. then move it over. + my $tmp = RT::Link->new(RT->SystemUser); + $tmp->LoadByCols(Base => $link->Base, Type => $link->Type, LocalTarget => $MergeInto->id); + if ($tmp->id) { + $link->Delete; + } else { + $link->SetTarget($MergeInto->URI); + $link->SetLocalTarget($MergeInto->id); + } + $old_seen{$link->Base."-".$link->Type} =1; + } + + } + + my $old_links_from = RT::Links->new($self->CurrentUser); + $old_links_from->Limit(FIELD => 'Base', VALUE => $self->URI); + + while (my $link = $old_links_from->Next) { + if (exists $old_seen{$link->Type."-".$link->Target}) { + $link->Delete; + } + if ($link->Target eq $MergeInto->URI) { + $link->Delete; + } else { + # First, make sure the link doesn't already exist. then move it over. + my $tmp = RT::Link->new(RT->SystemUser); + $tmp->LoadByCols(Target => $link->Target, Type => $link->Type, LocalBase => $MergeInto->id); + if ($tmp->id) { + $link->Delete; + } else { + $link->SetBase($MergeInto->URI); + $link->SetLocalBase($MergeInto->id); + $old_seen{$link->Type."-".$link->Target} =1; + } + } + + } + + # Update time fields + foreach my $type (qw(TimeEstimated TimeWorked TimeLeft)) { + + my $mutator = "Set$type"; + $MergeInto->$mutator( + ( $MergeInto->$type() || 0 ) + ( $self->$type() || 0 ) ); + + } +#add all of this ticket's watchers to that ticket. + foreach my $watcher_type (qw(Requestors Cc AdminCc)) { + + my $people = $self->$watcher_type->MembersObj; + my $addwatcher_type = $watcher_type; + $addwatcher_type =~ s/s$//; + + while ( my $watcher = $people->Next ) { + + my ($val, $msg) = $MergeInto->_AddWatcher( + Type => $addwatcher_type, + Silent => 1, + PrincipalId => $watcher->MemberId + ); + unless ($val) { + $RT::Logger->debug($msg); + } + } + + } + + #find all of the tickets that were merged into this ticket. + my $old_mergees = RT::Tickets->new( $self->CurrentUser ); + $old_mergees->Limit( + FIELD => 'EffectiveId', + OPERATOR => '=', + VALUE => $self->Id + ); + + # update their EffectiveId fields to the new ticket's id + while ( my $ticket = $old_mergees->Next() ) { + my ( $val, $msg ) = $ticket->__Set( + Field => 'EffectiveId', + Value => $MergeInto->Id() + ); + } + + #make a new link: this ticket is merged into that other ticket. + $self->AddLink( Type => 'MergedInto', Target => $MergeInto->Id()); + + $MergeInto->_SetLastUpdated; +} + +=head2 Merged + +Returns list of tickets' ids that's been merged into this ticket. + +=cut + +sub Merged { + my $self = shift; + + my $id = $self->id; + return @{ $MERGE_CACHE{'merged'}{ $id } } + if $MERGE_CACHE{'merged'}{ $id }; + + my $mergees = RT::Tickets->new( $self->CurrentUser ); + $mergees->Limit( + FIELD => 'EffectiveId', + VALUE => $id, + ); + $mergees->Limit( + FIELD => 'id', + OPERATOR => '!=', + VALUE => $id, + ); + return @{ $MERGE_CACHE{'merged'}{ $id } ||= [] } + = map $_->id, @{ $mergees->ItemsArrayRef || [] }; +} + + + + + +=head2 OwnerObj + +Takes nothing and returns an RT::User object of +this ticket's owner + +=cut + +sub OwnerObj { + my $self = shift; + + #If this gets ACLed, we lose on a rights check in User.pm and + #get deep recursion. if we need ACLs here, we need + #an equiv without ACLs + + my $owner = RT::User->new( $self->CurrentUser ); + $owner->Load( $self->__Value('Owner') ); + + #Return the owner object + return ($owner); +} + + + +=head2 OwnerAsString + +Returns the owner's email address + +=cut + +sub OwnerAsString { + my $self = shift; + return ( $self->OwnerObj->EmailAddress ); + +} + + + +=head2 SetOwner + +Takes two arguments: + the Id or Name of the owner +and (optionally) the type of the SetOwner Transaction. It defaults +to 'Set'. 'Steal' is also a valid option. + + +=cut + +sub SetOwner { + my $self = shift; + my $NewOwner = shift; + my $Type = shift || "Set"; + + $RT::Handle->BeginTransaction(); + + $self->_SetLastUpdated(); # lock the ticket + $self->Load( $self->id ); # in case $self changed while waiting for lock + + my $OldOwnerObj = $self->OwnerObj; + + my $NewOwnerObj = RT::User->new( $self->CurrentUser ); + $NewOwnerObj->Load( $NewOwner ); + unless ( $NewOwnerObj->Id ) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("That user does not exist") ); + } + + + # must have ModifyTicket rights + # or TakeTicket/StealTicket and $NewOwner is self + # see if it's a take + if ( $OldOwnerObj->Id == RT->Nobody->Id ) { + unless ( $self->CurrentUserHasRight('ModifyTicket') + || $self->CurrentUserHasRight('TakeTicket') ) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("Permission Denied") ); + } + } + + # see if it's a steal + elsif ( $OldOwnerObj->Id != RT->Nobody->Id + && $OldOwnerObj->Id != $self->CurrentUser->id ) { + + unless ( $self->CurrentUserHasRight('ModifyTicket') + || $self->CurrentUserHasRight('StealTicket') ) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("Permission Denied") ); + } + } + else { + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("Permission Denied") ); + } + } + + # If we're not stealing and the ticket has an owner and it's not + # the current user + if ( $Type ne 'Steal' and $Type ne 'Force' + and $OldOwnerObj->Id != RT->Nobody->Id + and $OldOwnerObj->Id != $self->CurrentUser->Id ) + { + $RT::Handle->Rollback(); + return ( 0, $self->loc("You can only take tickets that are unowned") ) + if $NewOwnerObj->id == $self->CurrentUser->id; + return ( + 0, + $self->loc("You can only reassign tickets that you own or that are unowned" ) + ); + } + + #If we've specified a new owner and that user can't modify the ticket + elsif ( !$NewOwnerObj->HasRight( Right => 'OwnTicket', Object => $self ) ) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("That user may not own tickets in that queue") ); + } + + # If the ticket has an owner and it's the new owner, we don't need + # To do anything + elsif ( $NewOwnerObj->Id == $OldOwnerObj->Id ) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("That user already owns that ticket") ); + } + + # Delete the owner in the owner group, then add a new one + # TODO: is this safe? it's not how we really want the API to work + # for most things, but it's fast. + my ( $del_id, $del_msg ); + for my $owner (@{$self->OwnerGroup->MembersObj->ItemsArrayRef}) { + ($del_id, $del_msg) = $owner->Delete(); + last unless ($del_id); + } + + unless ($del_id) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("Could not change owner: [_1]", $del_msg) ); + } + + my ( $add_id, $add_msg ) = $self->OwnerGroup->_AddMember( + PrincipalId => $NewOwnerObj->PrincipalId, + InsideTransaction => 1 ); + unless ($add_id) { + $RT::Handle->Rollback(); + return ( 0, $self->loc("Could not change owner: [_1]", $add_msg ) ); + } + + # We call set twice with slightly different arguments, so + # as to not have an SQL transaction span two RT transactions + + my ( $val, $msg ) = $self->_Set( + Field => 'Owner', + RecordTransaction => 0, + Value => $NewOwnerObj->Id, + TimeTaken => 0, + TransactionType => 'Set', + CheckACL => 0, # don't check acl + ); + + unless ($val) { + $RT::Handle->Rollback; + return ( 0, $self->loc("Could not change owner: [_1]", $msg) ); + } + + ($val, $msg) = $self->_NewTransaction( + Type => 'Set', + Field => 'Owner', + NewValue => $NewOwnerObj->Id, + OldValue => $OldOwnerObj->Id, + TimeTaken => 0, + ); + + if ( $val ) { + $msg = $self->loc( "Owner changed from [_1] to [_2]", + $OldOwnerObj->Name, $NewOwnerObj->Name ); + } + else { + $RT::Handle->Rollback(); + return ( 0, $msg ); + } + + $RT::Handle->Commit(); + + return ( $val, $msg ); +} + + + +=head2 Take + +A convenince method to set the ticket's owner to the current user + +=cut + +sub Take { + my $self = shift; + return ( $self->SetOwner( $self->CurrentUser->Id, 'Take' ) ); +} + + + +=head2 Untake + +Convenience method to set the owner to 'nobody' if the current user is the owner. + +=cut + +sub Untake { + my $self = shift; + return ( $self->SetOwner( RT->Nobody->UserObj->Id, 'Untake' ) ); +} + + + +=head2 Steal + +A convenience method to change the owner of the current ticket to the +current user. Even if it's owned by another user. + +=cut + +sub Steal { + my $self = shift; + + if ( $self->IsOwner( $self->CurrentUser ) ) { + return ( 0, $self->loc("You already own this ticket") ); + } + else { + return ( $self->SetOwner( $self->CurrentUser->Id, 'Steal' ) ); + + } + +} + + + + + +=head2 ValidateStatus STATUS + +Takes a string. Returns true if that status is a valid status for this ticket. +Returns false otherwise. + +=cut + +sub ValidateStatus { + my $self = shift; + my $status = shift; + + #Make sure the status passed in is valid + return 1 if $self->QueueObj->IsValidStatus($status); + + my $i = 0; + while ( my $caller = (caller($i++))[3] ) { + return 1 if $caller eq 'RT::Ticket::SetQueue'; + } + + return 0; +} + +sub Status { + my $self = shift; + my $value = $self->_Value( 'Status' ); + return $value unless $self->QueueObj; + return $self->QueueObj->Lifecycle->CanonicalCase( $value ); +} + +=head2 SetStatus STATUS + +Set this ticket's status. STATUS can be one of: new, open, stalled, resolved, rejected or deleted. + +Alternatively, you can pass in a list of named parameters (Status => STATUS, Force => FORCE, SetStarted => SETSTARTED ). +If FORCE is true, ignore unresolved dependencies and force a status change. +if SETSTARTED is true( it's the default value), set Started to current datetime if Started +is not set and the status is changed from initial to not initial. + +=cut + +sub SetStatus { + my $self = shift; + my %args; + if (@_ == 1) { + $args{Status} = shift; + } + else { + %args = (@_); + } + + # this only allows us to SetStarted, not we must SetStarted. + # this option was added for rtir initially + $args{SetStarted} = 1 unless exists $args{SetStarted}; + + + my $lifecycle = $self->QueueObj->Lifecycle; + + my $new = lc $args{'Status'}; + unless ( $lifecycle->IsValid( $new ) ) { + return (0, $self->loc("Status '[_1]' isn't a valid status for tickets in this queue.", $self->loc($new))); + } + + my $old = $self->__Value('Status'); + unless ( $lifecycle->IsTransition( $old => $new ) ) { + return (0, $self->loc("You can't change status from '[_1]' to '[_2]'.", $self->loc($old), $self->loc($new))); + } + + my $check_right = $lifecycle->CheckRight( $old => $new ); + unless ( $self->CurrentUserHasRight( $check_right ) ) { + return ( 0, $self->loc('Permission Denied') ); + } + + if ( !$args{Force} && $lifecycle->IsInactive( $new ) && $self->HasUnresolvedDependencies) { + return (0, $self->loc('That ticket has unresolved dependencies')); + } + + my $now = RT::Date->new( $self->CurrentUser ); + $now->SetToNow(); + + my $raw_started = RT::Date->new(RT->SystemUser); + $raw_started->Set(Format => 'ISO', Value => $self->__Value('Started')); + + #If we're changing the status from new, record that we've started + if ( $args{SetStarted} && $lifecycle->IsInitial($old) && !$lifecycle->IsInitial($new) && !$raw_started->Unix) { + #Set the Started time to "now" + $self->_Set( + Field => 'Started', + Value => $now->ISO, + RecordTransaction => 0 + ); + } + + #When we close a ticket, set the 'Resolved' attribute to now. + # It's misnamed, but that's just historical. + if ( $lifecycle->IsInactive($new) ) { + $self->_Set( + Field => 'Resolved', + Value => $now->ISO, + RecordTransaction => 0, + ); + } + + #Actually update the status + my ($val, $msg)= $self->_Set( + Field => 'Status', + Value => $new, + TimeTaken => 0, + CheckACL => 0, + TransactionType => 'Status', + ); + return ($val, $msg); +} + + + +=head2 Delete + +Takes no arguments. Marks this ticket for garbage collection + +=cut + +sub Delete { + my $self = shift; + unless ( $self->QueueObj->Lifecycle->IsValid('deleted') ) { + return (0, $self->loc('Delete operation is disabled by lifecycle configuration') ); #loc + } + return ( $self->SetStatus('deleted') ); +} + + +=head2 SetTold ISO [TIMETAKEN] + +Updates the told and records a transaction + +=cut + +sub SetTold { + my $self = shift; + my $told; + $told = shift if (@_); + my $timetaken = shift || 0; + + unless ( $self->CurrentUserHasRight('ModifyTicket') ) { + return ( 0, $self->loc("Permission Denied") ); + } + + my $datetold = RT::Date->new( $self->CurrentUser ); + if ($told) { + $datetold->Set( Format => 'iso', + Value => $told ); + } + else { + $datetold->SetToNow(); + } + + return ( $self->_Set( Field => 'Told', + Value => $datetold->ISO, + TimeTaken => $timetaken, + TransactionType => 'Told' ) ); +} + +=head2 _SetTold + +Updates the told without a transaction or acl check. Useful when we're sending replies. + +=cut + +sub _SetTold { + my $self = shift; + + my $now = RT::Date->new( $self->CurrentUser ); + $now->SetToNow(); + + #use __Set to get no ACLs ;) + return ( $self->__Set( Field => 'Told', + Value => $now->ISO ) ); +} + +=head2 SeenUpTo + + +=cut + +sub SeenUpTo { + my $self = shift; + my $uid = $self->CurrentUser->id; + my $attr = $self->FirstAttribute( "User-". $uid ."-SeenUpTo" ); + return if $attr && $attr->Content gt $self->LastUpdated; + + my $txns = $self->Transactions; + $txns->Limit( FIELD => 'Type', VALUE => 'Comment' ); + $txns->Limit( FIELD => 'Type', VALUE => 'Correspond' ); + $txns->Limit( FIELD => 'Creator', OPERATOR => '!=', VALUE => $uid ); + $txns->Limit( + FIELD => 'Created', + OPERATOR => '>', + VALUE => $attr->Content + ) if $attr; + $txns->RowsPerPage(1); + return $txns->First; +} + +=head2 RanTransactionBatch + +Acts as a guard around running TransactionBatch scrips. + +Should be false until you enter the code that runs TransactionBatch scrips + +Accepts an optional argument to indicate that TransactionBatch Scrips should no longer be run on this object. + +=cut + +sub RanTransactionBatch { + my $self = shift; + my $val = shift; + + if ( defined $val ) { + return $self->{_RanTransactionBatch} = $val; + } else { + return $self->{_RanTransactionBatch}; + } + +} + + +=head2 TransactionBatch + +Returns an array reference of all transactions created on this ticket during +this ticket object's lifetime or since last application of a batch, or undef +if there were none. + +Only works when the C<UseTransactionBatch> config option is set to true. + +=cut + +sub TransactionBatch { + my $self = shift; + return $self->{_TransactionBatch}; +} + +=head2 ApplyTransactionBatch + +Applies scrips on the current batch of transactions and shinks it. Usually +batch is applied when object is destroyed, but in some cases it's too late. + +=cut + +sub ApplyTransactionBatch { + my $self = shift; + + my $batch = $self->TransactionBatch; + return unless $batch && @$batch; + + $self->_ApplyTransactionBatch; + + $self->{_TransactionBatch} = []; +} + +sub _ApplyTransactionBatch { + my $self = shift; + + return if $self->RanTransactionBatch; + $self->RanTransactionBatch(1); + + my $still_exists = RT::Ticket->new( RT->SystemUser ); + $still_exists->Load( $self->Id ); + if (not $still_exists->Id) { + # The ticket has been removed from the database, but we still + # have pending TransactionBatch txns for it. Unfortunately, + # because it isn't in the DB anymore, attempting to run scrips + # on it may produce unpredictable results; simply drop the + # batched transactions. + $RT::Logger->warning("TransactionBatch was fired on a ticket that no longer exists; unable to run scrips! Call ->ApplyTransactionBatch before shredding the ticket, for consistent results."); + return; + } + + my $batch = $self->TransactionBatch; + + my %seen; + my $types = join ',', grep !$seen{$_}++, grep defined, map $_->__Value('Type'), grep defined, @{$batch}; + + require RT::Scrips; + RT::Scrips->new(RT->SystemUser)->Apply( + Stage => 'TransactionBatch', + TicketObj => $self, + TransactionObj => $batch->[0], + Type => $types, + ); + + # Entry point of the rule system + my $rules = RT::Ruleset->FindAllRules( + Stage => 'TransactionBatch', + TicketObj => $self, + TransactionObj => $batch->[0], + Type => $types, + ); + RT::Ruleset->CommitRules($rules); +} + +sub DESTROY { + my $self = shift; + + # DESTROY methods need to localize $@, or it may unset it. This + # causes $m->abort to not bubble all of the way up. See perlbug + # http://rt.perl.org/rt3/Ticket/Display.html?id=17650 + local $@; + + # The following line eliminates reentrancy. + # It protects against the fact that perl doesn't deal gracefully + # when an object's refcount is changed in its destructor. + return if $self->{_Destroyed}++; + + if (in_global_destruction()) { + unless ($ENV{'HARNESS_ACTIVE'}) { + warn "Too late to safely run transaction-batch scrips!" + ." This is typically caused by using ticket objects" + ." at the top-level of a script which uses the RT API." + ." Be sure to explicitly undef such ticket objects," + ." or put them inside of a lexical scope."; + } + return; + } + + return $self->ApplyTransactionBatch; +} + + + + +sub _OverlayAccessible { + { + EffectiveId => { 'read' => 1, 'write' => 1, 'public' => 1 }, + Queue => { 'read' => 1, 'write' => 1 }, + Requestors => { 'read' => 1, 'write' => 1 }, + Owner => { 'read' => 1, 'write' => 1 }, + Subject => { 'read' => 1, 'write' => 1 }, + InitialPriority => { 'read' => 1, 'write' => 1 }, + FinalPriority => { 'read' => 1, 'write' => 1 }, + Priority => { 'read' => 1, 'write' => 1 }, + Status => { 'read' => 1, 'write' => 1 }, + TimeEstimated => { 'read' => 1, 'write' => 1 }, + TimeWorked => { 'read' => 1, 'write' => 1 }, + TimeLeft => { 'read' => 1, 'write' => 1 }, + Told => { 'read' => 1, 'write' => 1 }, + Resolved => { 'read' => 1 }, + Type => { 'read' => 1 }, + Starts => { 'read' => 1, 'write' => 1 }, + Started => { 'read' => 1, 'write' => 1 }, + Due => { 'read' => 1, 'write' => 1 }, + Creator => { 'read' => 1, 'auto' => 1 }, + Created => { 'read' => 1, 'auto' => 1 }, + LastUpdatedBy => { 'read' => 1, 'auto' => 1 }, + LastUpdated => { 'read' => 1, 'auto' => 1 } + }; + +} + + + +sub _Set { + my $self = shift; + + my %args = ( Field => undef, + Value => undef, + TimeTaken => 0, + RecordTransaction => 1, + UpdateTicket => 1, + CheckACL => 1, + TransactionType => 'Set', + @_ ); + + if ($args{'CheckACL'}) { + unless ( $self->CurrentUserHasRight('ModifyTicket')) { + return ( 0, $self->loc("Permission Denied")); + } + } + + unless ($args{'UpdateTicket'} || $args{'RecordTransaction'}) { + $RT::Logger->error("Ticket->_Set called without a mandate to record an update or update the ticket"); + return(0, $self->loc("Internal Error")); + } + + #if the user is trying to modify the record + + #Take care of the old value we really don't want to get in an ACL loop. + # so ask the super::_Value + my $Old = $self->SUPER::_Value("$args{'Field'}"); + + my ($ret, $msg); + if ( $args{'UpdateTicket'} ) { + + #Set the new value + ( $ret, $msg ) = $self->SUPER::_Set( Field => $args{'Field'}, + Value => $args{'Value'} ); + + #If we can't actually set the field to the value, don't record + # a transaction. instead, get out of here. + return ( 0, $msg ) unless $ret; + } + + if ( $args{'RecordTransaction'} == 1 ) { + + my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction( + Type => $args{'TransactionType'}, + Field => $args{'Field'}, + NewValue => $args{'Value'}, + OldValue => $Old, + TimeTaken => $args{'TimeTaken'}, + ); + # Ensure that we can read the transaction, even if the change + # just made the ticket unreadable to us + $TransObj->{ _object_is_readable } = 1; + return ( $Trans, scalar $TransObj->BriefDescription ); + } + else { + return ( $ret, $msg ); + } +} + + + +=head2 _Value + +Takes the name of a table column. +Returns its value as a string, if the user passes an ACL check + +=cut + +sub _Value { + + my $self = shift; + my $field = shift; + + #if the field is public, return it. + if ( $self->_Accessible( $field, 'public' ) ) { + + #$RT::Logger->debug("Skipping ACL check for $field"); + return ( $self->SUPER::_Value($field) ); + + } + + #If the current user doesn't have ACLs, don't let em at it. + + unless ( $self->CurrentUserHasRight('ShowTicket') ) { + return (undef); + } + return ( $self->SUPER::_Value($field) ); + +} + + + +=head2 _UpdateTimeTaken + +This routine will increment the timeworked counter. it should +only be called from _NewTransaction + +=cut + +sub _UpdateTimeTaken { + my $self = shift; + my $Minutes = shift; + my ($Total); + + $Total = $self->SUPER::_Value("TimeWorked"); + $Total = ( $Total || 0 ) + ( $Minutes || 0 ); + $self->SUPER::_Set( + Field => "TimeWorked", + Value => $Total + ); + + return ($Total); +} + + + + + +=head2 CurrentUserHasRight + + Takes the textual name of a Ticket scoped right (from RT::ACE) and returns +1 if the user has that right. It returns 0 if the user doesn't have that right. + +=cut + +sub CurrentUserHasRight { + my $self = shift; + my $right = shift; + + return $self->CurrentUser->PrincipalObj->HasRight( + Object => $self, + Right => $right, + ) +} + + +=head2 CurrentUserCanSee + +Returns true if the current user can see the ticket, using ShowTicket + +=cut + +sub CurrentUserCanSee { + my $self = shift; + return $self->CurrentUserHasRight('ShowTicket'); +} + +=head2 HasRight + + Takes a paramhash with the attributes 'Right' and 'Principal' + 'Right' is a ticket-scoped textual right from RT::ACE + 'Principal' is an RT::User object + + Returns 1 if the principal has the right. Returns undef if not. + +=cut + +sub HasRight { + my $self = shift; + my %args = ( + Right => undef, + Principal => undef, + @_ + ); + + unless ( ( defined $args{'Principal'} ) and ( ref( $args{'Principal'} ) ) ) + { + Carp::cluck("Principal attrib undefined for Ticket::HasRight"); + $RT::Logger->crit("Principal attrib undefined for Ticket::HasRight"); + return(undef); + } + + return ( + $args{'Principal'}->HasRight( + Object => $self, + Right => $args{'Right'} + ) + ); +} + + + +=head2 Reminders + +Return the Reminders object for this ticket. (It's an RT::Reminders object.) +It isn't acutally a searchbuilder collection itself. + +=cut + +sub Reminders { + my $self = shift; + + unless ($self->{'__reminders'}) { + $self->{'__reminders'} = RT::Reminders->new($self->CurrentUser); + $self->{'__reminders'}->Ticket($self->id); + } + return $self->{'__reminders'}; + +} + + + + +=head2 Transactions + + Returns an RT::Transactions object of all transactions on this ticket + +=cut + +sub Transactions { + my $self = shift; + + my $transactions = RT::Transactions->new( $self->CurrentUser ); + + #If the user has no rights, return an empty object + if ( $self->CurrentUserHasRight('ShowTicket') ) { + $transactions->LimitToTicket($self->id); + + # if the user may not see comments do not return them + unless ( $self->CurrentUserHasRight('ShowTicketComments') ) { + $transactions->Limit( + SUBCLAUSE => 'acl', + FIELD => 'Type', + OPERATOR => '!=', + VALUE => "Comment" + ); + $transactions->Limit( + SUBCLAUSE => 'acl', + FIELD => 'Type', + OPERATOR => '!=', + VALUE => "CommentEmailRecord", + ENTRYAGGREGATOR => 'AND' + ); + + } + } else { + $transactions->Limit( + SUBCLAUSE => 'acl', + FIELD => 'id', + VALUE => 0, + ENTRYAGGREGATOR => 'AND' + ); + } + + return ($transactions); +} + + + + +=head2 TransactionCustomFields + + Returns the custom fields that transactions on tickets will have. + +=cut + +sub TransactionCustomFields { + my $self = shift; + my $cfs = $self->QueueObj->TicketTransactionCustomFields; + $cfs->SetContextObject( $self ); + return $cfs; +} + + +=head2 LoadCustomFieldByIdentifier + +Finds and returns the custom field of the given name for the ticket, +overriding L<RT::Record/LoadCustomFieldByIdentifier> to look for +queue-specific CFs before global ones. + +=cut + +sub LoadCustomFieldByIdentifier { + my $self = shift; + my $field = shift; + + return $self->SUPER::LoadCustomFieldByIdentifier($field) + if ref $field or $field =~ /^\d+$/; + + my $cf = RT::CustomField->new( $self->CurrentUser ); + $cf->SetContextObject( $self ); + $cf->LoadByNameAndQueue( Name => $field, Queue => $self->Queue ); + $cf->LoadByNameAndQueue( Name => $field, Queue => 0 ) unless $cf->id; + return $cf; +} + + +=head2 CustomFieldLookupType + +Returns the RT::Ticket lookup type, which can be passed to +RT::CustomField->Create() via the 'LookupType' hash key. + +=cut + + +sub CustomFieldLookupType { + "RT::Queue-RT::Ticket"; +} + +=head2 ACLEquivalenceObjects + +This method returns a list of objects for which a user's rights also apply +to this ticket. Generally, this is only the ticket's queue, but some RT +extensions may make other objects available too. + +This method is called from L<RT::Principal/HasRight>. + +=cut + +sub ACLEquivalenceObjects { + my $self = shift; + return $self->QueueObj; + +} + + +1; + +=head1 AUTHOR + +Jesse Vincent, jesse@bestpractical.com + +=head1 SEE ALSO + +RT + +=cut + + +use RT::Queue; +use base 'RT::Record'; + +sub Table {'Tickets'} + + + + + + +=head2 id + +Returns the current value of id. +(In the database, id is stored as int(11).) + + +=cut + + +=head2 EffectiveId + +Returns the current value of EffectiveId. +(In the database, EffectiveId is stored as int(11).) + + + +=head2 SetEffectiveId VALUE + + +Set EffectiveId to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, EffectiveId will be stored as a int(11).) + + +=cut + + +=head2 Queue + +Returns the current value of Queue. +(In the database, Queue is stored as int(11).) + + + +=head2 SetQueue VALUE + + +Set Queue to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Queue will be stored as a int(11).) + + +=cut + + +=head2 Type + +Returns the current value of Type. +(In the database, Type is stored as varchar(16).) + + + +=head2 SetType VALUE + + +Set Type to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Type will be stored as a varchar(16).) + + +=cut + + +=head2 IssueStatement + +Returns the current value of IssueStatement. +(In the database, IssueStatement is stored as int(11).) + + + +=head2 SetIssueStatement VALUE + + +Set IssueStatement to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, IssueStatement will be stored as a int(11).) + + +=cut + + +=head2 Resolution + +Returns the current value of Resolution. +(In the database, Resolution is stored as int(11).) + + + +=head2 SetResolution VALUE + + +Set Resolution to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Resolution will be stored as a int(11).) + + +=cut + + +=head2 Owner + +Returns the current value of Owner. +(In the database, Owner is stored as int(11).) + + + +=head2 SetOwner VALUE + + +Set Owner to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Owner will be stored as a int(11).) + + +=cut + + +=head2 Subject + +Returns the current value of Subject. +(In the database, Subject is stored as varchar(200).) + + + +=head2 SetSubject VALUE + + +Set Subject to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Subject will be stored as a varchar(200).) + + +=cut + + +=head2 InitialPriority + +Returns the current value of InitialPriority. +(In the database, InitialPriority is stored as int(11).) + + + +=head2 SetInitialPriority VALUE + + +Set InitialPriority to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, InitialPriority will be stored as a int(11).) + + +=cut + + +=head2 FinalPriority + +Returns the current value of FinalPriority. +(In the database, FinalPriority is stored as int(11).) + + + +=head2 SetFinalPriority VALUE + + +Set FinalPriority to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, FinalPriority will be stored as a int(11).) + + +=cut + + +=head2 Priority + +Returns the current value of Priority. +(In the database, Priority is stored as int(11).) + + + +=head2 SetPriority VALUE + + +Set Priority to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Priority will be stored as a int(11).) + + +=cut + + +=head2 TimeEstimated + +Returns the current value of TimeEstimated. +(In the database, TimeEstimated is stored as int(11).) + + + +=head2 SetTimeEstimated VALUE + + +Set TimeEstimated to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, TimeEstimated will be stored as a int(11).) + + +=cut + + +=head2 TimeWorked + +Returns the current value of TimeWorked. +(In the database, TimeWorked is stored as int(11).) + + + +=head2 SetTimeWorked VALUE + + +Set TimeWorked to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, TimeWorked will be stored as a int(11).) + + +=cut + + +=head2 Status + +Returns the current value of Status. +(In the database, Status is stored as varchar(64).) + + + +=head2 SetStatus VALUE + + +Set Status to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Status will be stored as a varchar(64).) + + +=cut + + +=head2 TimeLeft + +Returns the current value of TimeLeft. +(In the database, TimeLeft is stored as int(11).) + + + +=head2 SetTimeLeft VALUE + + +Set TimeLeft to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, TimeLeft will be stored as a int(11).) + + +=cut + + +=head2 Told + +Returns the current value of Told. +(In the database, Told is stored as datetime.) + + + +=head2 SetTold VALUE + + +Set Told to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Told will be stored as a datetime.) + + +=cut + + +=head2 Starts + +Returns the current value of Starts. +(In the database, Starts is stored as datetime.) + + + +=head2 SetStarts VALUE + + +Set Starts to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Starts will be stored as a datetime.) + + +=cut + + +=head2 Started + +Returns the current value of Started. +(In the database, Started is stored as datetime.) + + + +=head2 SetStarted VALUE + + +Set Started to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Started will be stored as a datetime.) + + +=cut + + +=head2 Due + +Returns the current value of Due. +(In the database, Due is stored as datetime.) + + + +=head2 SetDue VALUE + + +Set Due to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Due will be stored as a datetime.) + + +=cut + + +=head2 Resolved + +Returns the current value of Resolved. +(In the database, Resolved is stored as datetime.) + + + +=head2 SetResolved VALUE + + +Set Resolved to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Resolved will be stored as a datetime.) + + +=cut + + +=head2 LastUpdatedBy + +Returns the current value of LastUpdatedBy. +(In the database, LastUpdatedBy is stored as int(11).) + + +=cut + + +=head2 LastUpdated + +Returns the current value of LastUpdated. +(In the database, LastUpdated is stored as datetime.) + + +=cut + + +=head2 Creator + +Returns the current value of Creator. +(In the database, Creator is stored as int(11).) + + +=cut + + +=head2 Created + +Returns the current value of Created. +(In the database, Created is stored as datetime.) + + +=cut + + +=head2 Disabled + +Returns the current value of Disabled. +(In the database, Disabled is stored as smallint(6).) + + + +=head2 SetDisabled VALUE + + +Set Disabled to VALUE. +Returns (1, 'Status message') on success and (0, 'Error Message') on failure. +(In the database, Disabled will be stored as a smallint(6).) + + +=cut + + + +sub _CoreAccessible { + { + + id => + {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''}, + EffectiveId => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Queue => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Type => + {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''}, + IssueStatement => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Resolution => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Owner => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Subject => + {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => '[no subject]'}, + InitialPriority => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + FinalPriority => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Priority => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + TimeEstimated => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + TimeWorked => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Status => + {read => 1, write => 1, sql_type => 12, length => 64, is_blob => 0, is_numeric => 0, type => 'varchar(64)', default => ''}, + TimeLeft => + {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Told => + {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + Starts => + {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + Started => + {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + Due => + {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + Resolved => + {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + LastUpdatedBy => + {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + LastUpdated => + {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + Creator => + {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'}, + Created => + {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''}, + Disabled => + {read => 1, write => 1, sql_type => 5, length => 6, is_blob => 0, is_numeric => 1, type => 'smallint(6)', default => '0'}, + + } +}; + +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/Tickets.pm b/rt/lib/RT/Tickets.pm index cd5649dd9..4d091ce7a 100755 --- a/rt/lib/RT/Tickets.pm +++ b/rt/lib/RT/Tickets.pm @@ -1749,7 +1749,7 @@ sub _CustomFieldLimit { $self->_CloseParen; } elsif ( $op eq '=' || $op eq '!=' || $op eq '<>' ) { - if ( length( Encode::encode_utf8($value) ) < 256 ) { + if ( length( Encode::encode( "UTF-8", $value) ) < 256 ) { $self->_SQLLimit( ALIAS => $ObjectCFs, FIELD => 'Content', diff --git a/rt/lib/RT/Tickets.pm.orig b/rt/lib/RT/Tickets.pm.orig new file mode 100755 index 000000000..cd5649dd9 --- /dev/null +++ b/rt/lib/RT/Tickets.pm.orig @@ -0,0 +1,3892 @@ +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC +# <sales@bestpractical.com> +# +# (Except where explicitly superseded by other copyright notices) +# +# +# LICENSE: +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 or visit their web page on the internet at +# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. +# +# +# CONTRIBUTION SUBMISSION POLICY: +# +# (The following paragraph is not intended to limit the rights granted +# to you to modify and distribute this software under the terms of +# the GNU General Public License and is only of importance to you if +# you choose to contribute your changes and enhancements to the +# community by submitting them to Best Practical Solutions, LLC.) +# +# By intentionally submitting any modifications, corrections or +# derivatives to this work, or any other work intended for use with +# Request Tracker, to Best Practical Solutions, LLC, you confirm that +# you are the copyright holder for those contributions and you grant +# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, +# royalty-free, perpetual, license to use, copy, create derivative +# works based on those contributions, and sublicense and distribute +# those contributions and any derivatives thereof. +# +# END BPS TAGGED BLOCK }}} + +# Major Changes: + +# - Decimated ProcessRestrictions and broke it into multiple +# functions joined by a LUT +# - Semi-Generic SQL stuff moved to another file + +# Known Issues: FIXME! + +# - ClearRestrictions and Reinitialization is messy and unclear. The +# only good way to do it is to create a new RT::Tickets object. + +=head1 NAME + + RT::Tickets - A collection of Ticket objects + + +=head1 SYNOPSIS + + use RT::Tickets; + my $tickets = RT::Tickets->new($CurrentUser); + +=head1 DESCRIPTION + + A collection of RT::Tickets. + +=head1 METHODS + + +=cut + +package RT::Tickets; + +use strict; +use warnings; + + +use RT::Ticket; + +use base 'RT::SearchBuilder'; + +sub Table { 'Tickets'} + +use RT::CustomFields; +use DBIx::SearchBuilder::Unique; + +# Configuration Tables: + +# FIELD_METADATA is a mapping of searchable Field name, to Type, and other +# metadata. + +our %FIELD_METADATA = ( + Status => [ 'ENUM', ], #loc_left_pair + Queue => [ 'ENUM' => 'Queue', ], #loc_left_pair + Type => [ 'ENUM', ], #loc_left_pair + Creator => [ 'ENUM' => 'User', ], #loc_left_pair + LastUpdatedBy => [ 'ENUM' => 'User', ], #loc_left_pair + Owner => [ 'WATCHERFIELD' => 'Owner', ], #loc_left_pair + EffectiveId => [ 'INT', ], #loc_left_pair + id => [ 'ID', ], #loc_left_pair + InitialPriority => [ 'INT', ], #loc_left_pair + FinalPriority => [ 'INT', ], #loc_left_pair + Priority => [ 'INT', ], #loc_left_pair + TimeLeft => [ 'INT', ], #loc_left_pair + TimeWorked => [ 'INT', ], #loc_left_pair + TimeEstimated => [ 'INT', ], #loc_left_pair + + Linked => [ 'LINK' ], #loc_left_pair + LinkedTo => [ 'LINK' => 'To' ], #loc_left_pair + LinkedFrom => [ 'LINK' => 'From' ], #loc_left_pair + MemberOf => [ 'LINK' => To => 'MemberOf', ], #loc_left_pair + DependsOn => [ 'LINK' => To => 'DependsOn', ], #loc_left_pair + RefersTo => [ 'LINK' => To => 'RefersTo', ], #loc_left_pair + HasMember => [ 'LINK' => From => 'MemberOf', ], #loc_left_pair + DependentOn => [ 'LINK' => From => 'DependsOn', ], #loc_left_pair + DependedOnBy => [ 'LINK' => From => 'DependsOn', ], #loc_left_pair + ReferredToBy => [ 'LINK' => From => 'RefersTo', ], #loc_left_pair + Told => [ 'DATE' => 'Told', ], #loc_left_pair + Starts => [ 'DATE' => 'Starts', ], #loc_left_pair + Started => [ 'DATE' => 'Started', ], #loc_left_pair + Due => [ 'DATE' => 'Due', ], #loc_left_pair + Resolved => [ 'DATE' => 'Resolved', ], #loc_left_pair + LastUpdated => [ 'DATE' => 'LastUpdated', ], #loc_left_pair + Created => [ 'DATE' => 'Created', ], #loc_left_pair + Subject => [ 'STRING', ], #loc_left_pair + Content => [ 'TRANSCONTENT', ], #loc_left_pair + ContentType => [ 'TRANSFIELD', ], #loc_left_pair + Filename => [ 'TRANSFIELD', ], #loc_left_pair + TransactionDate => [ 'TRANSDATE', ], #loc_left_pair + Requestor => [ 'WATCHERFIELD' => 'Requestor', ], #loc_left_pair + Requestors => [ 'WATCHERFIELD' => 'Requestor', ], #loc_left_pair + Cc => [ 'WATCHERFIELD' => 'Cc', ], #loc_left_pair + AdminCc => [ 'WATCHERFIELD' => 'AdminCc', ], #loc_left_pair + Watcher => [ 'WATCHERFIELD', ], #loc_left_pair + QueueCc => [ 'WATCHERFIELD' => 'Cc' => 'Queue', ], #loc_left_pair + QueueAdminCc => [ 'WATCHERFIELD' => 'AdminCc' => 'Queue', ], #loc_left_pair + QueueWatcher => [ 'WATCHERFIELD' => undef => 'Queue', ], #loc_left_pair + CustomFieldValue => [ 'CUSTOMFIELD' => 'Ticket' ], #loc_left_pair + CustomField => [ 'CUSTOMFIELD' => 'Ticket' ], #loc_left_pair + CF => [ 'CUSTOMFIELD' => 'Ticket' ], #loc_left_pair + Updated => [ 'TRANSDATE', ], #loc_left_pair + RequestorGroup => [ 'MEMBERSHIPFIELD' => 'Requestor', ], #loc_left_pair + CCGroup => [ 'MEMBERSHIPFIELD' => 'Cc', ], #loc_left_pair + AdminCCGroup => [ 'MEMBERSHIPFIELD' => 'AdminCc', ], #loc_left_pair + WatcherGroup => [ 'MEMBERSHIPFIELD', ], #loc_left_pair + HasAttribute => [ 'HASATTRIBUTE', 1 ], + HasNoAttribute => [ 'HASATTRIBUTE', 0 ], + #freeside + Customer => [ 'FREESIDEFIELD' => 'Customer' ], + Service => [ 'FREESIDEFIELD' => 'Service' ], + WillResolve => [ 'DATE' => 'WillResolve', ], #loc_left_pair +); + +# Lower Case version of FIELDS, for case insensitivity +our %LOWER_CASE_FIELDS = map { ( lc($_) => $_ ) } (keys %FIELD_METADATA); + +our %SEARCHABLE_SUBFIELDS = ( + User => [qw( + EmailAddress Name RealName Nickname Organization Address1 Address2 + WorkPhone HomePhone MobilePhone PagerPhone id + )], +); + +# Mapping of Field Type to Function +our %dispatch = ( + ENUM => \&_EnumLimit, + INT => \&_IntLimit, + ID => \&_IdLimit, + LINK => \&_LinkLimit, + DATE => \&_DateLimit, + STRING => \&_StringLimit, + TRANSFIELD => \&_TransLimit, + TRANSCONTENT => \&_TransContentLimit, + TRANSDATE => \&_TransDateLimit, + WATCHERFIELD => \&_WatcherLimit, + MEMBERSHIPFIELD => \&_WatcherMembershipLimit, + CUSTOMFIELD => \&_CustomFieldLimit, + HASATTRIBUTE => \&_HasAttributeLimit, + FREESIDEFIELD => \&_FreesideFieldLimit, +); +our %can_bundle = ();# WATCHERFIELD => "yes", ); + +# Default EntryAggregator per type +# if you specify OP, you must specify all valid OPs +my %DefaultEA = ( + INT => 'AND', + ENUM => { + '=' => 'OR', + '!=' => 'AND' + }, + DATE => { + '=' => 'OR', + '>=' => 'AND', + '<=' => 'AND', + '>' => 'AND', + '<' => 'AND' + }, + STRING => { + '=' => 'OR', + '!=' => 'AND', + 'LIKE' => 'AND', + 'NOT LIKE' => 'AND' + }, + TRANSFIELD => 'AND', + TRANSDATE => 'AND', + LINK => 'OR', + LINKFIELD => 'AND', + TARGET => 'AND', + BASE => 'AND', + WATCHERFIELD => { + '=' => 'OR', + '!=' => 'AND', + 'LIKE' => 'OR', + 'NOT LIKE' => 'AND' + }, + + HASATTRIBUTE => { + '=' => 'AND', + '!=' => 'AND', + }, + + CUSTOMFIELD => 'OR', +); + +# Helper functions for passing the above lexically scoped tables above +# into Tickets_SQL. +sub FIELDS { return \%FIELD_METADATA } +sub dispatch { return \%dispatch } +sub can_bundle { return \%can_bundle } + +# Bring in the clowns. +require RT::Tickets_SQL; + + +our @SORTFIELDS = qw(id Status + Queue Subject + Owner Created Due Starts Started + Told + Resolved LastUpdated Priority TimeWorked TimeLeft); + +=head2 SortFields + +Returns the list of fields that lists of tickets can easily be sorted by + +=cut + +sub SortFields { + my $self = shift; + return (@SORTFIELDS); +} + + +# BEGIN SQL STUFF ********************************* + + +sub CleanSlate { + my $self = shift; + $self->SUPER::CleanSlate( @_ ); + delete $self->{$_} foreach qw( + _sql_cf_alias + _sql_group_members_aliases + _sql_object_cfv_alias + _sql_role_group_aliases + _sql_trattachalias + _sql_u_watchers_alias_for_sort + _sql_u_watchers_aliases + _sql_current_user_can_see_applied + ); +} + +=head1 Limit Helper Routines + +These routines are the targets of a dispatch table depending on the +type of field. They all share the same signature: + + my ($self,$field,$op,$value,@rest) = @_; + +The values in @rest should be suitable for passing directly to +DBIx::SearchBuilder::Limit. + +Essentially they are an expanded/broken out (and much simplified) +version of what ProcessRestrictions used to do. They're also much +more clearly delineated by the TYPE of field being processed. + +=head2 _IdLimit + +Handle ID field. + +=cut + +sub _IdLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + if ( $value eq '__Bookmarked__' ) { + return $sb->_BookmarkLimit( $field, $op, $value, @rest ); + } else { + return $sb->_IntLimit( $field, $op, $value, @rest ); + } +} + +sub _BookmarkLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + die "Invalid operator $op for __Bookmarked__ search on $field" + unless $op =~ /^(=|!=)$/; + + my @bookmarks = do { + my $tmp = $sb->CurrentUser->UserObj->FirstAttribute('Bookmarks'); + $tmp = $tmp->Content if $tmp; + $tmp ||= {}; + grep $_, keys %$tmp; + }; + + return $sb->_SQLLimit( + FIELD => $field, + OPERATOR => $op, + VALUE => 0, + @rest, + ) unless @bookmarks; + + # as bookmarked tickets can be merged we have to use a join + # but it should be pretty lightweight + my $tickets_alias = $sb->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'Tickets', + FIELD2 => 'EffectiveId', + ); + $sb->_OpenParen; + my $first = 1; + my $ea = $op eq '='? 'OR': 'AND'; + foreach my $id ( sort @bookmarks ) { + $sb->_SQLLimit( + ALIAS => $tickets_alias, + FIELD => 'id', + OPERATOR => $op, + VALUE => $id, + $first? (@rest): ( ENTRYAGGREGATOR => $ea ) + ); + $first = 0 if $first; + } + $sb->_CloseParen; +} + +=head2 _EnumLimit + +Handle Fields which are limited to certain values, and potentially +need to be looked up from another class. + +This subroutine actually handles two different kinds of fields. For +some the user is responsible for limiting the values. (i.e. Status, +Type). + +For others, the value specified by the user will be looked by via +specified class. + +Meta Data: + name of class to lookup in (Optional) + +=cut + +sub _EnumLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + # SQL::Statement changes != to <>. (Can we remove this now?) + $op = "!=" if $op eq "<>"; + + die "Invalid Operation: $op for $field" + unless $op eq "=" + or $op eq "!="; + + my $meta = $FIELD_METADATA{$field}; + if ( defined $meta->[1] && defined $value && $value !~ /^\d+$/ ) { + my $class = "RT::" . $meta->[1]; + my $o = $class->new( $sb->CurrentUser ); + $o->Load($value); + $value = $o->Id || 0; + } elsif ( $field eq "Type" ) { + $value = lc $value if $value =~ /^(ticket|approval|reminder)$/i; + } elsif ($field eq "Status") { + $value = lc $value; + } + $sb->_SQLLimit( + FIELD => $field, + VALUE => $value, + OPERATOR => $op, + @rest, + ); +} + +=head2 _IntLimit + +Handle fields where the values are limited to integers. (For example, +Priority, TimeWorked.) + +Meta Data: + None + +=cut + +sub _IntLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + die "Invalid Operator $op for $field" + unless $op =~ /^(=|!=|>|<|>=|<=)$/; + + $sb->_SQLLimit( + FIELD => $field, + VALUE => $value, + OPERATOR => $op, + @rest, + ); +} + +=head2 _LinkLimit + +Handle fields which deal with links between tickets. (MemberOf, DependsOn) + +Meta Data: + 1: Direction (From, To) + 2: Link Type (MemberOf, DependsOn, RefersTo) + +=cut + +sub _LinkLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + my $meta = $FIELD_METADATA{$field}; + die "Invalid Operator $op for $field" unless $op =~ /^(=|!=|IS|IS NOT)$/io; + + my $is_negative = 0; + if ( $op eq '!=' || $op =~ /\bNOT\b/i ) { + $is_negative = 1; + } + my $is_null = 0; + $is_null = 1 if !$value || $value =~ /^null$/io; + + my $direction = $meta->[1] || ''; + my ($matchfield, $linkfield) = ('', ''); + if ( $direction eq 'To' ) { + ($matchfield, $linkfield) = ("Target", "Base"); + } + elsif ( $direction eq 'From' ) { + ($matchfield, $linkfield) = ("Base", "Target"); + } + elsif ( $direction ) { + die "Invalid link direction '$direction' for $field\n"; + } else { + $sb->_OpenParen; + $sb->_LinkLimit( 'LinkedTo', $op, $value, @rest ); + $sb->_LinkLimit( + 'LinkedFrom', $op, $value, @rest, + ENTRYAGGREGATOR => (($is_negative && $is_null) || (!$is_null && !$is_negative))? 'OR': 'AND', + ); + $sb->_CloseParen; + return; + } + + my $is_local = 1; + if ( $is_null ) { + $op = ($op =~ /^(=|IS)$/i)? 'IS': 'IS NOT'; + } + elsif ( $value =~ /\D/ ) { + $value = RT::URI->new( $sb->CurrentUser )->CanonicalizeURI( $value ); + $is_local = 0; + } + $matchfield = "Local$matchfield" if $is_local; + +#For doing a left join to find "unlinked tickets" we want to generate a query that looks like this +# SELECT main.* FROM Tickets main +# LEFT JOIN Links Links_1 ON ( (Links_1.Type = 'MemberOf') +# AND(main.id = Links_1.LocalTarget)) +# WHERE Links_1.LocalBase IS NULL; + + if ( $is_null ) { + my $linkalias = $sb->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'Links', + FIELD2 => 'Local' . $linkfield + ); + $sb->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Type', + OPERATOR => '=', + VALUE => $meta->[2], + ) if $meta->[2]; + $sb->_SQLLimit( + @rest, + ALIAS => $linkalias, + FIELD => $matchfield, + OPERATOR => $op, + VALUE => 'NULL', + QUOTEVALUE => 0, + ); + } + else { + my $linkalias = $sb->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'Links', + FIELD2 => 'Local' . $linkfield + ); + $sb->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Type', + OPERATOR => '=', + VALUE => $meta->[2], + ) if $meta->[2]; + $sb->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => $matchfield, + OPERATOR => '=', + VALUE => $value, + ); + $sb->_SQLLimit( + @rest, + ALIAS => $linkalias, + FIELD => $matchfield, + OPERATOR => $is_negative? 'IS': 'IS NOT', + VALUE => 'NULL', + QUOTEVALUE => 0, + ); + } +} + +=head2 _DateLimit + +Handle date fields. (Created, LastTold..) + +Meta Data: + 1: type of link. (Probably not necessary.) + +=cut + +sub _DateLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + die "Invalid Date Op: $op" + unless $op =~ /^(=|>|<|>=|<=)$/; + + my $meta = $FIELD_METADATA{$field}; + die "Incorrect Meta Data for $field" + unless ( defined $meta->[1] ); + + $sb->_DateFieldLimit( $meta->[1], $op, $value, @rest ); +} + +# Factor this out for use by custom fields + +sub _DateFieldLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + my $date = RT::Date->new( $sb->CurrentUser ); + $date->Set( Format => 'unknown', Value => $value ); + + if ( $op eq "=" ) { + + # if we're specifying =, that means we want everything on a + # particular single day. in the database, we need to check for > + # and < the edges of that day. + # + # Except if the value is 'this month' or 'last month', check + # > and < the edges of the month. + + my ($daystart, $dayend); + if ( lc($value) eq 'this month' ) { + $date->SetToNow; + $date->SetToStart('month', Timezone => 'server'); + $daystart = $date->ISO; + $date->AddMonth(Timezone => 'server'); + $dayend = $date->ISO; + } + elsif ( lc($value) eq 'last month' ) { + $date->SetToNow; + $date->SetToStart('month', Timezone => 'server'); + $dayend = $date->ISO; + $date->AddDays(-1); + $date->SetToStart('month', Timezone => 'server'); + $daystart = $date->ISO; + } + else { + $date->SetToMidnight( Timezone => 'server' ); + $daystart = $date->ISO; + $date->AddDay; + $dayend = $date->ISO; + } + + $sb->_OpenParen; + + $sb->_SQLLimit( + FIELD => $field, + OPERATOR => ">=", + VALUE => $daystart, + @rest, + ); + + $sb->_SQLLimit( + FIELD => $field, + OPERATOR => "<", + VALUE => $dayend, + @rest, + ENTRYAGGREGATOR => 'AND', + ); + + $sb->_CloseParen; + + } + else { + $sb->_SQLLimit( + FIELD => $field, + OPERATOR => $op, + VALUE => $date->ISO, + @rest, + ); + } +} + +=head2 _StringLimit + +Handle simple fields which are just strings. (Subject,Type) + +Meta Data: + None + +=cut + +sub _StringLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + # FIXME: + # Valid Operators: + # =, !=, LIKE, NOT LIKE + if ( RT->Config->Get('DatabaseType') eq 'Oracle' + && (!defined $value || !length $value) + && lc($op) ne 'is' && lc($op) ne 'is not' + ) { + if ($op eq '!=' || $op =~ /^NOT\s/i) { + $op = 'IS NOT'; + } else { + $op = 'IS'; + } + $value = 'NULL'; + } + + $sb->_SQLLimit( + FIELD => $field, + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + @rest, + ); +} + +=head2 _TransDateLimit + +Handle fields limiting based on Transaction Date. + +The inpupt value must be in a format parseable by Time::ParseDate + +Meta Data: + None + +=cut + +# This routine should really be factored into translimit. +sub _TransDateLimit { + my ( $sb, $field, $op, $value, @rest ) = @_; + + # See the comments for TransLimit, they apply here too + + my $txn_alias = $sb->JoinTransactions; + + my $date = RT::Date->new( $sb->CurrentUser ); + $date->Set( Format => 'unknown', Value => $value ); + + $sb->_OpenParen; + if ( $op eq "=" ) { + + # if we're specifying =, that means we want everything on a + # particular single day. in the database, we need to check for > + # and < the edges of that day. + + $date->SetToMidnight( Timezone => 'server' ); + my $daystart = $date->ISO; + $date->AddDay; + my $dayend = $date->ISO; + + $sb->_SQLLimit( + ALIAS => $txn_alias, + FIELD => 'Created', + OPERATOR => ">=", + VALUE => $daystart, + @rest + ); + $sb->_SQLLimit( + ALIAS => $txn_alias, + FIELD => 'Created', + OPERATOR => "<=", + VALUE => $dayend, + @rest, + ENTRYAGGREGATOR => 'AND', + ); + + } + + # not searching for a single day + else { + + #Search for the right field + $sb->_SQLLimit( + ALIAS => $txn_alias, + FIELD => 'Created', + OPERATOR => $op, + VALUE => $date->ISO, + @rest + ); + } + + $sb->_CloseParen; +} + +=head2 _TransLimit + +Limit based on the ContentType or the Filename of a transaction. + +=cut + +sub _TransLimit { + my ( $self, $field, $op, $value, %rest ) = @_; + + my $txn_alias = $self->JoinTransactions; + unless ( defined $self->{_sql_trattachalias} ) { + $self->{_sql_trattachalias} = $self->_SQLJoin( + TYPE => 'LEFT', # not all txns have an attachment + ALIAS1 => $txn_alias, + FIELD1 => 'id', + TABLE2 => 'Attachments', + FIELD2 => 'TransactionId', + ); + } + + $self->_SQLLimit( + %rest, + ALIAS => $self->{_sql_trattachalias}, + FIELD => $field, + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + ); +} + +=head2 _TransContentLimit + +Limit based on the Content of a transaction. + +=cut + +sub _TransContentLimit { + + # Content search + + # If only this was this simple. We've got to do something + # complicated here: + + #Basically, we want to make sure that the limits apply to + #the same attachment, rather than just another attachment + #for the same ticket, no matter how many clauses we lump + #on. We put them in TicketAliases so that they get nuked + #when we redo the join. + + # In the SQL, we might have + # (( Content = foo ) or ( Content = bar AND Content = baz )) + # The AND group should share the same Alias. + + # Actually, maybe it doesn't matter. We use the same alias and it + # works itself out? (er.. different.) + + # Steal more from _ProcessRestrictions + + # FIXME: Maybe look at the previous FooLimit call, and if it was a + # TransLimit and EntryAggregator == AND, reuse the Aliases? + + # Or better - store the aliases on a per subclause basis - since + # those are going to be the things we want to relate to each other, + # anyway. + + # maybe we should not allow certain kinds of aggregation of these + # clauses and do a psuedo regex instead? - the problem is getting + # them all into the same subclause when you have (A op B op C) - the + # way they get parsed in the tree they're in different subclauses. + + my ( $self, $field, $op, $value, %rest ) = @_; + $field = 'Content' if $field =~ /\W/; + + my $config = RT->Config->Get('FullTextSearch') || {}; + unless ( $config->{'Enable'} ) { + $self->_SQLLimit( %rest, FIELD => 'id', VALUE => 0 ); + return; + } + + my $txn_alias = $self->JoinTransactions; + unless ( defined $self->{_sql_trattachalias} ) { + $self->{_sql_trattachalias} = $self->_SQLJoin( + TYPE => 'LEFT', # not all txns have an attachment + ALIAS1 => $txn_alias, + FIELD1 => 'id', + TABLE2 => 'Attachments', + FIELD2 => 'TransactionId', + ); + } + + $self->_OpenParen; + if ( $config->{'Indexed'} ) { + my $db_type = RT->Config->Get('DatabaseType'); + + my $alias; + if ( $config->{'Table'} and $config->{'Table'} ne "Attachments") { + $alias = $self->{'_sql_aliases'}{'full_text'} ||= $self->_SQLJoin( + TYPE => 'LEFT', + ALIAS1 => $self->{'_sql_trattachalias'}, + FIELD1 => 'id', + TABLE2 => $config->{'Table'}, + FIELD2 => 'id', + ); + } else { + $alias = $self->{'_sql_trattachalias'}; + } + + #XXX: handle negative searches + my $index = $config->{'Column'}; + if ( $db_type eq 'Oracle' ) { + my $dbh = $RT::Handle->dbh; + my $alias = $self->{_sql_trattachalias}; + $self->_SQLLimit( + %rest, + FUNCTION => "CONTAINS( $alias.$field, ".$dbh->quote($value) .")", + OPERATOR => '>', + VALUE => 0, + QUOTEVALUE => 0, + CASESENSITIVE => 1, + ); + # this is required to trick DBIx::SB's LEFT JOINS optimizer + # into deciding that join is redundant as it is + $self->_SQLLimit( + ENTRYAGGREGATOR => 'AND', + ALIAS => $self->{_sql_trattachalias}, + FIELD => 'Content', + OPERATOR => 'IS NOT', + VALUE => 'NULL', + ); + } + elsif ( $db_type eq 'Pg' ) { + my $dbh = $RT::Handle->dbh; + $self->_SQLLimit( + %rest, + ALIAS => $alias, + FIELD => $index, + OPERATOR => '@@', + VALUE => 'plainto_tsquery('. $dbh->quote($value) .')', + QUOTEVALUE => 0, + ); + } + elsif ( $db_type eq 'mysql' ) { + # XXX: We could theoretically skip the join to Attachments, + # and have Sphinx simply index and group by the TicketId, + # and join Ticket.id to that attribute, which would be much + # more efficient -- however, this is only a possibility if + # there are no other transaction limits. + + # This is a special character. Note that \ does not escape + # itself (in Sphinx 2.1.0, at least), so 'foo\;bar' becoming + # 'foo\\;bar' is not a vulnerability, and is still parsed as + # "foo, \, ;, then bar". Happily, the default mode is + # "all", meaning that boolean operators are not special. + $value =~ s/;/\\;/g; + + my $max = $config->{'MaxMatches'}; + $self->_SQLLimit( + %rest, + ALIAS => $alias, + FIELD => 'query', + OPERATOR => '=', + VALUE => "$value;limit=$max;maxmatches=$max", + ); + } + } else { + $self->_SQLLimit( + %rest, + ALIAS => $self->{_sql_trattachalias}, + FIELD => $field, + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + ); + } + if ( RT->Config->Get('DontSearchFileAttachments') ) { + $self->_SQLLimit( + ENTRYAGGREGATOR => 'AND', + ALIAS => $self->{_sql_trattachalias}, + FIELD => 'Filename', + OPERATOR => 'IS', + VALUE => 'NULL', + ); + } + $self->_CloseParen; +} + +=head2 _WatcherLimit + +Handle watcher limits. (Requestor, CC, etc..) + +Meta Data: + 1: Field to query on + + + +=cut + +sub _WatcherLimit { + my $self = shift; + my $field = shift; + my $op = shift; + my $value = shift; + my %rest = (@_); + + my $meta = $FIELD_METADATA{ $field }; + my $type = $meta->[1] || ''; + my $class = $meta->[2] || 'Ticket'; + + # Bail if the subfield is not allowed + if ( $rest{SUBKEY} + and not grep { $_ eq $rest{SUBKEY} } @{$SEARCHABLE_SUBFIELDS{'User'}}) + { + die "Invalid watcher subfield: '$rest{SUBKEY}'"; + } + + # if it's equality op and search by Email or Name then we can preload user + # we do it to help some DBs better estimate number of rows and get better plans + if ( $op =~ /^!?=$/ && (!$rest{'SUBKEY'} || $rest{'SUBKEY'} eq 'Name' || $rest{'SUBKEY'} eq 'EmailAddress') ) { + my $o = RT::User->new( $self->CurrentUser ); + my $method = + !$rest{'SUBKEY'} + ? $field eq 'Owner'? 'Load' : 'LoadByEmail' + : $rest{'SUBKEY'} eq 'EmailAddress' ? 'LoadByEmail': 'Load'; + $o->$method( $value ); + $rest{'SUBKEY'} = 'id'; + $value = $o->id || 0; + } + + # Owner was ENUM field, so "Owner = 'xxx'" allowed user to + # search by id and Name at the same time, this is workaround + # to preserve backward compatibility + if ( $field eq 'Owner' ) { + if ( ($rest{'SUBKEY'}||'') eq 'id' ) { + $self->_SQLLimit( + FIELD => 'Owner', + OPERATOR => $op, + VALUE => $value, + %rest, + ); + return; + } + } + $rest{SUBKEY} ||= 'EmailAddress'; + + my ($groups, $group_members, $users); + if ( $rest{'BUNDLE'} ) { + ($groups, $group_members, $users) = @{ $rest{'BUNDLE'} }; + } else { + $groups = $self->_RoleGroupsJoin( Type => $type, Class => $class, New => !$type ); + } + + $self->_OpenParen; + if ( $op =~ /^IS(?: NOT)?$/i ) { + # is [not] empty case + + $group_members ||= $self->_GroupMembersJoin( GroupsAlias => $groups ); + # to avoid joining the table Users into the query, we just join GM + # and make sure we don't match records where group is member of itself + $self->SUPER::Limit( + LEFTJOIN => $group_members, + FIELD => 'GroupId', + OPERATOR => '!=', + VALUE => "$group_members.MemberId", + QUOTEVALUE => 0, + ); + $self->_SQLLimit( + ALIAS => $group_members, + FIELD => 'GroupId', + OPERATOR => $op, + VALUE => $value, + %rest, + ); + } + elsif ( $op =~ /^!=$|^NOT\s+/i ) { + # negative condition case + + # reverse op + $op =~ s/!|NOT\s+//i; + + # XXX: we have no way to build correct "Watcher.X != 'Y'" when condition + # "X = 'Y'" matches more then one user so we try to fetch two records and + # do the right thing when there is only one exist and semi-working solution + # otherwise. + my $users_obj = RT::Users->new( $self->CurrentUser ); + $users_obj->Limit( + FIELD => $rest{SUBKEY}, + OPERATOR => $op, + VALUE => $value, + ); + $users_obj->OrderBy; + $users_obj->RowsPerPage(2); + my @users = @{ $users_obj->ItemsArrayRef }; + + $group_members ||= $self->_GroupMembersJoin( GroupsAlias => $groups ); + if ( @users <= 1 ) { + my $uid = 0; + $uid = $users[0]->id if @users; + $self->SUPER::Limit( + LEFTJOIN => $group_members, + ALIAS => $group_members, + FIELD => 'MemberId', + VALUE => $uid, + ); + $self->_SQLLimit( + %rest, + ALIAS => $group_members, + FIELD => 'id', + OPERATOR => 'IS', + VALUE => 'NULL', + ); + } else { + $self->SUPER::Limit( + LEFTJOIN => $group_members, + FIELD => 'GroupId', + OPERATOR => '!=', + VALUE => "$group_members.MemberId", + QUOTEVALUE => 0, + ); + $users ||= $self->Join( + TYPE => 'LEFT', + ALIAS1 => $group_members, + FIELD1 => 'MemberId', + TABLE2 => 'Users', + FIELD2 => 'id', + ); + $self->SUPER::Limit( + LEFTJOIN => $users, + ALIAS => $users, + FIELD => $rest{SUBKEY}, + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + ); + $self->_SQLLimit( + %rest, + ALIAS => $users, + FIELD => 'id', + OPERATOR => 'IS', + VALUE => 'NULL', + ); + } + } else { + # positive condition case + + $group_members ||= $self->_GroupMembersJoin( + GroupsAlias => $groups, New => 1, Left => 0 + ); + $users ||= $self->Join( + TYPE => 'LEFT', + ALIAS1 => $group_members, + FIELD1 => 'MemberId', + TABLE2 => 'Users', + FIELD2 => 'id', + ); + $self->_SQLLimit( + %rest, + ALIAS => $users, + FIELD => $rest{'SUBKEY'}, + VALUE => $value, + OPERATOR => $op, + CASESENSITIVE => 0, + ); + } + $self->_CloseParen; + return ($groups, $group_members, $users); +} + +sub _RoleGroupsJoin { + my $self = shift; + my %args = (New => 0, Class => 'Ticket', Type => '', @_); + return $self->{'_sql_role_group_aliases'}{ $args{'Class'} .'-'. $args{'Type'} } + if $self->{'_sql_role_group_aliases'}{ $args{'Class'} .'-'. $args{'Type'} } + && !$args{'New'}; + + # we always have watcher groups for ticket, so we use INNER join + my $groups = $self->Join( + ALIAS1 => 'main', + FIELD1 => $args{'Class'} eq 'Queue'? 'Queue': 'id', + TABLE2 => 'Groups', + FIELD2 => 'Instance', + ENTRYAGGREGATOR => 'AND', + ); + $self->SUPER::Limit( + LEFTJOIN => $groups, + ALIAS => $groups, + FIELD => 'Domain', + VALUE => 'RT::'. $args{'Class'} .'-Role', + ); + $self->SUPER::Limit( + LEFTJOIN => $groups, + ALIAS => $groups, + FIELD => 'Type', + VALUE => $args{'Type'}, + ) if $args{'Type'}; + + $self->{'_sql_role_group_aliases'}{ $args{'Class'} .'-'. $args{'Type'} } = $groups + unless $args{'New'}; + + return $groups; +} + +sub _GroupMembersJoin { + my $self = shift; + my %args = (New => 1, GroupsAlias => undef, Left => 1, @_); + + return $self->{'_sql_group_members_aliases'}{ $args{'GroupsAlias'} } + if $self->{'_sql_group_members_aliases'}{ $args{'GroupsAlias'} } + && !$args{'New'}; + + my $alias = $self->Join( + $args{'Left'} ? (TYPE => 'LEFT') : (), + ALIAS1 => $args{'GroupsAlias'}, + FIELD1 => 'id', + TABLE2 => 'CachedGroupMembers', + FIELD2 => 'GroupId', + ENTRYAGGREGATOR => 'AND', + ); + $self->SUPER::Limit( + $args{'Left'} ? (LEFTJOIN => $alias) : (), + ALIAS => $alias, + FIELD => 'Disabled', + VALUE => 0, + ); + + $self->{'_sql_group_members_aliases'}{ $args{'GroupsAlias'} } = $alias + unless $args{'New'}; + + return $alias; +} + +=head2 _WatcherJoin + +Helper function which provides joins to a watchers table both for limits +and for ordering. + +=cut + +sub _WatcherJoin { + my $self = shift; + my $type = shift || ''; + + + my $groups = $self->_RoleGroupsJoin( Type => $type ); + my $group_members = $self->_GroupMembersJoin( GroupsAlias => $groups ); + # XXX: work around, we must hide groups that + # are members of the role group we search in, + # otherwise them result in wrong NULLs in Users + # table and break ordering. Now, we know that + # RT doesn't allow to add groups as members of the + # ticket roles, so we just hide entries in CGM table + # with MemberId == GroupId from results + $self->SUPER::Limit( + LEFTJOIN => $group_members, + FIELD => 'GroupId', + OPERATOR => '!=', + VALUE => "$group_members.MemberId", + QUOTEVALUE => 0, + ); + my $users = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $group_members, + FIELD1 => 'MemberId', + TABLE2 => 'Users', + FIELD2 => 'id', + ); + return ($groups, $group_members, $users); +} + +=head2 _WatcherMembershipLimit + +Handle watcher membership limits, i.e. whether the watcher belongs to a +specific group or not. + +Meta Data: + 1: Field to query on + +SELECT DISTINCT main.* +FROM + Tickets main, + Groups Groups_1, + CachedGroupMembers CachedGroupMembers_2, + Users Users_3 +WHERE ( + (main.EffectiveId = main.id) +) AND ( + (main.Status != 'deleted') +) AND ( + (main.Type = 'ticket') +) AND ( + ( + (Users_3.EmailAddress = '22') + AND + (Groups_1.Domain = 'RT::Ticket-Role') + AND + (Groups_1.Type = 'RequestorGroup') + ) +) AND + Groups_1.Instance = main.id +AND + Groups_1.id = CachedGroupMembers_2.GroupId +AND + CachedGroupMembers_2.MemberId = Users_3.id +ORDER BY main.id ASC +LIMIT 25 + +=cut + +sub _WatcherMembershipLimit { + my ( $self, $field, $op, $value, @rest ) = @_; + my %rest = @rest; + + $self->_OpenParen; + + my $groups = $self->NewAlias('Groups'); + my $groupmembers = $self->NewAlias('CachedGroupMembers'); + my $users = $self->NewAlias('Users'); + my $memberships = $self->NewAlias('CachedGroupMembers'); + + if ( ref $field ) { # gross hack + my @bundle = @$field; + $self->_OpenParen; + for my $chunk (@bundle) { + ( $field, $op, $value, @rest ) = @$chunk; + $self->_SQLLimit( + ALIAS => $memberships, + FIELD => 'GroupId', + VALUE => $value, + OPERATOR => $op, + @rest, + ); + } + $self->_CloseParen; + } + else { + $self->_SQLLimit( + ALIAS => $memberships, + FIELD => 'GroupId', + VALUE => $value, + OPERATOR => $op, + @rest, + ); + } + + # Tie to groups for tickets we care about + $self->_SQLLimit( + ALIAS => $groups, + FIELD => 'Domain', + VALUE => 'RT::Ticket-Role', + ENTRYAGGREGATOR => 'AND' + ); + + $self->Join( + ALIAS1 => $groups, + FIELD1 => 'Instance', + ALIAS2 => 'main', + FIELD2 => 'id' + ); + + # }}} + + # If we care about which sort of watcher + my $meta = $FIELD_METADATA{$field}; + my $type = ( defined $meta->[1] ? $meta->[1] : undef ); + + if ($type) { + $self->_SQLLimit( + ALIAS => $groups, + FIELD => 'Type', + VALUE => $type, + ENTRYAGGREGATOR => 'AND' + ); + } + + $self->Join( + ALIAS1 => $groups, + FIELD1 => 'id', + ALIAS2 => $groupmembers, + FIELD2 => 'GroupId' + ); + + $self->Join( + ALIAS1 => $groupmembers, + FIELD1 => 'MemberId', + ALIAS2 => $users, + FIELD2 => 'id' + ); + + $self->Limit( + ALIAS => $groupmembers, + FIELD => 'Disabled', + VALUE => 0, + ); + + $self->Join( + ALIAS1 => $memberships, + FIELD1 => 'MemberId', + ALIAS2 => $users, + FIELD2 => 'id' + ); + + $self->Limit( + ALIAS => $memberships, + FIELD => 'Disabled', + VALUE => 0, + ); + + + $self->_CloseParen; + +} + +=head2 _CustomFieldDecipher + +Try and turn a CF descriptor into (cfid, cfname) object pair. + +Takes an optional second parameter of the CF LookupType, defaults to Ticket CFs. + +=cut + +sub _CustomFieldDecipher { + my ($self, $string, $lookuptype) = @_; + $lookuptype ||= $self->_SingularClass->CustomFieldLookupType; + + my ($object, $field, $column) = ($string =~ /^(?:(.+?)\.)?\{(.+)\}(?:\.(Content|LargeContent))?$/); + $field ||= ($string =~ /^{(.*?)}$/)[0] || $string; + + my ($cf, $applied_to); + + if ( $object ) { + my $record_class = RT::CustomField->RecordClassFromLookupType($lookuptype); + $applied_to = $record_class->new( $self->CurrentUser ); + $applied_to->Load( $object ); + + if ( $applied_to->id ) { + RT->Logger->debug("Limiting to CFs identified by '$field' applied to $record_class #@{[$applied_to->id]} (loaded via '$object')"); + } + else { + RT->Logger->warning("$record_class '$object' doesn't exist, parsed from '$string'"); + $object = 0; + undef $applied_to; + } + } + + if ( $field =~ /\D/ ) { + $object ||= ''; + my $cfs = RT::CustomFields->new( $self->CurrentUser ); + $cfs->Limit( FIELD => 'Name', VALUE => $field, ($applied_to ? (CASESENSITIVE => 0) : ()) ); + $cfs->LimitToLookupType($lookuptype); + + if ($applied_to) { + $cfs->SetContextObject($applied_to); + $cfs->LimitToObjectId($applied_to->id); + } + + # if there is more then one field the current user can + # see with the same name then we shouldn't return cf object + # as we don't know which one to use + $cf = $cfs->First; + if ( $cf ) { + $cf = undef if $cfs->Next; + } + } + else { + $cf = RT::CustomField->new( $self->CurrentUser ); + $cf->Load( $field ); + $cf->SetContextObject($applied_to) + if $cf->id and $applied_to; + } + + return ($object, $field, $cf, $column); +} + +=head2 _CustomFieldJoin + +Factor out the Join of custom fields so we can use it for sorting too + +=cut + +our %JOIN_ALIAS_FOR_LOOKUP_TYPE = ( + RT::Ticket->CustomFieldLookupType => sub { "main" }, +); + +sub _CustomFieldJoin { + my ($self, $cfkey, $cfid, $field, $type) = @_; + $type ||= RT::Ticket->CustomFieldLookupType; + + # Perform one Join per CustomField + if ( $self->{_sql_object_cfv_alias}{$cfkey} || + $self->{_sql_cf_alias}{$cfkey} ) + { + return ( $self->{_sql_object_cfv_alias}{$cfkey}, + $self->{_sql_cf_alias}{$cfkey} ); + } + + my $ObjectAlias = $JOIN_ALIAS_FOR_LOOKUP_TYPE{$type} + ? $JOIN_ALIAS_FOR_LOOKUP_TYPE{$type}->($self) + : die "We don't know how to join on $type"; + + my ($ObjectCFs, $CFs); + if ( $cfid ) { + $ObjectCFs = $self->{_sql_object_cfv_alias}{$cfkey} = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $ObjectAlias, + FIELD1 => 'id', + TABLE2 => 'ObjectCustomFieldValues', + FIELD2 => 'ObjectId', + ); + $self->SUPER::Limit( + LEFTJOIN => $ObjectCFs, + FIELD => 'CustomField', + VALUE => $cfid, + ENTRYAGGREGATOR => 'AND' + ); + } + else { + my $ocfalias = $self->Join( + TYPE => 'LEFT', + FIELD1 => 'Queue', + TABLE2 => 'ObjectCustomFields', + FIELD2 => 'ObjectId', + ); + + $self->SUPER::Limit( + LEFTJOIN => $ocfalias, + ENTRYAGGREGATOR => 'OR', + FIELD => 'ObjectId', + VALUE => '0', + ); + + $CFs = $self->{_sql_cf_alias}{$cfkey} = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $ocfalias, + FIELD1 => 'CustomField', + TABLE2 => 'CustomFields', + FIELD2 => 'id', + ); + $self->SUPER::Limit( + LEFTJOIN => $CFs, + ENTRYAGGREGATOR => 'AND', + FIELD => 'LookupType', + VALUE => $type, + ); + $self->SUPER::Limit( + LEFTJOIN => $CFs, + ENTRYAGGREGATOR => 'AND', + FIELD => 'Name', + VALUE => $field, + ); + + $ObjectCFs = $self->{_sql_object_cfv_alias}{$cfkey} = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $CFs, + FIELD1 => 'id', + TABLE2 => 'ObjectCustomFieldValues', + FIELD2 => 'CustomField', + ); + $self->SUPER::Limit( + LEFTJOIN => $ObjectCFs, + FIELD => 'ObjectId', + VALUE => "$ObjectAlias.id", + QUOTEVALUE => 0, + ENTRYAGGREGATOR => 'AND', + ); + } + + $self->SUPER::Limit( + LEFTJOIN => $ObjectCFs, + FIELD => 'ObjectType', + VALUE => RT::CustomField->ObjectTypeFromLookupType($type), + ENTRYAGGREGATOR => 'AND' + ); + $self->SUPER::Limit( + LEFTJOIN => $ObjectCFs, + FIELD => 'Disabled', + OPERATOR => '=', + VALUE => '0', + ENTRYAGGREGATOR => 'AND' + ); + + return ($ObjectCFs, $CFs); +} + +=head2 _CustomFieldLimit + +Limit based on CustomFields + +Meta Data: + none + +=cut + +use Regexp::Common qw(RE_net_IPv4); +use Regexp::Common::net::CIDR; + + +sub _CustomFieldLimit { + my ( $self, $_field, $op, $value, %rest ) = @_; + + my $meta = $FIELD_METADATA{ $_field }; + my $class = $meta->[1] || 'Ticket'; + my $type = "RT::$class"->CustomFieldLookupType; + + my $field = $rest{'SUBKEY'} || die "No field specified"; + + # For our sanity, we can only limit on one queue at a time + + my ($object, $cfid, $cf, $column); + ($object, $field, $cf, $column) = $self->_CustomFieldDecipher( $field, $type ); + $cfid = $cf ? $cf->id : 0 ; + +# If we're trying to find custom fields that don't match something, we +# want tickets where the custom field has no value at all. Note that +# we explicitly don't include the "IS NULL" case, since we would +# otherwise end up with a redundant clause. + + my ($negative_op, $null_op, $inv_op, $range_op) + = $self->ClassifySQLOperation( $op ); + + my $fix_op = sub { + return @_ unless RT->Config->Get('DatabaseType') eq 'Oracle'; + + my %args = @_; + return %args unless $args{'FIELD'} eq 'LargeContent'; + + my $op = $args{'OPERATOR'}; + if ( $op eq '=' ) { + $args{'OPERATOR'} = 'MATCHES'; + } + elsif ( $op eq '!=' ) { + $args{'OPERATOR'} = 'NOT MATCHES'; + } + elsif ( $op =~ /^[<>]=?$/ ) { + $args{'FUNCTION'} = "TO_CHAR( $args{'ALIAS'}.LargeContent )"; + } + return %args; + }; + + if ( $cf && $cf->Type eq 'IPAddress' ) { + my $parsed = RT::ObjectCustomFieldValue->ParseIP($value); + if ($parsed) { + $value = $parsed; + } + else { + $RT::Logger->warn("$value is not a valid IPAddress"); + } + } + + if ( $cf && $cf->Type eq 'IPAddressRange' ) { + my ( $start_ip, $end_ip ) = + RT::ObjectCustomFieldValue->ParseIPRange($value); + if ( $start_ip && $end_ip ) { + if ( $op =~ /^([<>])=?$/ ) { + my $is_less = $1 eq '<' ? 1 : 0; + if ( $is_less ) { + $value = $start_ip; + } + else { + $value = $end_ip; + } + } + else { + $value = join '-', $start_ip, $end_ip; + } + } + else { + $RT::Logger->warn("$value is not a valid IPAddressRange"); + } + } + + if ( $cf && $cf->Type =~ /^Date(?:Time)?$/ ) { + my $date = RT::Date->new( $self->CurrentUser ); + $date->Set( Format => 'unknown', Value => $value ); + if ( $date->Unix ) { + + if ( + $cf->Type eq 'Date' + || $value =~ /^\s*(?:today|tomorrow|yesterday)\s*$/i + || ( $value !~ /midnight|\d+:\d+:\d+/i + && $date->Time( Timezone => 'user' ) eq '00:00:00' ) + ) + { + $value = $date->Date( Timezone => 'user' ); + } + else { + $value = $date->DateTime; + } + } + else { + $RT::Logger->warn("$value is not a valid date string"); + } + } + + my $single_value = !$cf || !$cfid || $cf->SingleValue; + + my $cfkey = $cfid ? $cfid : "$type-$object.$field"; + + if ( $null_op && !$column ) { + # IS[ NOT] NULL without column is the same as has[ no] any CF value, + # we can reuse our default joins for this operation + # with column specified we have different situation + my ($ObjectCFs, $CFs) = $self->_CustomFieldJoin( $cfkey, $cfid, $field, $type ); + $self->_OpenParen; + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'id', + OPERATOR => $op, + VALUE => $value, + %rest + ); + $self->_SQLLimit( + ALIAS => $CFs, + FIELD => 'Name', + OPERATOR => 'IS NOT', + VALUE => 'NULL', + QUOTEVALUE => 0, + ENTRYAGGREGATOR => 'AND', + ) if $CFs; + $self->_CloseParen; + } + elsif ( $op !~ /^[<>]=?$/ && ( $cf && $cf->Type eq 'IPAddressRange')) { + + my ($start_ip, $end_ip) = split /-/, $value; + + $self->_OpenParen; + if ( $op !~ /NOT|!=|<>/i ) { # positive equation + $self->_CustomFieldLimit( + $_field, '<=', $end_ip, %rest, + SUBKEY => $rest{'SUBKEY'}. '.Content', + ); + $self->_CustomFieldLimit( + $_field, '>=', $start_ip, %rest, + SUBKEY => $rest{'SUBKEY'}. '.LargeContent', + ENTRYAGGREGATOR => 'AND', + ); + # as well limit borders so DB optimizers can use better + # estimations and scan less rows +# have to disable this tweak because of ipv6 +# $self->_CustomFieldLimit( +# $_field, '>=', '000.000.000.000', %rest, +# SUBKEY => $rest{'SUBKEY'}. '.Content', +# ENTRYAGGREGATOR => 'AND', +# ); +# $self->_CustomFieldLimit( +# $_field, '<=', '255.255.255.255', %rest, +# SUBKEY => $rest{'SUBKEY'}. '.LargeContent', +# ENTRYAGGREGATOR => 'AND', +# ); + } + else { # negative equation + $self->_CustomFieldLimit($_field, '>', $end_ip, %rest); + $self->_CustomFieldLimit( + $_field, '<', $start_ip, %rest, + SUBKEY => $rest{'SUBKEY'}. '.LargeContent', + ENTRYAGGREGATOR => 'OR', + ); + # TODO: as well limit borders so DB optimizers can use better + # estimations and scan less rows, but it's harder to do + # as we have OR aggregator + } + $self->_CloseParen; + } + elsif ( !$negative_op || $single_value ) { + $cfkey .= '.'. $self->{'_sql_multiple_cfs_index'}++ if !$single_value && !$range_op; + my ($ObjectCFs, $CFs) = $self->_CustomFieldJoin( $cfkey, $cfid, $field, $type ); + + $self->_OpenParen; + + $self->_OpenParen; + + $self->_OpenParen; + # if column is defined then deal only with it + # otherwise search in Content and in LargeContent + if ( $column ) { + $self->_SQLLimit( $fix_op->( + ALIAS => $ObjectCFs, + FIELD => $column, + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + %rest + ) ); + $self->_CloseParen; + $self->_CloseParen; + $self->_CloseParen; + } + else { + # need special treatment for Date + if ( $cf and $cf->Type eq 'DateTime' and $op eq '=' && $value !~ /:/ ) { + # no time specified, that means we want everything on a + # particular day. in the database, we need to check for > + # and < the edges of that day. + my $date = RT::Date->new( $self->CurrentUser ); + $date->Set( Format => 'unknown', Value => $value ); + my $daystart = $date->ISO; + $date->AddDay; + my $dayend = $date->ISO; + + $self->_OpenParen; + + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => ">=", + VALUE => $daystart, + %rest, + ); + + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => "<", + VALUE => $dayend, + %rest, + ENTRYAGGREGATOR => 'AND', + ); + + $self->_CloseParen; + } + elsif ( $op eq '=' || $op eq '!=' || $op eq '<>' ) { + if ( length( Encode::encode_utf8($value) ) < 256 ) { + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + %rest + ); + } + else { + $self->_OpenParen; + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => '=', + VALUE => '', + ENTRYAGGREGATOR => 'OR' + ); + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => 'IS', + VALUE => 'NULL', + ENTRYAGGREGATOR => 'OR' + ); + $self->_CloseParen; + $self->_SQLLimit( $fix_op->( + ALIAS => $ObjectCFs, + FIELD => 'LargeContent', + OPERATOR => $op, + VALUE => $value, + ENTRYAGGREGATOR => 'AND', + CASESENSITIVE => 0, + ) ); + } + } + else { + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + %rest + ); + + $self->_OpenParen; + $self->_OpenParen; + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => '=', + VALUE => '', + ENTRYAGGREGATOR => 'OR' + ); + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => 'IS', + VALUE => 'NULL', + ENTRYAGGREGATOR => 'OR' + ); + $self->_CloseParen; + $self->_SQLLimit( $fix_op->( + ALIAS => $ObjectCFs, + FIELD => 'LargeContent', + OPERATOR => $op, + VALUE => $value, + ENTRYAGGREGATOR => 'AND', + CASESENSITIVE => 0, + ) ); + $self->_CloseParen; + } + $self->_CloseParen; + + # XXX: if we join via CustomFields table then + # because of order of left joins we get NULLs in + # CF table and then get nulls for those records + # in OCFVs table what result in wrong results + # as decifer method now tries to load a CF then + # we fall into this situation only when there + # are more than one CF with the name in the DB. + # the same thing applies to order by call. + # TODO: reorder joins T <- OCFVs <- CFs <- OCFs if + # we want treat IS NULL as (not applies or has + # no value) + $self->_SQLLimit( + ALIAS => $CFs, + FIELD => 'Name', + OPERATOR => 'IS NOT', + VALUE => 'NULL', + QUOTEVALUE => 0, + ENTRYAGGREGATOR => 'AND', + ) if $CFs; + $self->_CloseParen; + + if ($negative_op) { + $self->_SQLLimit( + ALIAS => $ObjectCFs, + FIELD => $column || 'Content', + OPERATOR => 'IS', + VALUE => 'NULL', + QUOTEVALUE => 0, + ENTRYAGGREGATOR => 'OR', + ); + } + + $self->_CloseParen; + } + } + else { + $cfkey .= '.'. $self->{'_sql_multiple_cfs_index'}++; + my ($ObjectCFs, $CFs) = $self->_CustomFieldJoin( $cfkey, $cfid, $field, $type ); + + # reverse operation + $op =~ s/!|NOT\s+//i; + + # if column is defined then deal only with it + # otherwise search in Content and in LargeContent + if ( $column ) { + $self->SUPER::Limit( $fix_op->( + LEFTJOIN => $ObjectCFs, + ALIAS => $ObjectCFs, + FIELD => $column, + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + ) ); + } + else { + $self->SUPER::Limit( + LEFTJOIN => $ObjectCFs, + ALIAS => $ObjectCFs, + FIELD => 'Content', + OPERATOR => $op, + VALUE => $value, + CASESENSITIVE => 0, + ); + } + $self->_SQLLimit( + %rest, + ALIAS => $ObjectCFs, + FIELD => 'id', + OPERATOR => 'IS', + VALUE => 'NULL', + QUOTEVALUE => 0, + ); + } +} + +sub _HasAttributeLimit { + my ( $self, $field, $op, $value, %rest ) = @_; + + my $alias = $self->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'Attributes', + FIELD2 => 'ObjectId', + ); + $self->SUPER::Limit( + LEFTJOIN => $alias, + FIELD => 'ObjectType', + VALUE => 'RT::Ticket', + ENTRYAGGREGATOR => 'AND' + ); + $self->SUPER::Limit( + LEFTJOIN => $alias, + FIELD => 'Name', + OPERATOR => $op, + VALUE => $value, + ENTRYAGGREGATOR => 'AND' + ); + $self->_SQLLimit( + %rest, + ALIAS => $alias, + FIELD => 'id', + OPERATOR => $FIELD_METADATA{$field}->[1]? 'IS NOT': 'IS', + VALUE => 'NULL', + QUOTEVALUE => 0, + ); +} + +# End Helper Functions + +# End of SQL Stuff ------------------------------------------------- + + +=head2 OrderByCols ARRAY + +A modified version of the OrderBy method which automatically joins where +C<ALIAS> is set to the name of a watcher type. + +=cut + +sub OrderByCols { + my $self = shift; + my @args = @_; + my $clause; + my @res = (); + my $order = 0; + + foreach my $row (@args) { + if ( $row->{ALIAS} ) { + push @res, $row; + next; + } + if ( $row->{FIELD} !~ /\./ ) { + my $meta = $self->FIELDS->{ $row->{FIELD} }; + unless ( $meta ) { + push @res, $row; + next; + } + + if ( $meta->[0] eq 'ENUM' && ($meta->[1]||'') eq 'Queue' ) { + my $alias = $self->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => $row->{'FIELD'}, + TABLE2 => 'Queues', + FIELD2 => 'id', + ); + push @res, { %$row, ALIAS => $alias, FIELD => "Name" }; + } elsif ( ( $meta->[0] eq 'ENUM' && ($meta->[1]||'') eq 'User' ) + || ( $meta->[0] eq 'WATCHERFIELD' && ($meta->[1]||'') eq 'Owner' ) + ) { + my $alias = $self->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => $row->{'FIELD'}, + TABLE2 => 'Users', + FIELD2 => 'id', + ); + push @res, { %$row, ALIAS => $alias, FIELD => "Name" }; + } else { + push @res, $row; + } + next; + } + + my ( $field, $subkey ) = split /\./, $row->{FIELD}, 2; + my $meta = $self->FIELDS->{$field}; + if ( defined $meta->[0] && $meta->[0] eq 'WATCHERFIELD' ) { + # cache alias as we want to use one alias per watcher type for sorting + my $users = $self->{_sql_u_watchers_alias_for_sort}{ $meta->[1] }; + unless ( $users ) { + $self->{_sql_u_watchers_alias_for_sort}{ $meta->[1] } + = $users = ( $self->_WatcherJoin( $meta->[1] ) )[2]; + } + push @res, { %$row, ALIAS => $users, FIELD => $subkey }; + } elsif ( defined $meta->[0] && $meta->[0] eq 'CUSTOMFIELD' ) { + my ($object, $field, $cf_obj, $column) = $self->_CustomFieldDecipher( $subkey ); + my $cfkey = $cf_obj ? $cf_obj->id : "$object.$field"; + $cfkey .= ".ordering" if !$cf_obj || ($cf_obj->MaxValues||0) != 1; + my ($ObjectCFs, $CFs) = $self->_CustomFieldJoin( $cfkey, ($cf_obj ?$cf_obj->id :0) , $field ); + # this is described in _CustomFieldLimit + $self->_SQLLimit( + ALIAS => $CFs, + FIELD => 'Name', + OPERATOR => 'IS NOT', + VALUE => 'NULL', + QUOTEVALUE => 1, + ENTRYAGGREGATOR => 'AND', + ) if $CFs; + unless ($cf_obj) { + # For those cases where we are doing a join against the + # CF name, and don't have a CFid, use Unique to make sure + # we don't show duplicate tickets. NOTE: I'm pretty sure + # this will stay mixed in for the life of the + # class/package, and not just for the life of the object. + # Potential performance issue. + require DBIx::SearchBuilder::Unique; + DBIx::SearchBuilder::Unique->import; + } + my $CFvs = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $ObjectCFs, + FIELD1 => 'CustomField', + TABLE2 => 'CustomFieldValues', + FIELD2 => 'CustomField', + ); + $self->SUPER::Limit( + LEFTJOIN => $CFvs, + FIELD => 'Name', + QUOTEVALUE => 0, + VALUE => $ObjectCFs . ".Content", + ENTRYAGGREGATOR => 'AND' + ); + + push @res, { %$row, ALIAS => $CFvs, FIELD => 'SortOrder' }; + push @res, { %$row, ALIAS => $ObjectCFs, FIELD => 'Content' }; + } elsif ( $field eq "Custom" && $subkey eq "Ownership") { + # PAW logic is "reversed" + my $order = "ASC"; + if (exists $row->{ORDER} ) { + my $o = $row->{ORDER}; + delete $row->{ORDER}; + $order = "DESC" if $o =~ /asc/i; + } + + # Ticket.Owner 1 0 X + # Unowned Tickets 0 1 X + # Else 0 0 X + + foreach my $uid ( $self->CurrentUser->Id, RT->Nobody->Id ) { + if ( RT->Config->Get('DatabaseType') eq 'Oracle' ) { + my $f = ($row->{'ALIAS'} || 'main') .'.Owner'; + push @res, { + %$row, + FIELD => undef, + ALIAS => '', + FUNCTION => "CASE WHEN $f=$uid THEN 1 ELSE 0 END", + ORDER => $order + }; + } else { + push @res, { + %$row, + FIELD => undef, + FUNCTION => "Owner=$uid", + ORDER => $order + }; + } + } + + push @res, { %$row, FIELD => "Priority", ORDER => $order } ; + + } elsif ( $field eq 'Customer' ) { #Freeside + # OrderBy(FIELD => expression) doesn't work, it has to be + # an actual field, so we have to do the join even if sorting + # by custnum + my $custalias = $self->JoinToCustomer; + my $cust_field = lc($subkey); + if ( !$cust_field or $cust_field eq 'number' ) { + $cust_field = 'custnum'; + } + elsif ( $cust_field eq 'name' ) { + $cust_field = "COALESCE( $custalias.company, + $custalias.last || ', ' || $custalias.first + )"; + } + else { # order by cust_main fields directly: 'Customer.agentnum' + $cust_field = $subkey; + } + push @res, { %$row, ALIAS => $custalias, FIELD => $cust_field }; + + } elsif ( $field eq 'Service' ) { + + my $svcalias = $self->JoinToService; + my $svc_field = lc($subkey); + if ( !$svc_field or $svc_field eq 'number' ) { + $svc_field = 'svcnum'; + } + push @res, { %$row, ALIAS => $svcalias, FIELD => $svc_field }; + + } #Freeside + + else { + push @res, $row; + } + } + return $self->SUPER::OrderByCols(@res); +} + +#Freeside + +sub JoinToCustLinks { + # Set up join to links (id = localbase), + # limit link type to 'MemberOf', + # and target value to any Freeside custnum URI. + # Return the linkalias for further join/limit action, + # and an sql expression to retrieve the custnum. + my $self = shift; + # only join once for each RT::Tickets object + my $linkalias = $self->{cust_main_linkalias}; + if (!$linkalias) { + $linkalias = $self->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'Links', + FIELD2 => 'LocalBase', + ); + $self->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Base', + OPERATOR => 'LIKE', + VALUE => 'fsck.com-rt://%/ticket/%', + ); + $self->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Type', + OPERATOR => '=', + VALUE => 'MemberOf', + ); + $self->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Target', + OPERATOR => 'STARTSWITH', + VALUE => 'freeside://freeside/cust_main/', + ); + $self->{cust_main_linkalias} = $linkalias; + } + my $custnum_sql = "CAST(SUBSTR($linkalias.Target,31) AS "; + if ( RT->Config->Get('DatabaseType') eq 'mysql' ) { + $custnum_sql .= 'SIGNED INTEGER)'; + } + else { + $custnum_sql .= 'INTEGER)'; + } + return ($linkalias, $custnum_sql); +} + +sub JoinToCustomer { + my $self = shift; + my ($linkalias, $custnum_sql) = $self->JoinToCustLinks; + # don't reuse this join, though--negative queries need + # independent joins + my $custalias = $self->Join( + TYPE => 'LEFT', + EXPRESSION => $custnum_sql, + TABLE2 => 'cust_main', + FIELD2 => 'custnum', + ); + return $custalias; +} + +sub JoinToSvcLinks { + my $self = shift; + my $linkalias = $self->{cust_svc_linkalias}; + if (!$linkalias) { + $linkalias = $self->Join( + TYPE => 'LEFT', + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'Links', + FIELD2 => 'LocalBase', + ); + $self->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Base', + OPERATOR => 'LIKE', + VALUE => 'fsck.com-rt://%/ticket/%', + ); + + $self->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Type', + OPERATOR => '=', + VALUE => 'MemberOf', + ); + $self->SUPER::Limit( + LEFTJOIN => $linkalias, + FIELD => 'Target', + OPERATOR => 'STARTSWITH', + VALUE => 'freeside://freeside/cust_svc/', + ); + $self->{cust_svc_linkalias} = $linkalias; + } + my $svcnum_sql = "CAST(SUBSTR($linkalias.Target,30) AS "; + if ( RT->Config->Get('DatabaseType') eq 'mysql' ) { + $svcnum_sql .= 'SIGNED INTEGER)'; + } + else { + $svcnum_sql .= 'INTEGER)'; + } + return ($linkalias, $svcnum_sql); +} + +sub JoinToService { + my $self = shift; + my ($linkalias, $svcnum_sql) = $self->JoinToSvcLinks; + $self->Join( + TYPE => 'LEFT', + EXPRESSION => $svcnum_sql, + TABLE2 => 'cust_svc', + FIELD2 => 'svcnum', + ); +} + +# This creates an alternate left join path to cust_main via cust_svc. +# _FreesideFieldLimit needs to add this as a separate, independent join +# and include all tickets that have a matching cust_main record via +# either path. +sub JoinToCustomerViaService { + my $self = shift; + my $svcalias = $self->JoinToService; + my $cust_pkg = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $svcalias, + FIELD1 => 'pkgnum', + TABLE2 => 'cust_pkg', + FIELD2 => 'pkgnum', + ); + my $cust_main = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $cust_pkg, + FIELD1 => 'custnum', + TABLE2 => 'cust_main', + FIELD2 => 'custnum', + ); + $cust_main; +} + +sub _FreesideFieldLimit { + my ( $self, $field, $op, $value, %rest ) = @_; + my $is_negative = 0; + if ( $op eq '!=' || $op =~ /\bNOT\b/i ) { + # if the op is negative, do the join as though + # the op were positive, then accept only records + # where the right-side join key is null. + $is_negative = 1; + $op = '=' if $op eq '!='; + $op =~ s/\bNOT\b//; + } + + my (@alias, $table2, $subfield, $pkey); + if ( $field eq 'Customer' ) { + push @alias, $self->JoinToCustomer; + push @alias, $self->JoinToCustomerViaService; + $pkey = 'custnum'; + } + elsif ( $field eq 'Service' ) { + push @alias, $self->JoinToService; + $pkey = 'svcnum'; + } + else { + die "malformed Freeside query: $field"; + } + + $subfield = $rest{SUBKEY} || $pkey; + # compound subkey: separate into table name and field in that table + # (must be linked by custnum) + $subfield = lc($subfield); + ($table2, $subfield) = ($1, $2) if $subfield =~ /^(\w+)?\.(\w+)$/; + $subfield = $pkey if $subfield eq 'number'; + + # if it's compound, create a join from cust_main or cust_svc to that + # table, using custnum or svcnum, and Limit on that table instead. + my @_SQLLimit = (); + foreach my $a (@alias) { + if ( $table2 ) { + $a = $self->Join( + TYPE => 'LEFT', + ALIAS1 => $a, + FIELD1 => $pkey, + TABLE2 => $table2, + FIELD2 => $pkey, + ); + } + + # do the actual Limit + $self->SUPER::Limit( + LEFTJOIN => $a, + FIELD => $subfield, + OPERATOR => $op, + VALUE => $value, + ENTRYAGGREGATOR => 'AND', + # no SUBCLAUSE needed, limits on different aliases across left joins + # are inherently independent + ); + + # then, since it's a left join, exclude tickets for which there is now + # no matching record in the table we just limited on. (Or where there + # is a matching record, if $is_negative.) + # For a cust_main query (where there are two different aliases), this + # will produce a subclause: "cust_main_1.custnum IS NOT NULL OR + # cust_main_2.custnum IS NOT NULL" (or "IS NULL AND..." for a negative + # query). + #$self->_SQLLimit( + push @_SQLLimit, { + %rest, + ALIAS => $a, + FIELD => $pkey, + OPERATOR => $is_negative ? 'IS' : 'IS NOT', + VALUE => 'NULL', + QUOTEVALUE => 0, + ENTRYAGGREGATOR => $is_negative ? 'AND' : 'OR', + SUBCLAUSE => 'fs_limit', + }; + } + + $self->_OpenParen; + foreach my $_SQLLimit (@_SQLLimit) { + $self->_SQLLimit( %$_SQLLimit); + } + $self->_CloseParen; + +} + +#Freeside + +=head2 Limit + +Takes a paramhash with the fields FIELD, OPERATOR, VALUE and DESCRIPTION +Generally best called from LimitFoo methods + +=cut + +sub Limit { + my $self = shift; + my %args = ( + FIELD => undef, + OPERATOR => '=', + VALUE => undef, + DESCRIPTION => undef, + @_ + ); + $args{'DESCRIPTION'} = $self->loc( + "[_1] [_2] [_3]", $args{'FIELD'}, + $args{'OPERATOR'}, $args{'VALUE'} + ) + if ( !defined $args{'DESCRIPTION'} ); + + my $index = $self->_NextIndex; + +# make the TicketRestrictions hash the equivalent of whatever we just passed in; + + %{ $self->{'TicketRestrictions'}{$index} } = %args; + + $self->{'RecalcTicketLimits'} = 1; + +# If we're looking at the effective id, we don't want to append the other clause +# which limits us to tickets where id = effective id + if ( $args{'FIELD'} eq 'EffectiveId' + && ( !$args{'ALIAS'} || $args{'ALIAS'} eq 'main' ) ) + { + $self->{'looking_at_effective_id'} = 1; + } + + if ( $args{'FIELD'} eq 'Type' + && ( !$args{'ALIAS'} || $args{'ALIAS'} eq 'main' ) ) + { + $self->{'looking_at_type'} = 1; + } + + return ($index); +} + + + + +=head2 LimitQueue + +LimitQueue takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of = or !=. (It defaults to =). +VALUE is a queue id or Name. + + +=cut + +sub LimitQueue { + my $self = shift; + my %args = ( + VALUE => undef, + OPERATOR => '=', + @_ + ); + + #TODO VALUE should also take queue objects + if ( defined $args{'VALUE'} && $args{'VALUE'} !~ /^\d+$/ ) { + my $queue = RT::Queue->new( $self->CurrentUser ); + $queue->Load( $args{'VALUE'} ); + $args{'VALUE'} = $queue->Id; + } + + # What if they pass in an Id? Check for isNum() and convert to + # string. + + #TODO check for a valid queue here + + $self->Limit( + FIELD => 'Queue', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( + ' ', $self->loc('Queue'), $args{'OPERATOR'}, $args{'VALUE'}, + ), + ); + +} + + + +=head2 LimitStatus + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of = or !=. +VALUE is a status. + +RT adds Status != 'deleted' until object has +allow_deleted_search internal property set. +$tickets->{'allow_deleted_search'} = 1; +$tickets->LimitStatus( VALUE => 'deleted' ); + +=cut + +sub LimitStatus { + my $self = shift; + my %args = ( + OPERATOR => '=', + @_ + ); + $self->Limit( + FIELD => 'Status', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Status'), $args{'OPERATOR'}, + $self->loc( $args{'VALUE'} ) ), + ); +} + + + +=head2 IgnoreType + +If called, this search will not automatically limit the set of results found +to tickets of type "Ticket". Tickets of other types, such as "project" and +"approval" will be found. + +=cut + +sub IgnoreType { + my $self = shift; + + # Instead of faking a Limit that later gets ignored, fake up the + # fact that we're already looking at type, so that the check in + # Tickets_SQL/FromSQL goes down the right branch + + # $self->LimitType(VALUE => '__any'); + $self->{looking_at_type} = 1; +} + + + +=head2 LimitType + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of = or !=, it defaults to "=". +VALUE is a string to search for in the type of the ticket. + + + +=cut + +sub LimitType { + my $self = shift; + my %args = ( + OPERATOR => '=', + VALUE => undef, + @_ + ); + $self->Limit( + FIELD => 'Type', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Type'), $args{'OPERATOR'}, $args{'VALUE'}, ), + ); +} + + + + + +=head2 LimitSubject + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of = or !=. +VALUE is a string to search for in the subject of the ticket. + +=cut + +sub LimitSubject { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'Subject', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Subject'), $args{'OPERATOR'}, $args{'VALUE'}, ), + ); +} + + + +# Things that can be > < = != + + +=head2 LimitId + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, >, < or !=. +VALUE is a ticket Id to search for + +=cut + +sub LimitId { + my $self = shift; + my %args = ( + OPERATOR => '=', + @_ + ); + + $self->Limit( + FIELD => 'id', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => + join( ' ', $self->loc('Id'), $args{'OPERATOR'}, $args{'VALUE'}, ), + ); +} + + + +=head2 LimitPriority + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, >, < or !=. +VALUE is a value to match the ticket's priority against + +=cut + +sub LimitPriority { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'Priority', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Priority'), + $args{'OPERATOR'}, $args{'VALUE'}, ), + ); +} + + + +=head2 LimitInitialPriority + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, >, < or !=. +VALUE is a value to match the ticket's initial priority against + + +=cut + +sub LimitInitialPriority { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'InitialPriority', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Initial Priority'), $args{'OPERATOR'}, + $args{'VALUE'}, ), + ); +} + + + +=head2 LimitFinalPriority + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, >, < or !=. +VALUE is a value to match the ticket's final priority against + +=cut + +sub LimitFinalPriority { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'FinalPriority', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Final Priority'), $args{'OPERATOR'}, + $args{'VALUE'}, ), + ); +} + + + +=head2 LimitTimeWorked + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, >, < or !=. +VALUE is a value to match the ticket's TimeWorked attribute + +=cut + +sub LimitTimeWorked { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'TimeWorked', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Time Worked'), + $args{'OPERATOR'}, $args{'VALUE'}, ), + ); +} + + + +=head2 LimitTimeLeft + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, >, < or !=. +VALUE is a value to match the ticket's TimeLeft attribute + +=cut + +sub LimitTimeLeft { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'TimeLeft', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Time Left'), + $args{'OPERATOR'}, $args{'VALUE'}, ), + ); +} + + + + + +=head2 LimitContent + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, LIKE, NOT LIKE or !=. +VALUE is a string to search for in the body of the ticket + +=cut + +sub LimitContent { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'Content', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Ticket content'), $args{'OPERATOR'}, + $args{'VALUE'}, ), + ); +} + + + +=head2 LimitFilename + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, LIKE, NOT LIKE or !=. +VALUE is a string to search for in the body of the ticket + +=cut + +sub LimitFilename { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'Filename', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Attachment filename'), $args{'OPERATOR'}, + $args{'VALUE'}, ), + ); +} + + +=head2 LimitContentType + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of =, LIKE, NOT LIKE or !=. +VALUE is a content type to search ticket attachments for + +=cut + +sub LimitContentType { + my $self = shift; + my %args = (@_); + $self->Limit( + FIELD => 'ContentType', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Ticket content type'), $args{'OPERATOR'}, + $args{'VALUE'}, ), + ); +} + + + + + +=head2 LimitOwner + +Takes a paramhash with the fields OPERATOR and VALUE. +OPERATOR is one of = or !=. +VALUE is a user id. + +=cut + +sub LimitOwner { + my $self = shift; + my %args = ( + OPERATOR => '=', + @_ + ); + + my $owner = RT::User->new( $self->CurrentUser ); + $owner->Load( $args{'VALUE'} ); + + # FIXME: check for a valid $owner + $self->Limit( + FIELD => 'Owner', + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + DESCRIPTION => join( ' ', + $self->loc('Owner'), $args{'OPERATOR'}, $owner->Name(), ), + ); + +} + + + + +=head2 LimitWatcher + + Takes a paramhash with the fields OPERATOR, TYPE and VALUE. + OPERATOR is one of =, LIKE, NOT LIKE or !=. + VALUE is a value to match the ticket's watcher email addresses against + TYPE is the sort of watchers you want to match against. Leave it undef if you want to search all of them + + +=cut + +sub LimitWatcher { + my $self = shift; + my %args = ( + OPERATOR => '=', + VALUE => undef, + TYPE => undef, + @_ + ); + + #build us up a description + my ( $watcher_type, $desc ); + if ( $args{'TYPE'} ) { + $watcher_type = $args{'TYPE'}; + } + else { + $watcher_type = "Watcher"; + } + + $self->Limit( + FIELD => $watcher_type, + VALUE => $args{'VALUE'}, + OPERATOR => $args{'OPERATOR'}, + TYPE => $args{'TYPE'}, + DESCRIPTION => join( ' ', + $self->loc($watcher_type), + $args{'OPERATOR'}, $args{'VALUE'}, ), + ); +} + + + + + + +=head2 LimitLinkedTo + +LimitLinkedTo takes a paramhash with two fields: TYPE and TARGET +TYPE limits the sort of link we want to search on + +TYPE = { RefersTo, MemberOf, DependsOn } + +TARGET is the id or URI of the TARGET of the link + +=cut + +sub LimitLinkedTo { + my $self = shift; + my %args = ( + TARGET => undef, + TYPE => undef, + OPERATOR => '=', + @_ + ); + + $self->Limit( + FIELD => 'LinkedTo', + BASE => undef, + TARGET => $args{'TARGET'}, + TYPE => $args{'TYPE'}, + DESCRIPTION => $self->loc( + "Tickets [_1] by [_2]", + $self->loc( $args{'TYPE'} ), + $args{'TARGET'} + ), + OPERATOR => $args{'OPERATOR'}, + ); +} + + + +=head2 LimitLinkedFrom + +LimitLinkedFrom takes a paramhash with two fields: TYPE and BASE +TYPE limits the sort of link we want to search on + + +BASE is the id or URI of the BASE of the link + +=cut + +sub LimitLinkedFrom { + my $self = shift; + my %args = ( + BASE => undef, + TYPE => undef, + OPERATOR => '=', + @_ + ); + + # translate RT2 From/To naming to RT3 TicketSQL naming + my %fromToMap = qw(DependsOn DependentOn + MemberOf HasMember + RefersTo ReferredToBy); + + my $type = $args{'TYPE'}; + $type = $fromToMap{$type} if exists( $fromToMap{$type} ); + + $self->Limit( + FIELD => 'LinkedTo', + TARGET => undef, + BASE => $args{'BASE'}, + TYPE => $type, + DESCRIPTION => $self->loc( + "Tickets [_1] [_2]", + $self->loc( $args{'TYPE'} ), + $args{'BASE'}, + ), + OPERATOR => $args{'OPERATOR'}, + ); +} + + +sub LimitMemberOf { + my $self = shift; + my $ticket_id = shift; + return $self->LimitLinkedTo( + @_, + TARGET => $ticket_id, + TYPE => 'MemberOf', + ); +} + + +sub LimitHasMember { + my $self = shift; + my $ticket_id = shift; + return $self->LimitLinkedFrom( + @_, + BASE => "$ticket_id", + TYPE => 'HasMember', + ); + +} + + + +sub LimitDependsOn { + my $self = shift; + my $ticket_id = shift; + return $self->LimitLinkedTo( + @_, + TARGET => $ticket_id, + TYPE => 'DependsOn', + ); + +} + + + +sub LimitDependedOnBy { + my $self = shift; + my $ticket_id = shift; + return $self->LimitLinkedFrom( + @_, + BASE => $ticket_id, + TYPE => 'DependentOn', + ); + +} + + + +sub LimitRefersTo { + my $self = shift; + my $ticket_id = shift; + return $self->LimitLinkedTo( + @_, + TARGET => $ticket_id, + TYPE => 'RefersTo', + ); + +} + + + +sub LimitReferredToBy { + my $self = shift; + my $ticket_id = shift; + return $self->LimitLinkedFrom( + @_, + BASE => $ticket_id, + TYPE => 'ReferredToBy', + ); +} + + + + + +=head2 LimitDate (FIELD => 'DateField', OPERATOR => $oper, VALUE => $ISODate) + +Takes a paramhash with the fields FIELD OPERATOR and VALUE. + +OPERATOR is one of > or < +VALUE is a date and time in ISO format in GMT +FIELD is one of Starts, Started, Told, Created, Resolved, LastUpdated + +There are also helper functions of the form LimitFIELD that eliminate +the need to pass in a FIELD argument. + +=cut + +sub LimitDate { + my $self = shift; + my %args = ( + FIELD => undef, + VALUE => undef, + OPERATOR => undef, + + @_ + ); + + #Set the description if we didn't get handed it above + unless ( $args{'DESCRIPTION'} ) { + $args{'DESCRIPTION'} = $args{'FIELD'} . " " + . $args{'OPERATOR'} . " " + . $args{'VALUE'} . " GMT"; + } + + $self->Limit(%args); + +} + + +sub LimitCreated { + my $self = shift; + $self->LimitDate( FIELD => 'Created', @_ ); +} + +sub LimitDue { + my $self = shift; + $self->LimitDate( FIELD => 'Due', @_ ); + +} + +sub LimitStarts { + my $self = shift; + $self->LimitDate( FIELD => 'Starts', @_ ); + +} + +sub LimitStarted { + my $self = shift; + $self->LimitDate( FIELD => 'Started', @_ ); +} + +sub LimitResolved { + my $self = shift; + $self->LimitDate( FIELD => 'Resolved', @_ ); +} + +sub LimitTold { + my $self = shift; + $self->LimitDate( FIELD => 'Told', @_ ); +} + +sub LimitLastUpdated { + my $self = shift; + $self->LimitDate( FIELD => 'LastUpdated', @_ ); +} + +# + +=head2 LimitTransactionDate (OPERATOR => $oper, VALUE => $ISODate) + +Takes a paramhash with the fields FIELD OPERATOR and VALUE. + +OPERATOR is one of > or < +VALUE is a date and time in ISO format in GMT + + +=cut + +sub LimitTransactionDate { + my $self = shift; + my %args = ( + FIELD => 'TransactionDate', + VALUE => undef, + OPERATOR => undef, + + @_ + ); + + # <20021217042756.GK28744@pallas.fsck.com> + # "Kill It" - Jesse. + + #Set the description if we didn't get handed it above + unless ( $args{'DESCRIPTION'} ) { + $args{'DESCRIPTION'} = $args{'FIELD'} . " " + . $args{'OPERATOR'} . " " + . $args{'VALUE'} . " GMT"; + } + + $self->Limit(%args); + +} + + + + +=head2 LimitCustomField + +Takes a paramhash of key/value pairs with the following keys: + +=over 4 + +=item CUSTOMFIELD - CustomField name or id. If a name is passed, an additional parameter QUEUE may also be passed to distinguish the custom field. + +=item OPERATOR - The usual Limit operators + +=item VALUE - The value to compare against + +=back + +=cut + +sub LimitCustomField { + my $self = shift; + my %args = ( + VALUE => undef, + CUSTOMFIELD => undef, + OPERATOR => '=', + DESCRIPTION => undef, + FIELD => 'CustomFieldValue', + QUOTEVALUE => 1, + @_ + ); + + my $CF = RT::CustomField->new( $self->CurrentUser ); + if ( $args{CUSTOMFIELD} =~ /^\d+$/ ) { + $CF->Load( $args{CUSTOMFIELD} ); + } + else { + $CF->LoadByNameAndQueue( + Name => $args{CUSTOMFIELD}, + Queue => $args{QUEUE} + ); + $args{CUSTOMFIELD} = $CF->Id; + } + + #If we are looking to compare with a null value. + if ( $args{'OPERATOR'} =~ /^is$/i ) { + $args{'DESCRIPTION'} + ||= $self->loc( "Custom field [_1] has no value.", $CF->Name ); + } + elsif ( $args{'OPERATOR'} =~ /^is not$/i ) { + $args{'DESCRIPTION'} + ||= $self->loc( "Custom field [_1] has a value.", $CF->Name ); + } + + # if we're not looking to compare with a null value + else { + $args{'DESCRIPTION'} ||= $self->loc( "Custom field [_1] [_2] [_3]", + $CF->Name, $args{OPERATOR}, $args{VALUE} ); + } + + if ( defined $args{'QUEUE'} && $args{'QUEUE'} =~ /\D/ ) { + my $QueueObj = RT::Queue->new( $self->CurrentUser ); + $QueueObj->Load( $args{'QUEUE'} ); + $args{'QUEUE'} = $QueueObj->Id; + } + delete $args{'QUEUE'} unless defined $args{'QUEUE'} && length $args{'QUEUE'}; + + my @rest; + @rest = ( ENTRYAGGREGATOR => 'AND' ) + if ( $CF->Type eq 'SelectMultiple' ); + + $self->Limit( + VALUE => $args{VALUE}, + FIELD => "CF" + .(defined $args{'QUEUE'}? ".$args{'QUEUE'}" : '' ) + .".{" . $CF->Name . "}", + OPERATOR => $args{OPERATOR}, + CUSTOMFIELD => 1, + @rest, + ); + + $self->{'RecalcTicketLimits'} = 1; +} + + + +=head2 _NextIndex + +Keep track of the counter for the array of restrictions + +=cut + +sub _NextIndex { + my $self = shift; + return ( $self->{'restriction_index'}++ ); +} + + + + +sub _Init { + my $self = shift; + $self->{'table'} = "Tickets"; + $self->{'RecalcTicketLimits'} = 1; + $self->{'looking_at_effective_id'} = 0; + $self->{'looking_at_type'} = 0; + $self->{'restriction_index'} = 1; + $self->{'primary_key'} = "id"; + delete $self->{'items_array'}; + delete $self->{'item_map'}; + delete $self->{'columns_to_display'}; + $self->SUPER::_Init(@_); + + $self->_InitSQL; + +} + + +sub Count { + my $self = shift; + $self->_ProcessRestrictions() if ( $self->{'RecalcTicketLimits'} == 1 ); + return ( $self->SUPER::Count() ); +} + + +sub CountAll { + my $self = shift; + $self->_ProcessRestrictions() if ( $self->{'RecalcTicketLimits'} == 1 ); + return ( $self->SUPER::CountAll() ); +} + + + +=head2 ItemsArrayRef + +Returns a reference to the set of all items found in this search + +=cut + +sub ItemsArrayRef { + my $self = shift; + + return $self->{'items_array'} if $self->{'items_array'}; + + my $placeholder = $self->_ItemsCounter; + $self->GotoFirstItem(); + while ( my $item = $self->Next ) { + push( @{ $self->{'items_array'} }, $item ); + } + $self->GotoItem($placeholder); + $self->{'items_array'} + = $self->ItemsOrderBy( $self->{'items_array'} ); + + return $self->{'items_array'}; +} + +sub ItemsArrayRefWindow { + my $self = shift; + my $window = shift; + + my @old = ($self->_ItemsCounter, $self->RowsPerPage, $self->FirstRow+1); + + $self->RowsPerPage( $window ); + $self->FirstRow(1); + $self->GotoFirstItem; + + my @res; + while ( my $item = $self->Next ) { + push @res, $item; + } + + $self->RowsPerPage( $old[1] ); + $self->FirstRow( $old[2] ); + $self->GotoItem( $old[0] ); + + return \@res; +} + + +sub Next { + my $self = shift; + + $self->_ProcessRestrictions() if ( $self->{'RecalcTicketLimits'} == 1 ); + + my $Ticket = $self->SUPER::Next; + return $Ticket unless $Ticket; + + if ( $Ticket->__Value('Status') eq 'deleted' + && !$self->{'allow_deleted_search'} ) + { + return $self->Next; + } + elsif ( RT->Config->Get('UseSQLForACLChecks') ) { + # if we found a ticket with this option enabled then + # all tickets we found are ACLed, cache this fact + my $key = join ";:;", $self->CurrentUser->id, 'ShowTicket', 'RT::Ticket-'. $Ticket->id; + $RT::Principal::_ACL_CACHE->set( $key => 1 ); + return $Ticket; + } + elsif ( $Ticket->CurrentUserHasRight('ShowTicket') ) { + # has rights + return $Ticket; + } + else { + # If the user doesn't have the right to show this ticket + return $self->Next; + } +} + +sub _DoSearch { + my $self = shift; + $self->CurrentUserCanSee if RT->Config->Get('UseSQLForACLChecks'); + return $self->SUPER::_DoSearch( @_ ); +} + +sub _DoCount { + my $self = shift; + $self->CurrentUserCanSee if RT->Config->Get('UseSQLForACLChecks'); + return $self->SUPER::_DoCount( @_ ); +} + +sub _RolesCanSee { + my $self = shift; + + my $cache_key = 'RolesHasRight;:;ShowTicket'; + + if ( my $cached = $RT::Principal::_ACL_CACHE->fetch( $cache_key ) ) { + return %$cached; + } + + my $ACL = RT::ACL->new( RT->SystemUser ); + $ACL->Limit( FIELD => 'RightName', VALUE => 'ShowTicket' ); + $ACL->Limit( FIELD => 'PrincipalType', OPERATOR => '!=', VALUE => 'Group' ); + my $principal_alias = $ACL->Join( + ALIAS1 => 'main', + FIELD1 => 'PrincipalId', + TABLE2 => 'Principals', + FIELD2 => 'id', + ); + $ACL->Limit( ALIAS => $principal_alias, FIELD => 'Disabled', VALUE => 0 ); + + my %res = (); + foreach my $ACE ( @{ $ACL->ItemsArrayRef } ) { + my $role = $ACE->__Value('PrincipalType'); + my $type = $ACE->__Value('ObjectType'); + if ( $type eq 'RT::System' ) { + $res{ $role } = 1; + } + elsif ( $type eq 'RT::Queue' ) { + next if $res{ $role } && !ref $res{ $role }; + push @{ $res{ $role } ||= [] }, $ACE->__Value('ObjectId'); + } + else { + $RT::Logger->error('ShowTicket right is granted on unsupported object'); + } + } + $RT::Principal::_ACL_CACHE->set( $cache_key => \%res ); + return %res; +} + +sub _DirectlyCanSeeIn { + my $self = shift; + my $id = $self->CurrentUser->id; + + my $cache_key = 'User-'. $id .';:;ShowTicket;:;DirectlyCanSeeIn'; + if ( my $cached = $RT::Principal::_ACL_CACHE->fetch( $cache_key ) ) { + return @$cached; + } + + my $ACL = RT::ACL->new( RT->SystemUser ); + $ACL->Limit( FIELD => 'RightName', VALUE => 'ShowTicket' ); + my $principal_alias = $ACL->Join( + ALIAS1 => 'main', + FIELD1 => 'PrincipalId', + TABLE2 => 'Principals', + FIELD2 => 'id', + ); + $ACL->Limit( ALIAS => $principal_alias, FIELD => 'Disabled', VALUE => 0 ); + my $cgm_alias = $ACL->Join( + ALIAS1 => 'main', + FIELD1 => 'PrincipalId', + TABLE2 => 'CachedGroupMembers', + FIELD2 => 'GroupId', + ); + $ACL->Limit( ALIAS => $cgm_alias, FIELD => 'MemberId', VALUE => $id ); + $ACL->Limit( ALIAS => $cgm_alias, FIELD => 'Disabled', VALUE => 0 ); + + my @res = (); + foreach my $ACE ( @{ $ACL->ItemsArrayRef } ) { + my $type = $ACE->__Value('ObjectType'); + if ( $type eq 'RT::System' ) { + # If user is direct member of a group that has the right + # on the system then he can see any ticket + $RT::Principal::_ACL_CACHE->set( $cache_key => [-1] ); + return (-1); + } + elsif ( $type eq 'RT::Queue' ) { + push @res, $ACE->__Value('ObjectId'); + } + else { + $RT::Logger->error('ShowTicket right is granted on unsupported object'); + } + } + $RT::Principal::_ACL_CACHE->set( $cache_key => \@res ); + return @res; +} + +sub CurrentUserCanSee { + my $self = shift; + return if $self->{'_sql_current_user_can_see_applied'}; + + return $self->{'_sql_current_user_can_see_applied'} = 1 + if $self->CurrentUser->UserObj->HasRight( + Right => 'SuperUser', Object => $RT::System + ); + + my $id = $self->CurrentUser->id; + + # directly can see in all queues then we have nothing to do + my @direct_queues = $self->_DirectlyCanSeeIn; + return $self->{'_sql_current_user_can_see_applied'} = 1 + if @direct_queues && $direct_queues[0] == -1; + + my %roles = $self->_RolesCanSee; + { + my %skip = map { $_ => 1 } @direct_queues; + foreach my $role ( keys %roles ) { + next unless ref $roles{ $role }; + + my @queues = grep !$skip{$_}, @{ $roles{ $role } }; + if ( @queues ) { + $roles{ $role } = \@queues; + } else { + delete $roles{ $role }; + } + } + } + +# there is no global watchers, only queues and tickes, if at +# some point we will add global roles then it's gonna blow +# the idea here is that if the right is set globaly for a role +# and user plays this role for a queue directly not a ticket +# then we have to check in advance + if ( my @tmp = grep $_ ne 'Owner' && !ref $roles{ $_ }, keys %roles ) { + + my $groups = RT::Groups->new( RT->SystemUser ); + $groups->Limit( FIELD => 'Domain', VALUE => 'RT::Queue-Role' ); + foreach ( @tmp ) { + $groups->Limit( FIELD => 'Type', VALUE => $_ ); + } + my $principal_alias = $groups->Join( + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'Principals', + FIELD2 => 'id', + ); + $groups->Limit( ALIAS => $principal_alias, FIELD => 'Disabled', VALUE => 0 ); + my $cgm_alias = $groups->Join( + ALIAS1 => 'main', + FIELD1 => 'id', + TABLE2 => 'CachedGroupMembers', + FIELD2 => 'GroupId', + ); + $groups->Limit( ALIAS => $cgm_alias, FIELD => 'MemberId', VALUE => $id ); + $groups->Limit( ALIAS => $cgm_alias, FIELD => 'Disabled', VALUE => 0 ); + while ( my $group = $groups->Next ) { + push @direct_queues, $group->Instance; + } + } + + unless ( @direct_queues || keys %roles ) { + $self->SUPER::Limit( + SUBCLAUSE => 'ACL', + ALIAS => 'main', + FIELD => 'id', + VALUE => 0, + ENTRYAGGREGATOR => 'AND', + ); + return $self->{'_sql_current_user_can_see_applied'} = 1; + } + + { + my $join_roles = keys %roles; + $join_roles = 0 if $join_roles == 1 && $roles{'Owner'}; + my ($role_group_alias, $cgm_alias); + if ( $join_roles ) { + $role_group_alias = $self->_RoleGroupsJoin( New => 1 ); + $cgm_alias = $self->_GroupMembersJoin( GroupsAlias => $role_group_alias ); + $self->SUPER::Limit( + LEFTJOIN => $cgm_alias, + FIELD => 'MemberId', + OPERATOR => '=', + VALUE => $id, + ); + } + my $limit_queues = sub { + my $ea = shift; + my @queues = @_; + + return unless @queues; + if ( @queues == 1 ) { + $self->SUPER::Limit( + SUBCLAUSE => 'ACL', + ALIAS => 'main', + FIELD => 'Queue', + VALUE => $_[0], + ENTRYAGGREGATOR => $ea, + ); + } else { + $self->SUPER::_OpenParen('ACL'); + foreach my $q ( @queues ) { + $self->SUPER::Limit( + SUBCLAUSE => 'ACL', + ALIAS => 'main', + FIELD => 'Queue', + VALUE => $q, + ENTRYAGGREGATOR => $ea, + ); + $ea = 'OR'; + } + $self->SUPER::_CloseParen('ACL'); + } + return 1; + }; + + $self->SUPER::_OpenParen('ACL'); + my $ea = 'AND'; + $ea = 'OR' if $limit_queues->( $ea, @direct_queues ); + while ( my ($role, $queues) = each %roles ) { + $self->SUPER::_OpenParen('ACL'); + if ( $role eq 'Owner' ) { + $self->SUPER::Limit( + SUBCLAUSE => 'ACL', + FIELD => 'Owner', + VALUE => $id, + ENTRYAGGREGATOR => $ea, + ); + } + else { + $self->SUPER::Limit( + SUBCLAUSE => 'ACL', + ALIAS => $cgm_alias, + FIELD => 'MemberId', + OPERATOR => 'IS NOT', + VALUE => 'NULL', + QUOTEVALUE => 0, + ENTRYAGGREGATOR => $ea, + ); + $self->SUPER::Limit( + SUBCLAUSE => 'ACL', + ALIAS => $role_group_alias, + FIELD => 'Type', + VALUE => $role, + ENTRYAGGREGATOR => 'AND', + ); + } + $limit_queues->( 'AND', @$queues ) if ref $queues; + $ea = 'OR' if $ea eq 'AND'; + $self->SUPER::_CloseParen('ACL'); + } + $self->SUPER::_CloseParen('ACL'); + } + return $self->{'_sql_current_user_can_see_applied'} = 1; +} + + + + + +=head2 LoadRestrictions + +LoadRestrictions takes a string which can fully populate the TicketRestrictons hash. +TODO It is not yet implemented + +=cut + + + +=head2 DescribeRestrictions + +takes nothing. +Returns a hash keyed by restriction id. +Each element of the hash is currently a one element hash that contains DESCRIPTION which +is a description of the purpose of that TicketRestriction + +=cut + +sub DescribeRestrictions { + my $self = shift; + + my %listing; + + foreach my $row ( keys %{ $self->{'TicketRestrictions'} } ) { + $listing{$row} = $self->{'TicketRestrictions'}{$row}{'DESCRIPTION'}; + } + return (%listing); +} + + + +=head2 RestrictionValues FIELD + +Takes a restriction field and returns a list of values this field is restricted +to. + +=cut + +sub RestrictionValues { + my $self = shift; + my $field = shift; + map $self->{'TicketRestrictions'}{$_}{'VALUE'}, grep { + $self->{'TicketRestrictions'}{$_}{'FIELD'} eq $field + && $self->{'TicketRestrictions'}{$_}{'OPERATOR'} eq "=" + } + keys %{ $self->{'TicketRestrictions'} }; +} + + + +=head2 ClearRestrictions + +Removes all restrictions irretrievably + +=cut + +sub ClearRestrictions { + my $self = shift; + delete $self->{'TicketRestrictions'}; + $self->{'looking_at_effective_id'} = 0; + $self->{'looking_at_type'} = 0; + $self->{'RecalcTicketLimits'} = 1; +} + + + +=head2 DeleteRestriction + +Takes the row Id of a restriction (From DescribeRestrictions' output, for example. +Removes that restriction from the session's limits. + +=cut + +sub DeleteRestriction { + my $self = shift; + my $row = shift; + delete $self->{'TicketRestrictions'}{$row}; + + $self->{'RecalcTicketLimits'} = 1; + + #make the underlying easysearch object forget all its preconceptions +} + + + +# Convert a set of oldstyle SB Restrictions to Clauses for RQL + +sub _RestrictionsToClauses { + my $self = shift; + + my %clause; + foreach my $row ( keys %{ $self->{'TicketRestrictions'} } ) { + my $restriction = $self->{'TicketRestrictions'}{$row}; + + # We need to reimplement the subclause aggregation that SearchBuilder does. + # Default Subclause is ALIAS.FIELD, and default ALIAS is 'main', + # Then SB AND's the different Subclauses together. + + # So, we want to group things into Subclauses, convert them to + # SQL, and then join them with the appropriate DefaultEA. + # Then join each subclause group with AND. + + my $field = $restriction->{'FIELD'}; + my $realfield = $field; # CustomFields fake up a fieldname, so + # we need to figure that out + + # One special case + # Rewrite LinkedTo meta field to the real field + if ( $field =~ /LinkedTo/ ) { + $realfield = $field = $restriction->{'TYPE'}; + } + + # Two special case + # Handle subkey fields with a different real field + if ( $field =~ /^(\w+)\./ ) { + $realfield = $1; + } + + die "I don't know about $field yet" + unless ( exists $FIELD_METADATA{$realfield} + or $restriction->{CUSTOMFIELD} ); + + my $type = $FIELD_METADATA{$realfield}->[0]; + my $op = $restriction->{'OPERATOR'}; + + my $value = ( + grep {defined} + map { $restriction->{$_} } qw(VALUE TICKET BASE TARGET) + )[0]; + + # this performs the moral equivalent of defined or/dor/C<//>, + # without the short circuiting.You need to use a 'defined or' + # type thing instead of just checking for truth values, because + # VALUE could be 0.(i.e. "false") + + # You could also use this, but I find it less aesthetic: + # (although it does short circuit) + #( defined $restriction->{'VALUE'}? $restriction->{VALUE} : + # defined $restriction->{'TICKET'} ? + # $restriction->{TICKET} : + # defined $restriction->{'BASE'} ? + # $restriction->{BASE} : + # defined $restriction->{'TARGET'} ? + # $restriction->{TARGET} ) + + my $ea = $restriction->{ENTRYAGGREGATOR} + || $DefaultEA{$type} + || "AND"; + if ( ref $ea ) { + die "Invalid operator $op for $field ($type)" + unless exists $ea->{$op}; + $ea = $ea->{$op}; + } + + # Each CustomField should be put into a different Clause so they + # are ANDed together. + if ( $restriction->{CUSTOMFIELD} ) { + $realfield = $field; + } + + exists $clause{$realfield} or $clause{$realfield} = []; + + # Escape Quotes + $field =~ s!(['\\])!\\$1!g; + $value =~ s!(['\\])!\\$1!g; + my $data = [ $ea, $type, $field, $op, $value ]; + + # here is where we store extra data, say if it's a keyword or + # something. (I.e. "TYPE SPECIFIC STUFF") + + if (lc $ea eq 'none') { + $clause{$realfield} = [ $data ]; + } else { + push @{ $clause{$realfield} }, $data; + } + } + return \%clause; +} + + + +=head2 _ProcessRestrictions PARAMHASH + +# The new _ProcessRestrictions is somewhat dependent on the SQL stuff, +# but isn't quite generic enough to move into Tickets_SQL. + +=cut + +sub _ProcessRestrictions { + my $self = shift; + + #Blow away ticket aliases since we'll need to regenerate them for + #a new search + delete $self->{'TicketAliases'}; + delete $self->{'items_array'}; + delete $self->{'item_map'}; + delete $self->{'raw_rows'}; + delete $self->{'rows'}; + delete $self->{'count_all'}; + + my $sql = $self->Query; # Violating the _SQL namespace + if ( !$sql || $self->{'RecalcTicketLimits'} ) { + + # "Restrictions to Clauses Branch\n"; + my $clauseRef = eval { $self->_RestrictionsToClauses; }; + if ($@) { + $RT::Logger->error( "RestrictionsToClauses: " . $@ ); + $self->FromSQL(""); + } + else { + $sql = $self->ClausesToSQL($clauseRef); + $self->FromSQL($sql) if $sql; + } + } + + $self->{'RecalcTicketLimits'} = 0; + +} + +=head2 _BuildItemMap + +Build up a L</ItemMap> of first/last/next/prev items, so that we can +display search nav quickly. + +=cut + +sub _BuildItemMap { + my $self = shift; + + my $window = RT->Config->Get('TicketsItemMapSize'); + + $self->{'item_map'} = {}; + + my $items = $self->ItemsArrayRefWindow( $window ); + return unless $items && @$items; + + my $prev = 0; + $self->{'item_map'}{'first'} = $items->[0]->EffectiveId; + for ( my $i = 0; $i < @$items; $i++ ) { + my $item = $items->[$i]; + my $id = $item->EffectiveId; + $self->{'item_map'}{$id}{'defined'} = 1; + $self->{'item_map'}{$id}{'prev'} = $prev; + $self->{'item_map'}{$id}{'next'} = $items->[$i+1]->EffectiveId + if $items->[$i+1]; + $prev = $id; + } + $self->{'item_map'}{'last'} = $prev + if !$window || @$items < $window; +} + +=head2 ItemMap + +Returns an a map of all items found by this search. The map is a hash +of the form: + + { + first => <first ticket id found>, + last => <last ticket id found or undef>, + + <ticket id> => { + prev => <the ticket id found before>, + next => <the ticket id found after>, + }, + <ticket id> => { + prev => ..., + next => ..., + }, + } + +=cut + +sub ItemMap { + my $self = shift; + $self->_BuildItemMap unless $self->{'item_map'}; + return $self->{'item_map'}; +} + + + + +=head2 PrepForSerialization + +You don't want to serialize a big tickets object, as +the {items} hash will be instantly invalid _and_ eat +lots of space + +=cut + +sub PrepForSerialization { + my $self = shift; + delete $self->{'items'}; + delete $self->{'items_array'}; + $self->RedoSearch(); +} + +=head1 FLAGS + +RT::Tickets supports several flags which alter search behavior: + + +allow_deleted_search (Otherwise never show deleted tickets in search results) +looking_at_type (otherwise limit to type=ticket) + +These flags are set by calling + +$tickets->{'flagname'} = 1; + +BUG: There should be an API for this + + + +=cut + + + +=head2 NewItem + +Returns an empty new RT::Ticket item + +=cut + +sub NewItem { + my $self = shift; + return(RT::Ticket->new($self->CurrentUser)); +} +RT::Base->_ImportOverlays(); + +1; diff --git a/rt/lib/RT/User.pm b/rt/lib/RT/User.pm index af4a6ad99..0094f9807 100755 --- a/rt/lib/RT/User.pm +++ b/rt/lib/RT/User.pm @@ -81,7 +81,6 @@ use Digest::MD5; use RT::Principals; use RT::ACE; use RT::Interface::Email; -use Encode; use Text::Password::Pronounceable; sub _OverlayAccessible { @@ -102,7 +101,6 @@ sub _OverlayAccessible { AuthSystem => { public => 1, admin => 1 }, Gecos => { public => 1, admin => 1 }, PGPKey => { public => 1, admin => 1 }, - PrivateKey => { admin => 1 }, } } @@ -880,7 +878,7 @@ sub _GeneratePassword_sha512 { my $sha = Digest::SHA->new(512); $sha->add($salt); - $sha->add(encode_utf8($password)); + $sha->add(Encode::encode( 'UTF-8', $password)); return join("!", "", "sha512", $salt, $sha->b64digest); } @@ -957,16 +955,16 @@ sub IsPassword { my $hash = MIME::Base64::decode_base64($stored); # Decoding yields 30 byes; first 4 are the salt, the rest are substr(SHA256,0,26) my $salt = substr($hash, 0, 4, ""); - return 0 unless substr(Digest::SHA::sha256($salt . Digest::MD5::md5(encode_utf8($value))), 0, 26) eq $hash; + return 0 unless substr(Digest::SHA::sha256($salt . Digest::MD5::md5(Encode::encode( "UTF-8", $value))), 0, 26) eq $hash; } elsif (length $stored == 32) { # Hex nonsalted-md5 - return 0 unless Digest::MD5::md5_hex(encode_utf8($value)) eq $stored; + return 0 unless Digest::MD5::md5_hex(Encode::encode( "UTF-8", $value)) eq $stored; } elsif (length $stored == 22) { # Base64 nonsalted-md5 - return 0 unless Digest::MD5::md5_base64(encode_utf8($value)) eq $stored; + return 0 unless Digest::MD5::md5_base64(Encode::encode( "UTF-8", $value)) eq $stored; } elsif (length $stored == 13) { # crypt() output - return 0 unless crypt(encode_utf8($value), $stored) eq $stored; + return 0 unless crypt(Encode::encode( "UTF-8", $value), $stored) eq $stored; } else { $RT::Logger->warning("Unknown password form"); return 0; @@ -1055,8 +1053,7 @@ sub GenerateAuthString { my $self = shift; my $protect = shift; - my $str = $self->AuthToken . $protect; - utf8::encode($str); + my $str = Encode::encode( "UTF-8", $self->AuthToken . $protect ); return substr(Digest::MD5::md5_hex($str),0,16); } @@ -1073,8 +1070,7 @@ sub ValidateAuthString { my $auth_string = shift; my $protected = shift; - my $str = $self->AuthToken . $protected; - utf8::encode( $str ); + my $str = Encode::encode( "UTF-8", $self->AuthToken . $protected ); return $auth_string eq substr(Digest::MD5::md5_hex($str),0,16); } @@ -1346,10 +1342,8 @@ sub Preferences { my $name = _PrefName (shift); my $default = shift; - my $attr = RT::Attribute->new( $self->CurrentUser ); - $attr->LoadByNameAndObject( Object => $self, Name => $name ); - - my $content = $attr->Id ? $attr->Content : undef; + my ($attr) = $self->Attributes->Named( $name ); + my $content = $attr ? $attr->Content : undef; unless ( ref $content eq 'HASH' ) { return defined $content ? $content : $default; } @@ -1378,9 +1372,8 @@ sub SetPreferences { return (0, $self->loc("No permission to set preferences")) unless $self->CurrentUserCanModify('Preferences'); - my $attr = RT::Attribute->new( $self->CurrentUser ); - $attr->LoadByNameAndObject( Object => $self, Name => $name ); - if ( $attr->Id ) { + my ($attr) = $self->Attributes->Named( $name ); + if ( $attr ) { my ($ok, $msg) = $attr->SetContent( $value ); return (1, "No updates made") if $msg eq "That is already the current value"; @@ -1403,13 +1396,11 @@ sub DeletePreferences { return (0, $self->loc("No permission to set preferences")) unless $self->CurrentUserCanModify('Preferences'); - my $attr = RT::Attribute->new( $self->CurrentUser ); - $attr->LoadByNameAndObject( Object => $self, Name => $name ); - if ( $attr->Id ) { - return $attr->Delete; - } + my ($attr) = $self->DeleteAttribute( $name ); + return (0, $self->loc("Preferences were not found")) + unless $attr; - return (0, $self->loc("Preferences were not found")); + return 1; } =head2 Stylesheet @@ -1652,7 +1643,8 @@ sub SetPrivateKey { my $self = shift; my $key = shift; - unless ($self->CurrentUserCanModify('PrivateKey')) { + # Users should not be able to change their own PrivateKey values + unless ( $self->CurrentUser->HasRight(Right => 'AdminUsers', Object => $RT::System) ) { return (0, $self->loc("Permission Denied")); } diff --git a/rt/lib/RT/Util.pm b/rt/lib/RT/Util.pm index 9720f1da8..f8ffccfb9 100644 --- a/rt/lib/RT/Util.pm +++ b/rt/lib/RT/Util.pm @@ -125,7 +125,7 @@ sub mime_recommended_filename { $head = $head->head if $head->isa('MIME::Entity'); for my $attr_name (qw( content-disposition.filename content-type.name )) { - my $value = $head->mime_attr($attr_name); + my $value = Encode::decode("UTF-8",$head->mime_attr($attr_name)); if ( defined $value && $value =~ /\S/ ) { return $value; } @@ -133,6 +133,23 @@ sub mime_recommended_filename { return; } +sub assert_bytes { + my $string = shift; + return unless utf8::is_utf8($string); + return unless $string =~ /([^\x00-\x7F])/; + + my $msg; + if (ord($1) > 255) { + $msg = "Expecting a byte string, but was passed characters"; + } else { + $msg = "Expecting a byte string, but was possibly passed charcters;" + ." if the string is actually bytes, please use utf8::downgrade"; + } + $RT::Logger->warn($msg, Carp::longmess()); + +} + + RT::Base->_ImportOverlays(); 1; diff --git a/rt/lib/RTx/.Calendar.pm.swp b/rt/lib/RTx/.Calendar.pm.swp Binary files differnew file mode 100644 index 000000000..444c2f509 --- /dev/null +++ b/rt/lib/RTx/.Calendar.pm.swp diff --git a/rt/lib/RTx/.Schedule.pm.swp b/rt/lib/RTx/.Schedule.pm.swp Binary files differnew file mode 100644 index 000000000..5fb7a01c3 --- /dev/null +++ b/rt/lib/RTx/.Schedule.pm.swp |