1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
6 # <jesse@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 # General Public License for more details.
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
30 # CONTRIBUTION SUBMISSION POLICY:
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
47 # END BPS TAGGED BLOCK }}}
49 ## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
51 ## This is a library of static subs to be used by the Mason web
64 package RT::Interface::Web;
66 use RT::SavedSearches;
68 use RT::Interface::Web::Session;
74 =head2 EscapeUTF8 SCALARREF
76 does a css-busting but minimalist escaping of whatever html you're passing in.
82 return unless defined $$ref;
87 $$ref =~ s/\(/(/g;
88 $$ref =~ s/\)/)/g;
97 =head2 EscapeURI SCALARREF
99 Escapes URI component according to RFC2396
105 return unless defined $$ref;
108 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
113 # {{{ WebCanonicalizeInfo
115 =head2 WebCanonicalizeInfo();
117 Different web servers set different environmental varibles. This
118 function must return something suitable for REMOTE_USER. By default,
119 just downcase $ENV{'REMOTE_USER'}
123 sub WebCanonicalizeInfo {
124 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
129 # {{{ WebExternalAutoInfo
131 =head2 WebExternalAutoInfo($user);
133 Returns a hash of user attributes, used when WebExternalAuto is set.
137 sub WebExternalAutoInfo {
142 # default to making Privileged users, even if they specify
143 # some other default Attributes
144 if ( !$RT::AutoCreate
145 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
147 $user_info{'Privileged'} = 1;
150 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
152 # Populate fields with information from Unix /etc/passwd
154 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
155 $user_info{'Comments'} = $comments if defined $comments;
156 $user_info{'RealName'} = $realname if defined $realname;
157 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
159 # Populate fields with information from NT domain controller
162 # and return the wad of stuff
171 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
173 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
175 # Roll back any dangling transactions from a previous failed connection
176 $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth;
178 MaybeEnableSQLStatementLog();
180 # avoid reentrancy, as suggested by masonbook
181 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
183 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
184 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
187 PreprocessTimeUpdates($ARGS);
189 MaybeShowInstallModePage();
191 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
193 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
195 MaybeShowNoAuthPage($ARGS);
197 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
199 _ForceLogout() unless _UserLoggedIn();
201 # Process per-page authentication callbacks
202 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
204 unless ( _UserLoggedIn() ) {
207 # If the user is logging in, let's authenticate
208 if ( defined $ARGS->{user} && defined $ARGS->{pass} ) {
209 AttemptPasswordAuthentication($ARGS);
211 # if no credentials then show him login page
212 $HTML::Mason::Commands::m->comp( '/Elements/Login', %$ARGS );
213 $HTML::Mason::Commands::m->abort;
217 # now it applies not only to home page, but any dashboard that can be used as a workspace
218 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
219 if ( $ARGS->{'HomeRefreshInterval'} );
221 # Process per-page global callbacks
222 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
224 ShowRequestedPage($ARGS);
225 LogRecordedSQLStatements();
230 delete $HTML::Mason::Commands::session{'CurrentUser'};
234 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
242 =head2 MaybeShowInstallModePage
244 This function, called exclusively by RT's autohandler, dispatches
245 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
247 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
251 sub MaybeShowInstallModePage {
252 return unless RT->InstallMode;
254 my $m = $HTML::Mason::Commands::m;
255 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
257 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
258 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
265 =head2 MaybeShowNoAuthPage \%ARGS
267 This function, called exclusively by RT's autohandler, dispatches
268 a request to the page a user requested (but only if it matches the "noauth" regex.
270 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
274 sub MaybeShowNoAuthPage {
277 my $m = $HTML::Mason::Commands::m;
279 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
281 # If it's a noauth file, don't ask for auth.
283 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
287 =head2 ShowRequestedPage \%ARGS
289 This function, called exclusively by RT's autohandler, dispatches
290 a request to the page a user requested (making sure that unpriviled users
291 can only see self-service pages.
295 sub ShowRequestedPage {
298 my $m = $HTML::Mason::Commands::m;
302 # If the user isn't privileged, they can only see SelfService
303 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
305 # if the user is trying to access a ticket, redirect them
306 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
307 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
310 # otherwise, drop the user at the SelfService default page
311 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
312 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
315 # if user is in SelfService dir let him do anything
317 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
320 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
325 sub AttemptExternalAuth {
328 return unless ( RT->Config->Get('WebExternalAuth') );
330 my $user = $ARGS->{user};
331 my $m = $HTML::Mason::Commands::m;
333 # If RT is configured for external auth, let's go through and get REMOTE_USER
335 # do we actually have a REMOTE_USER equivlent?
336 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
337 my $orig_user = $user;
339 $user = RT::Interface::Web::WebCanonicalizeInfo();
340 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
342 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
343 my $NodeName = Win32::NodeName();
344 $user =~ s/^\Q$NodeName\E\\//i;
347 InstantiateNewSession() unless _UserLoggedIn;
348 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
349 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
351 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
353 # Create users on-the-fly
354 my $UserObj = RT::User->new($RT::SystemUser);
355 my ( $val, $msg ) = $UserObj->Create(
356 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
363 # now get user specific information, to better create our user.
364 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
366 # set the attributes that have been defined.
367 foreach my $attribute ( $UserObj->WritableAttributes ) {
369 Attribute => $attribute,
371 UserInfo => $new_user_info,
372 CallbackName => 'NewUser',
373 CallbackPage => '/autohandler'
375 my $method = "Set$attribute";
376 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
378 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
381 # we failed to successfully create the user. abort abort abort.
382 delete $HTML::Mason::Commands::session{'CurrentUser'};
383 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc( 'Cannot create user: [_1]', $msg ) )
384 if RT->Config->Get('WebFallbackToInternalAuth');;
389 if ( _UserLoggedIn() ) {
390 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
392 delete $HTML::Mason::Commands::session{'CurrentUser'};
395 if ( RT->Config->Get('WebExternalOnly') ) {
396 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('You are not an authorized user') );
400 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
401 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
402 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
403 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('You are not an authorized user') );
408 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
409 # XXX: we must return AUTH_REQUIRED status or we fallback to
410 # internal auth here too.
411 delete $HTML::Mason::Commands::session{'CurrentUser'}
412 if defined $HTML::Mason::Commands::session{'CurrentUser'};
416 sub AttemptPasswordAuthentication {
418 my $user_obj = RT::CurrentUser->new();
419 $user_obj->Load( $ARGS->{user} );
421 my $m = $HTML::Mason::Commands::m;
423 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
424 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
425 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('Your username or password is incorrect'), );
426 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
430 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
431 InstantiateNewSession();
432 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
433 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
436 =head2 LoadSessionFromCookie
438 Load or setup a session cookie for the current user.
442 sub _SessionCookieName {
443 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
444 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
448 sub LoadSessionFromCookie {
450 my %cookies = CGI::Cookie->fetch;
451 my $cookiename = _SessionCookieName();
452 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
453 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
454 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
455 undef $cookies{$cookiename};
457 if ( int RT->Config->Get('AutoLogoff') ) {
458 my $now = int( time / 60 );
459 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
461 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
462 InstantiateNewSession();
465 # save session on each request when AutoLogoff is turned on
466 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
470 sub InstantiateNewSession {
471 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
472 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
475 sub SendSessionCookie {
476 my $cookie = CGI::Cookie->new(
477 -name => _SessionCookieName(),
478 -value => $HTML::Mason::Commands::session{_session_id},
479 -path => RT->Config->Get('WebPath'),
480 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 )
483 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
488 This routine ells the current user's browser to redirect to URL.
489 Additionally, it unties the user's currently active session, helping to avoid
490 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
491 a cached DBI statement handle twice at the same time.
496 my $redir_to = shift;
497 untie $HTML::Mason::Commands::session;
498 my $uri = URI->new($redir_to);
499 my $server_uri = URI->new( RT->Config->Get('WebURL') );
501 # If the user is coming in via a non-canonical
502 # hostname, don't redirect them to the canonical host,
503 # it will just upset them (and invalidate their credentials)
504 # don't do this if $RT::CanoniaclRedirectURLs is true
505 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
506 && $uri->host eq $server_uri->host
507 && $uri->port eq $server_uri->port )
509 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
510 $uri->scheme('https');
512 $uri->scheme('http');
515 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
516 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
517 $uri->port( $ENV{'SERVER_PORT'} );
520 # not sure why, but on some systems without this call mason doesn't
521 # set status to 302, but 200 instead and people see blank pages
522 $HTML::Mason::Commands::r->status(302);
524 # Perlbal expects a status message, but Mason's default redirect status
525 # doesn't provide one. See also rt.cpan.org #36689.
526 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
528 $HTML::Mason::Commands::m->abort;
531 =head2 StaticFileHeaders
533 Send the browser a few headers to try to get it to (somewhat agressively)
534 cache RT's static Javascript and CSS files.
536 This routine could really use _accurate_ heuristics. (XXX TODO)
540 sub StaticFileHeaders {
541 my $date = RT::Date->new($RT::SystemUser);
544 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
546 # Expire things in a month.
547 $date->Set( Value => time + 30 * 24 * 60 * 60 );
548 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
550 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
551 # request, but we don't handle it and generate full reply again
552 # Last modified at server start time
553 # $date->Set( Value => $^T );
554 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
559 Takes a C<< Path => path >> and returns a boolean indicating that
560 the path is safely within RT's control or not. The path I<must> be
563 This function does not consult the filesystem at all; it is merely
564 a logical sanity checking of the path. This explicitly does not handle
565 symlinks; if you have symlinks in RT's webroot pointing outside of it,
566 then we assume you know what you are doing.
573 my $path = $args{Path};
575 # Get File::Spec to clean up extra /s, ./, etc
576 my $cleaned_up = File::Spec->canonpath($path);
578 if (!defined($cleaned_up)) {
579 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
583 # Forbid too many ..s. We can't just sum then check because
584 # "../foo/bar/baz" should be illegal even though it has more
585 # downdirs than updirs. So as soon as we get a negative score
586 # (which means "breaking out" of the top level) we reject the path.
588 my @components = split '/', $cleaned_up;
590 for my $component (@components) {
591 if ($component eq '..') {
594 $RT::Logger->info("Rejecting unsafe path: $path");
598 elsif ($component eq '.' || $component eq '') {
599 # these two have no effect on $score
609 =head2 SendStaticFile
611 Takes a File => path and a Type => Content-type
613 If Type isn't provided and File is an image, it will
614 figure out a sane Content-type, otherwise it will
615 send application/octet-stream
617 Will set caching headers using StaticFileHeaders
624 my $file = $args{File};
625 my $type = $args{Type};
626 my $relfile = $args{RelativeFile};
628 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
629 $HTML::Mason::Commands::r->status(400);
630 $HTML::Mason::Commands::m->abort;
633 $self->StaticFileHeaders();
636 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
638 $type =~ s/jpg/jpeg/gi;
640 $type ||= "application/octet-stream";
642 $HTML::Mason::Commands::r->content_type($type);
643 open my $fh, "<$file" or die "couldn't open file: $!";
647 $HTML::Mason::Commands::m->out($_) while (<$fh>);
648 $HTML::Mason::Commands::m->flush_buffer;
655 my $content = $args{Content};
656 return '' unless $content;
658 # Make the content have no 'weird' newlines in it
659 $content =~ s/\r+\n/\n/g;
661 my $return_content = $content;
663 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
664 my $sigonly = $args{StripSignature};
666 # massage content to easily detect if there's any real content
667 $content =~ s/\s+//g; # yes! remove all the spaces
669 # remove html version of spaces and newlines
670 $content =~ s! !!g;
671 $content =~ s!<br/?>!!g;
674 # Filter empty content when type is text/html
675 return '' if $html && $content !~ /\S/;
677 # If we aren't supposed to strip the sig, just bail now.
678 return $return_content unless $sigonly;
681 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
684 # Check for plaintext sig
685 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
687 # Check for html-formatted sig
688 RT::Interface::Web::EscapeUTF8( \$sig );
691 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
694 return $return_content;
702 # if they've passed multiple values, they'll be an array. if they've
703 # passed just one, a scalar whatever they are, mark them as utf8
706 ? Encode::is_utf8($_)
708 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
709 : ( $type eq 'ARRAY' )
710 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
712 : ( $type eq 'HASH' )
713 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
719 sub PreprocessTimeUpdates {
722 # Later in the code we use
723 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
724 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
725 # The call_next method pass through original arguments and if you have
726 # an argument with unicode key then in a next component you'll get two
727 # records in the args hash: one with key without UTF8 flag and another
728 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
729 # is copied from mason's source to get the same results as we get from
730 # call_next method, this feature is not documented, so we just leave it
731 # here to avoid possible side effects.
733 # This code canonicalizes time inputs in hours into minutes
734 foreach my $field ( keys %$ARGS ) {
735 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
737 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
738 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
739 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
740 $ARGS->{$local} *= 60;
742 delete $ARGS->{$field};
747 sub MaybeEnableSQLStatementLog {
749 my $log_sql_statements = RT->Config->Get('StatementLog');
751 if ($log_sql_statements) {
752 $RT::Handle->ClearSQLStatementLog;
753 $RT::Handle->LogSQLStatements(1);
758 sub LogRecordedSQLStatements {
759 my $log_sql_statements = RT->Config->Get('StatementLog');
761 return unless ($log_sql_statements);
763 my @log = $RT::Handle->SQLStatementLog;
764 $RT::Handle->ClearSQLStatementLog;
765 for my $stmt (@log) {
766 my ( $time, $sql, $bind, $duration ) = @{$stmt};
776 level => $log_sql_statements,
778 . sprintf( "%.6f", $duration )
780 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
786 package HTML::Mason::Commands;
788 use vars qw/$r $m %session/;
794 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
795 with whatever it's called with. If there is no $session{'CurrentUser'},
796 it creates a temporary user, so we have something to get a localisation handle
803 if ( $session{'CurrentUser'}
804 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
806 return ( $session{'CurrentUser'}->loc(@_) );
809 RT::CurrentUser->new();
813 return ( $u->loc(@_) );
816 # pathetic case -- SystemUser is gone.
825 =head2 loc_fuzzy STRING
827 loc_fuzzy is for handling localizations of messages that may already
828 contain interpolated variables, typically returned from libraries
829 outside RT's control. It takes the message string and extracts the
830 variable array automatically by matching against the candidate entries
831 inside the lexicon file.
838 if ( $session{'CurrentUser'}
839 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
841 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
843 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
844 return ( $u->loc_fuzzy($msg) );
851 # Error - calls Error and aborts
856 if ( $session{'ErrorDocument'}
857 && $session{'ErrorDocumentType'} )
859 $r->content_type( $session{'ErrorDocumentType'} );
860 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
863 $m->comp( "/Elements/Error", Why => $why, %args );
870 # {{{ sub CreateTicket
872 =head2 CreateTicket ARGS
874 Create a new ticket, using Mason's %ARGS. returns @results.
883 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
885 my $Queue = new RT::Queue( $session{'CurrentUser'} );
886 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
887 Abort('Queue not found');
890 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
891 Abort('You have no permission to create tickets in that queue.');
895 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
896 $due = new RT::Date( $session{'CurrentUser'} );
897 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
900 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
901 $starts = new RT::Date( $session{'CurrentUser'} );
902 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
905 my $sigless = RT::Interface::Web::StripContent(
906 Content => $ARGS{Content},
907 ContentType => $ARGS{ContentType},
909 CurrentUser => $session{'CurrentUser'},
912 my $MIMEObj = MakeMIMEEntity(
913 Subject => $ARGS{'Subject'},
914 From => $ARGS{'From'},
917 Type => $ARGS{'ContentType'},
920 if ( $ARGS{'Attachments'} ) {
921 my $rv = $MIMEObj->make_multipart;
922 $RT::Logger->error("Couldn't make multipart message")
923 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
925 foreach ( values %{ $ARGS{'Attachments'} } ) {
927 $RT::Logger->error("Couldn't add empty attachemnt");
930 $MIMEObj->add_part($_);
934 foreach my $argument (qw(Encrypt Sign)) {
936 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
937 ) if defined $ARGS{$argument};
941 Type => $ARGS{'Type'} || 'ticket',
942 Queue => $ARGS{'Queue'},
943 Owner => $ARGS{'Owner'},
946 Requestor => $ARGS{'Requestors'},
948 AdminCc => $ARGS{'AdminCc'},
949 InitialPriority => $ARGS{'InitialPriority'},
950 FinalPriority => $ARGS{'FinalPriority'},
951 TimeLeft => $ARGS{'TimeLeft'},
952 TimeEstimated => $ARGS{'TimeEstimated'},
953 TimeWorked => $ARGS{'TimeWorked'},
954 Subject => $ARGS{'Subject'},
955 Status => $ARGS{'Status'},
956 Due => $due ? $due->ISO : undef,
957 Starts => $starts ? $starts->ISO : undef,
962 foreach my $type (qw(Requestor Cc AdminCc)) {
963 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
964 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
969 require RT::Action::SendEmail;
970 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
973 if ( $ARGS{'AttachTickets'} ) {
974 require RT::Action::SendEmail;
975 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
976 ref $ARGS{'AttachTickets'}
977 ? @{ $ARGS{'AttachTickets'} }
978 : ( $ARGS{'AttachTickets'} ) );
981 foreach my $arg ( keys %ARGS ) {
982 next if $arg =~ /-(?:Magic|Category)$/;
984 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
985 $create_args{$arg} = $ARGS{$arg};
988 # Object-RT::Ticket--CustomField-3-Values
989 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
992 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
995 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
999 if ( $arg =~ /-Upload$/ ) {
1000 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1004 my $type = $cf->Type;
1007 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1008 @values = @{ $ARGS{$arg} };
1009 } elsif ( $type =~ /text/i ) {
1010 @values = ( $ARGS{$arg} );
1012 no warnings 'uninitialized';
1013 @values = split /\r*\n/, $ARGS{$arg};
1015 @values = grep length, map {
1021 grep defined, @values;
1023 $create_args{"CustomField-$cfid"} = \@values;
1027 # turn new link lists into arrays, and pass in the proper arguments
1029 'new-DependsOn' => 'DependsOn',
1030 'DependsOn-new' => 'DependedOnBy',
1031 'new-MemberOf' => 'Parents',
1032 'MemberOf-new' => 'Children',
1033 'new-RefersTo' => 'RefersTo',
1034 'RefersTo-new' => 'ReferredToBy',
1036 foreach my $key ( keys %map ) {
1037 next unless $ARGS{$key};
1038 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1042 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1047 push( @Actions, split( "\n", $ErrMsg ) );
1048 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1049 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1051 return ( $Ticket, @Actions );
1057 # {{{ sub LoadTicket - loads a ticket
1059 =head2 LoadTicket id
1061 Takes a ticket id as its only variable. if it's handed an array, it takes
1064 Returns an RT::Ticket object as the current user.
1071 if ( ref($id) eq "ARRAY" ) {
1076 Abort("No ticket specified");
1079 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1081 unless ( $Ticket->id ) {
1082 Abort("Could not load ticket $id");
1089 # {{{ sub ProcessUpdateMessage
1091 =head2 ProcessUpdateMessage
1093 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1095 Don't write message if it only contains current user's signature and
1096 SkipSignatureOnly argument is true. Function anyway adds attachments
1097 and updates time worked field even if skips message. The default value
1102 sub ProcessUpdateMessage {
1107 SkipSignatureOnly => 1,
1111 if ( $args{ARGSRef}->{'UpdateAttachments'}
1112 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1114 delete $args{ARGSRef}->{'UpdateAttachments'};
1117 # Strip the signature
1118 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1119 Content => $args{ARGSRef}->{UpdateContent},
1120 ContentType => $args{ARGSRef}->{UpdateContentType},
1121 StripSignature => $args{SkipSignatureOnly},
1122 CurrentUser => $args{'TicketObj'}->CurrentUser,
1125 # If, after stripping the signature, we have no message, move the
1126 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1127 # ProcessBasics can deal -- then bail out.
1128 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1129 and not length $args{ARGSRef}->{'UpdateContent'} )
1131 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1132 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1137 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1138 $args{ARGSRef}->{'UpdateSubject'} = undef;
1141 my $Message = MakeMIMEEntity(
1142 Subject => $args{ARGSRef}->{'UpdateSubject'},
1143 Body => $args{ARGSRef}->{'UpdateContent'},
1144 Type => $args{ARGSRef}->{'UpdateContentType'},
1147 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1148 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1150 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1151 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1152 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1154 $old_txn = $args{TicketObj}->Transactions->First();
1157 if ( my $msg = $old_txn->Message->First ) {
1158 RT::Interface::Email::SetInReplyTo(
1159 Message => $Message,
1164 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1165 $Message->make_multipart;
1166 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1169 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1170 require RT::Action::SendEmail;
1171 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1172 ref $args{ARGSRef}->{'AttachTickets'}
1173 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1174 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1177 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1178 my $cc = $args{ARGSRef}->{'UpdateCc'};
1180 my %message_args = (
1182 BccMessageTo => $bcc,
1183 Sign => $args{ARGSRef}->{'Sign'},
1184 Encrypt => $args{ARGSRef}->{'Encrypt'},
1185 MIMEObj => $Message,
1186 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
1190 foreach my $type (qw(Cc AdminCc)) {
1191 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1192 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1193 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1194 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1197 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1198 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1199 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1202 if (@temp_squelch) {
1203 require RT::Action::SendEmail;
1204 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1207 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1208 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1209 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1211 my $var = ucfirst($1) . 'MessageTo';
1213 if ( $message_args{$var} ) {
1214 $message_args{$var} .= ", $value";
1216 $message_args{$var} = $value;
1222 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1223 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1224 push( @results, $Description );
1225 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1226 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1227 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1228 push( @results, $Description );
1229 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1232 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1239 # {{{ sub MakeMIMEEntity
1241 =head2 MakeMIMEEntity PARAMHASH
1243 Takes a paramhash Subject, Body and AttachmentFieldName.
1245 Also takes Form, Cc and Type as optional paramhash keys.
1247 Returns a MIME::Entity.
1251 sub MakeMIMEEntity {
1253 #TODO document what else this takes.
1259 AttachmentFieldName => undef,
1263 my $Message = MIME::Entity->build(
1264 Type => 'multipart/mixed',
1265 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1266 grep defined $args{$_}, qw(Subject From Cc)
1269 if ( defined $args{'Body'} && length $args{'Body'} ) {
1271 # Make the update content have no 'weird' newlines in it
1272 $args{'Body'} =~ s/\r\n/\n/gs;
1275 Type => $args{'Type'} || 'text/plain',
1277 Data => $args{'Body'},
1281 if ( $args{'AttachmentFieldName'} ) {
1283 my $cgi_object = $m->cgi_object;
1285 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1287 my ( @content, $buffer );
1288 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1289 push @content, $buffer;
1292 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1294 # Prefer the cached name first over CGI.pm stringification.
1295 my $filename = $RT::Mason::CGI::Filename;
1296 $filename = "$filehandle" unless defined $filename;
1297 $filename = Encode::encode_utf8( $filename );
1298 $filename =~ s{^.*[\\/]}{};
1301 Type => $uploadinfo->{'Content-Type'},
1302 Filename => $filename,
1305 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1306 $Message->head->set( 'Subject' => $filename );
1311 $Message->make_singlepart;
1313 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1321 # {{{ sub ParseDateToISO
1323 =head2 ParseDateToISO
1325 Takes a date in an arbitrary format.
1326 Returns an ISO date and time in GMT
1330 sub ParseDateToISO {
1333 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1335 Format => 'unknown',
1338 return ( $date_obj->ISO );
1343 # {{{ sub ProcessACLChanges
1345 sub ProcessACLChanges {
1346 my $ARGSref = shift;
1350 foreach my $arg ( keys %$ARGSref ) {
1351 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1353 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1356 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1357 @rights = @{ $ARGSref->{$arg} };
1359 @rights = $ARGSref->{$arg};
1361 @rights = grep $_, @rights;
1362 next unless @rights;
1364 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1365 $principal->Load($principal_id);
1368 if ( $object_type eq 'RT::System' ) {
1370 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1371 $obj = $object_type->new( $session{'CurrentUser'} );
1372 $obj->Load($object_id);
1373 unless ( $obj->id ) {
1374 $RT::Logger->error("couldn't load $object_type #$object_id");
1378 $RT::Logger->error("object type '$object_type' is incorrect");
1379 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1383 foreach my $right (@rights) {
1384 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1385 push( @results, $msg );
1394 # {{{ sub UpdateRecordObj
1396 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1398 @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.
1400 Returns an array of success/failure messages
1404 sub UpdateRecordObject {
1407 AttributesRef => undef,
1409 AttributePrefix => undef,
1413 my $Object = $args{'Object'};
1414 my @results = $Object->Update(
1415 AttributesRef => $args{'AttributesRef'},
1416 ARGSRef => $args{'ARGSRef'},
1417 AttributePrefix => $args{'AttributePrefix'},
1425 # {{{ Sub ProcessCustomFieldUpdates
1427 sub ProcessCustomFieldUpdates {
1429 CustomFieldObj => undef,
1434 my $Object = $args{'CustomFieldObj'};
1435 my $ARGSRef = $args{'ARGSRef'};
1437 my @attribs = qw(Name Type Description Queue SortOrder);
1438 my @results = UpdateRecordObject(
1439 AttributesRef => \@attribs,
1444 my $prefix = "CustomField-" . $Object->Id;
1445 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1446 my ( $addval, $addmsg ) = $Object->AddValue(
1447 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1448 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1449 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1451 push( @results, $addmsg );
1455 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1456 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1457 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1459 foreach my $id (@delete_values) {
1460 next unless defined $id;
1461 my ( $err, $msg ) = $Object->DeleteValue($id);
1462 push( @results, $msg );
1465 my $vals = $Object->Values();
1466 while ( my $cfv = $vals->Next() ) {
1467 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1468 if ( $cfv->SortOrder != $so ) {
1469 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1470 push( @results, $msg );
1480 # {{{ sub ProcessTicketBasics
1482 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1484 Returns an array of results messages.
1488 sub ProcessTicketBasics {
1496 my $TicketObj = $args{'TicketObj'};
1497 my $ARGSRef = $args{'ARGSRef'};
1499 # {{{ Set basic fields
1512 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1513 my $tempqueue = RT::Queue->new($RT::SystemUser);
1514 $tempqueue->Load( $ARGSRef->{'Queue'} );
1515 if ( $tempqueue->id ) {
1516 $ARGSRef->{'Queue'} = $tempqueue->id;
1520 # Status isn't a field that can be set to a null value.
1521 # RT core complains if you try
1522 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1524 my @results = UpdateRecordObject(
1525 AttributesRef => \@attribs,
1526 Object => $TicketObj,
1527 ARGSRef => $ARGSRef,
1530 # We special case owner changing, so we can use ForceOwnerChange
1531 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1533 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1534 $ChownType = "Force";
1536 $ChownType = "Give";
1539 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1540 push( @results, $msg );
1550 sub ProcessTicketCustomFieldUpdates {
1552 $args{'Object'} = delete $args{'TicketObj'};
1553 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1555 # Build up a list of objects that we want to work with
1556 my %custom_fields_to_mod;
1557 foreach my $arg ( keys %$ARGSRef ) {
1558 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1559 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1560 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1561 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1565 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1568 sub ProcessObjectCustomFieldUpdates {
1570 my $ARGSRef = $args{'ARGSRef'};
1573 # Build up a list of objects that we want to work with
1574 my %custom_fields_to_mod;
1575 foreach my $arg ( keys %$ARGSRef ) {
1577 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1578 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1580 # For each of those objects, find out what custom fields we want to work with.
1581 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1584 # For each of those objects
1585 foreach my $class ( keys %custom_fields_to_mod ) {
1586 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1587 my $Object = $args{'Object'};
1588 $Object = $class->new( $session{'CurrentUser'} )
1589 unless $Object && ref $Object eq $class;
1591 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1592 unless ( $Object->id ) {
1593 $RT::Logger->warning("Couldn't load object $class #$id");
1597 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1598 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1599 $CustomFieldObj->LoadById($cf);
1600 unless ( $CustomFieldObj->id ) {
1601 $RT::Logger->warning("Couldn't load custom field #$cf");
1605 _ProcessObjectCustomFieldUpdates(
1606 Prefix => "Object-$class-$id-CustomField-$cf-",
1608 CustomField => $CustomFieldObj,
1609 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1617 sub _ProcessObjectCustomFieldUpdates {
1619 my $cf = $args{'CustomField'};
1620 my $cf_type = $cf->Type;
1622 # Remove blank Values since the magic field will take care of this. Sometimes
1623 # the browser gives you a blank value which causes CFs to be processed twice
1624 if ( defined $args{'ARGS'}->{'Values'}
1625 && !length $args{'ARGS'}->{'Values'}
1626 && $args{'ARGS'}->{'Values-Magic'} )
1628 delete $args{'ARGS'}->{'Values'};
1632 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1634 # skip category argument
1635 next if $arg eq 'Category';
1637 # since http won't pass in a form element with a null value, we need
1639 if ( $arg eq 'Values-Magic' ) {
1641 # We don't care about the magic, if there's really a values element;
1642 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1643 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1645 # "Empty" values does not mean anything for Image and Binary fields
1646 next if $cf_type =~ /^(?:Image|Binary)$/;
1649 $args{'ARGS'}->{'Values'} = undef;
1653 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1654 @values = @{ $args{'ARGS'}->{$arg} };
1655 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1656 @values = ( $args{'ARGS'}->{$arg} );
1658 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1659 if defined $args{'ARGS'}->{$arg};
1661 @values = grep length, map {
1667 grep defined, @values;
1669 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1670 foreach my $value (@values) {
1671 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1675 push( @results, $msg );
1677 } elsif ( $arg eq 'Upload' ) {
1678 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1679 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1680 push( @results, $msg );
1681 } elsif ( $arg eq 'DeleteValues' ) {
1682 foreach my $value (@values) {
1683 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1687 push( @results, $msg );
1689 } elsif ( $arg eq 'DeleteValueIds' ) {
1690 foreach my $value (@values) {
1691 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1695 push( @results, $msg );
1697 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1698 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1701 foreach my $value (@values) {
1702 if ( my $entry = $cf_values->HasEntry($value) ) {
1703 $values_hash{ $entry->id } = 1;
1707 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1711 push( @results, $msg );
1712 $values_hash{$val} = 1 if $val;
1715 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1716 return @results if ( $cf->Type eq 'Date' && ! @values );
1718 $cf_values->RedoSearch;
1719 while ( my $cf_value = $cf_values->Next ) {
1720 next if $values_hash{ $cf_value->id };
1722 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1724 ValueId => $cf_value->id
1726 push( @results, $msg );
1728 } elsif ( $arg eq 'Values' ) {
1729 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1731 # keep everything up to the point of difference, delete the rest
1733 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1734 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1743 # now add/replace extra things, if any
1744 foreach my $value (@values) {
1745 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1749 push( @results, $msg );
1754 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1755 $cf->Name, ref $args{'Object'},
1764 # {{{ sub ProcessTicketWatchers
1766 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1768 Returns an array of results messages.
1772 sub ProcessTicketWatchers {
1780 my $Ticket = $args{'TicketObj'};
1781 my $ARGSRef = $args{'ARGSRef'};
1785 foreach my $key ( keys %$ARGSRef ) {
1787 # Delete deletable watchers
1788 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1789 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1793 push @results, $msg;
1796 # Delete watchers in the simple style demanded by the bulk manipulator
1797 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1798 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1799 Email => $ARGSRef->{$key},
1802 push @results, $msg;
1805 # Add new wathchers by email address
1806 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1807 and $key =~ /^WatcherTypeEmail(\d*)$/ )
1810 #They're in this order because otherwise $1 gets clobbered :/
1811 my ( $code, $msg ) = $Ticket->AddWatcher(
1812 Type => $ARGSRef->{$key},
1813 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1815 push @results, $msg;
1818 #Add requestors in the simple style demanded by the bulk manipulator
1819 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1820 my ( $code, $msg ) = $Ticket->AddWatcher(
1822 Email => $ARGSRef->{$key}
1824 push @results, $msg;
1827 # Add new watchers by owner
1828 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1829 my $principal_id = $1;
1830 my $form = $ARGSRef->{$key};
1831 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1832 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1834 my ( $code, $msg ) = $Ticket->AddWatcher(
1836 PrincipalId => $principal_id
1838 push @results, $msg;
1848 # {{{ sub ProcessTicketDates
1850 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1852 Returns an array of results messages.
1856 sub ProcessTicketDates {
1863 my $Ticket = $args{'TicketObj'};
1864 my $ARGSRef = $args{'ARGSRef'};
1868 # {{{ Set date fields
1869 my @date_fields = qw(
1877 #Run through each field in this list. update the value if apropriate
1878 foreach my $field (@date_fields) {
1879 next unless exists $ARGSRef->{ $field . '_Date' };
1880 next if $ARGSRef->{ $field . '_Date' } eq '';
1884 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
1886 Format => 'unknown',
1887 Value => $ARGSRef->{ $field . '_Date' }
1890 my $obj = $field . "Obj";
1891 if ( ( defined $DateObj->Unix )
1892 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
1894 my $method = "Set$field";
1895 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
1896 push @results, "$msg";
1906 # {{{ sub ProcessTicketLinks
1908 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1910 Returns an array of results messages.
1914 sub ProcessTicketLinks {
1921 my $Ticket = $args{'TicketObj'};
1922 my $ARGSRef = $args{'ARGSRef'};
1924 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
1926 #Merge if we need to
1927 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
1928 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
1929 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
1930 push @results, $msg;
1938 sub ProcessRecordLinks {
1945 my $Record = $args{'RecordObj'};
1946 my $ARGSRef = $args{'ARGSRef'};
1950 # Delete links that are gone gone gone.
1951 foreach my $arg ( keys %$ARGSRef ) {
1952 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
1957 my ( $val, $msg ) = $Record->DeleteLink(
1963 push @results, $msg;
1969 my @linktypes = qw( DependsOn MemberOf RefersTo );
1971 foreach my $linktype (@linktypes) {
1972 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
1973 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
1974 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
1976 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
1978 $luri =~ s/\s+$//; # Strip trailing whitespace
1979 my ( $val, $msg ) = $Record->AddLink(
1983 push @results, $msg;
1986 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
1987 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
1988 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
1990 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
1992 my ( $val, $msg ) = $Record->AddLink(
1997 push @results, $msg;
2005 =head2 _UploadedFile ( $arg );
2007 Takes a CGI parameter name; if a file is uploaded under that name,
2008 return a hash reference suitable for AddCustomFieldValue's use:
2009 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2011 Returns C<undef> if no files were uploaded in the C<$arg> field.
2017 my $cgi_object = $m->cgi_object;
2018 my $fh = $cgi_object->upload($arg) or return undef;
2019 my $upload_info = $cgi_object->uploadInfo($fh);
2021 my $filename = "$fh";
2022 $filename =~ s#^.*[\\/]##;
2027 LargeContent => do { local $/; scalar <$fh> },
2028 ContentType => $upload_info->{'Content-Type'},
2032 sub GetColumnMapEntry {
2033 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2035 # deal with the simplest thing first
2036 if ( $args{'Map'}{ $args{'Name'} } ) {
2037 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2041 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2042 return undef unless $args{'Map'}->{$mainkey};
2043 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2044 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2046 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2051 sub ProcessColumnMapValue {
2053 my %args = ( Arguments => [], Escape => 1, @_ );
2056 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2057 my @tmp = $value->( @{ $args{'Arguments'} } );
2058 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2059 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2060 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2061 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2066 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2070 =head2 _load_container_object ( $type, $id );
2072 Instantiate container object for saving searches.
2076 sub _load_container_object {
2077 my ( $obj_type, $obj_id ) = @_;
2078 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2081 =head2 _parse_saved_search ( $arg );
2083 Given a serialization string for saved search, and returns the
2084 container object and the search id.
2088 sub _parse_saved_search {
2090 return unless $spec;
2091 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2098 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2101 eval "require RT::Interface::Web_Vendor";
2102 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2103 eval "require RT::Interface::Web_Local";
2104 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );