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;
1348 #XXX: why don't we get ARGSref like in other Process* subs?
1352 foreach my $arg ( keys %$ARGSref ) {
1353 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1355 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1358 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1359 @rights = @{ $ARGSref->{$arg} };
1361 @rights = $ARGSref->{$arg};
1363 @rights = grep $_, @rights;
1364 next unless @rights;
1366 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1367 $principal->Load($principal_id);
1370 if ( $object_type eq 'RT::System' ) {
1372 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1373 $obj = $object_type->new( $session{'CurrentUser'} );
1374 $obj->Load($object_id);
1375 unless ( $obj->id ) {
1376 $RT::Logger->error("couldn't load $object_type #$object_id");
1380 $RT::Logger->error("object type '$object_type' is incorrect");
1381 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1385 foreach my $right (@rights) {
1386 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1387 push( @results, $msg );
1396 # {{{ sub UpdateRecordObj
1398 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1400 @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.
1402 Returns an array of success/failure messages
1406 sub UpdateRecordObject {
1409 AttributesRef => undef,
1411 AttributePrefix => undef,
1415 my $Object = $args{'Object'};
1416 my @results = $Object->Update(
1417 AttributesRef => $args{'AttributesRef'},
1418 ARGSRef => $args{'ARGSRef'},
1419 AttributePrefix => $args{'AttributePrefix'},
1427 # {{{ Sub ProcessCustomFieldUpdates
1429 sub ProcessCustomFieldUpdates {
1431 CustomFieldObj => undef,
1436 my $Object = $args{'CustomFieldObj'};
1437 my $ARGSRef = $args{'ARGSRef'};
1439 my @attribs = qw(Name Type Description Queue SortOrder);
1440 my @results = UpdateRecordObject(
1441 AttributesRef => \@attribs,
1446 my $prefix = "CustomField-" . $Object->Id;
1447 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1448 my ( $addval, $addmsg ) = $Object->AddValue(
1449 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1450 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1451 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1453 push( @results, $addmsg );
1457 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1458 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1459 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1461 foreach my $id (@delete_values) {
1462 next unless defined $id;
1463 my ( $err, $msg ) = $Object->DeleteValue($id);
1464 push( @results, $msg );
1467 my $vals = $Object->Values();
1468 while ( my $cfv = $vals->Next() ) {
1469 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1470 if ( $cfv->SortOrder != $so ) {
1471 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1472 push( @results, $msg );
1482 # {{{ sub ProcessTicketBasics
1484 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1486 Returns an array of results messages.
1490 sub ProcessTicketBasics {
1498 my $TicketObj = $args{'TicketObj'};
1499 my $ARGSRef = $args{'ARGSRef'};
1501 # {{{ Set basic fields
1514 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1515 my $tempqueue = RT::Queue->new($RT::SystemUser);
1516 $tempqueue->Load( $ARGSRef->{'Queue'} );
1517 if ( $tempqueue->id ) {
1518 $ARGSRef->{'Queue'} = $tempqueue->id;
1522 # Status isn't a field that can be set to a null value.
1523 # RT core complains if you try
1524 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1526 my @results = UpdateRecordObject(
1527 AttributesRef => \@attribs,
1528 Object => $TicketObj,
1529 ARGSRef => $ARGSRef,
1532 # We special case owner changing, so we can use ForceOwnerChange
1533 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1535 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1536 $ChownType = "Force";
1538 $ChownType = "Give";
1541 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1542 push( @results, $msg );
1552 sub ProcessTicketCustomFieldUpdates {
1554 $args{'Object'} = delete $args{'TicketObj'};
1555 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1557 # Build up a list of objects that we want to work with
1558 my %custom_fields_to_mod;
1559 foreach my $arg ( keys %$ARGSRef ) {
1560 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1561 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1562 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1563 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1567 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1570 sub ProcessObjectCustomFieldUpdates {
1572 my $ARGSRef = $args{'ARGSRef'};
1575 # Build up a list of objects that we want to work with
1576 my %custom_fields_to_mod;
1577 foreach my $arg ( keys %$ARGSRef ) {
1579 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1580 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1582 # For each of those objects, find out what custom fields we want to work with.
1583 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1586 # For each of those objects
1587 foreach my $class ( keys %custom_fields_to_mod ) {
1588 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1589 my $Object = $args{'Object'};
1590 $Object = $class->new( $session{'CurrentUser'} )
1591 unless $Object && ref $Object eq $class;
1593 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1594 unless ( $Object->id ) {
1595 $RT::Logger->warning("Couldn't load object $class #$id");
1599 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1600 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1601 $CustomFieldObj->LoadById($cf);
1602 unless ( $CustomFieldObj->id ) {
1603 $RT::Logger->warning("Couldn't load custom field #$cf");
1607 _ProcessObjectCustomFieldUpdates(
1608 Prefix => "Object-$class-$id-CustomField-$cf-",
1610 CustomField => $CustomFieldObj,
1611 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1619 sub _ProcessObjectCustomFieldUpdates {
1621 my $cf = $args{'CustomField'};
1622 my $cf_type = $cf->Type;
1624 # Remove blank Values since the magic field will take care of this. Sometimes
1625 # the browser gives you a blank value which causes CFs to be processed twice
1626 if ( defined $args{'ARGS'}->{'Values'}
1627 && !length $args{'ARGS'}->{'Values'}
1628 && $args{'ARGS'}->{'Values-Magic'} )
1630 delete $args{'ARGS'}->{'Values'};
1634 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1636 # skip category argument
1637 next if $arg eq 'Category';
1639 # since http won't pass in a form element with a null value, we need
1641 if ( $arg eq 'Values-Magic' ) {
1643 # We don't care about the magic, if there's really a values element;
1644 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1645 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1647 # "Empty" values does not mean anything for Image and Binary fields
1648 next if $cf_type =~ /^(?:Image|Binary)$/;
1651 $args{'ARGS'}->{'Values'} = undef;
1655 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1656 @values = @{ $args{'ARGS'}->{$arg} };
1657 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1658 @values = ( $args{'ARGS'}->{$arg} );
1660 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1661 if defined $args{'ARGS'}->{$arg};
1663 @values = grep length, map {
1669 grep defined, @values;
1671 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1672 foreach my $value (@values) {
1673 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1677 push( @results, $msg );
1679 } elsif ( $arg eq 'Upload' ) {
1680 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1681 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1682 push( @results, $msg );
1683 } elsif ( $arg eq 'DeleteValues' ) {
1684 foreach my $value (@values) {
1685 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1689 push( @results, $msg );
1691 } elsif ( $arg eq 'DeleteValueIds' ) {
1692 foreach my $value (@values) {
1693 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1697 push( @results, $msg );
1699 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1700 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1703 foreach my $value (@values) {
1704 if ( my $entry = $cf_values->HasEntry($value) ) {
1705 $values_hash{ $entry->id } = 1;
1709 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1713 push( @results, $msg );
1714 $values_hash{$val} = 1 if $val;
1717 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1718 return @results if ( $cf->Type eq 'Date' && ! @values );
1720 $cf_values->RedoSearch;
1721 while ( my $cf_value = $cf_values->Next ) {
1722 next if $values_hash{ $cf_value->id };
1724 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1726 ValueId => $cf_value->id
1728 push( @results, $msg );
1730 } elsif ( $arg eq 'Values' ) {
1731 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1733 # keep everything up to the point of difference, delete the rest
1735 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1736 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1745 # now add/replace extra things, if any
1746 foreach my $value (@values) {
1747 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1751 push( @results, $msg );
1756 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1757 $cf->Name, ref $args{'Object'},
1766 # {{{ sub ProcessTicketWatchers
1768 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1770 Returns an array of results messages.
1774 sub ProcessTicketWatchers {
1782 my $Ticket = $args{'TicketObj'};
1783 my $ARGSRef = $args{'ARGSRef'};
1787 foreach my $key ( keys %$ARGSRef ) {
1789 # Delete deletable watchers
1790 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1791 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1795 push @results, $msg;
1798 # Delete watchers in the simple style demanded by the bulk manipulator
1799 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1800 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1801 Email => $ARGSRef->{$key},
1804 push @results, $msg;
1807 # Add new wathchers by email address
1808 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1809 and $key =~ /^WatcherTypeEmail(\d*)$/ )
1812 #They're in this order because otherwise $1 gets clobbered :/
1813 my ( $code, $msg ) = $Ticket->AddWatcher(
1814 Type => $ARGSRef->{$key},
1815 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1817 push @results, $msg;
1820 #Add requestors in the simple style demanded by the bulk manipulator
1821 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1822 my ( $code, $msg ) = $Ticket->AddWatcher(
1824 Email => $ARGSRef->{$key}
1826 push @results, $msg;
1829 # Add new watchers by owner
1830 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1831 my $principal_id = $1;
1832 my $form = $ARGSRef->{$key};
1833 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1834 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1836 my ( $code, $msg ) = $Ticket->AddWatcher(
1838 PrincipalId => $principal_id
1840 push @results, $msg;
1850 # {{{ sub ProcessTicketDates
1852 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1854 Returns an array of results messages.
1858 sub ProcessTicketDates {
1865 my $Ticket = $args{'TicketObj'};
1866 my $ARGSRef = $args{'ARGSRef'};
1870 # {{{ Set date fields
1871 my @date_fields = qw(
1879 #Run through each field in this list. update the value if apropriate
1880 foreach my $field (@date_fields) {
1881 next unless exists $ARGSRef->{ $field . '_Date' };
1882 next if $ARGSRef->{ $field . '_Date' } eq '';
1886 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
1888 Format => 'unknown',
1889 Value => $ARGSRef->{ $field . '_Date' }
1892 my $obj = $field . "Obj";
1893 if ( ( defined $DateObj->Unix )
1894 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
1896 my $method = "Set$field";
1897 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
1898 push @results, "$msg";
1908 # {{{ sub ProcessTicketLinks
1910 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1912 Returns an array of results messages.
1916 sub ProcessTicketLinks {
1923 my $Ticket = $args{'TicketObj'};
1924 my $ARGSRef = $args{'ARGSRef'};
1926 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
1928 #Merge if we need to
1929 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
1930 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
1931 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
1932 push @results, $msg;
1940 sub ProcessRecordLinks {
1947 my $Record = $args{'RecordObj'};
1948 my $ARGSRef = $args{'ARGSRef'};
1952 # Delete links that are gone gone gone.
1953 foreach my $arg ( keys %$ARGSRef ) {
1954 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
1959 my ( $val, $msg ) = $Record->DeleteLink(
1965 push @results, $msg;
1971 my @linktypes = qw( DependsOn MemberOf RefersTo );
1973 foreach my $linktype (@linktypes) {
1974 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
1975 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
1976 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
1978 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
1980 $luri =~ s/\s+$//; # Strip trailing whitespace
1981 my ( $val, $msg ) = $Record->AddLink(
1985 push @results, $msg;
1988 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
1989 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
1990 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
1992 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
1994 my ( $val, $msg ) = $Record->AddLink(
1999 push @results, $msg;
2007 =head2 _UploadedFile ( $arg );
2009 Takes a CGI parameter name; if a file is uploaded under that name,
2010 return a hash reference suitable for AddCustomFieldValue's use:
2011 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2013 Returns C<undef> if no files were uploaded in the C<$arg> field.
2019 my $cgi_object = $m->cgi_object;
2020 my $fh = $cgi_object->upload($arg) or return undef;
2021 my $upload_info = $cgi_object->uploadInfo($fh);
2023 my $filename = "$fh";
2024 $filename =~ s#^.*[\\/]##;
2029 LargeContent => do { local $/; scalar <$fh> },
2030 ContentType => $upload_info->{'Content-Type'},
2034 sub GetColumnMapEntry {
2035 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2037 # deal with the simplest thing first
2038 if ( $args{'Map'}{ $args{'Name'} } ) {
2039 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2043 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2044 return undef unless $args{'Map'}->{$mainkey};
2045 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2046 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2048 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2053 sub ProcessColumnMapValue {
2055 my %args = ( Arguments => [], Escape => 1, @_ );
2058 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2059 my @tmp = $value->( @{ $args{'Arguments'} } );
2060 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2061 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2062 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2063 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2068 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2072 =head2 _load_container_object ( $type, $id );
2074 Instantiate container object for saving searches.
2078 sub _load_container_object {
2079 my ( $obj_type, $obj_id ) = @_;
2080 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2083 =head2 _parse_saved_search ( $arg );
2085 Given a serialization string for saved search, and returns the
2086 container object and the search id.
2090 sub _parse_saved_search {
2092 return unless $spec;
2093 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2100 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2103 eval "require RT::Interface::Web_Vendor";
2104 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2105 eval "require RT::Interface::Web_Local";
2106 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );