1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC
6 # <sales@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 # Process session-related callbacks before any auth attempts
196 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
198 MaybeShowNoAuthPage($ARGS);
200 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
202 _ForceLogout() unless _UserLoggedIn();
204 # Process per-page authentication callbacks
205 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
207 unless ( _UserLoggedIn() ) {
210 # Authenticate if the user is trying to login via user/pass query args
211 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
214 my $m = $HTML::Mason::Commands::m;
216 # REST urls get a special 401 response
217 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
218 $HTML::Mason::Commands::r->content_type("text/plain");
219 $m->error_format("text");
220 $m->out("RT/$RT::VERSION 401 Credentials required\n");
221 $m->out("\n$msg\n") if $msg;
224 # Specially handle /index.html so that we get a nicer URL
225 elsif ( $m->request_comp->path eq '/index.html' ) {
226 my $next = SetNextPage(RT->Config->Get('WebURL'));
227 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
231 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
236 # now it applies not only to home page, but any dashboard that can be used as a workspace
237 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
238 if ( $ARGS->{'HomeRefreshInterval'} );
240 # Process per-page global callbacks
241 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
243 ShowRequestedPage($ARGS);
244 LogRecordedSQLStatements();
246 # Process per-page final cleanup callbacks
247 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
252 delete $HTML::Mason::Commands::session{'CurrentUser'};
256 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
264 =head2 LoginError ERROR
266 Pushes a login error into the Actions session store and returns the hash key.
272 my $key = Digest::MD5::md5_hex( rand(1024) );
273 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
274 $HTML::Mason::Commands::session{'i'}++;
278 =head2 SetNextPage [PATH]
280 Intuits and stashes the next page in the sesssion hash. If PATH is
281 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
287 my $next = shift || IntuitNextPage();
288 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
290 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
291 $HTML::Mason::Commands::session{'i'}++;
298 =head2 TangentForLogin [HASH]
300 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
301 the next page. Optionally takes a hash which is dumped into query params.
305 sub TangentForLogin {
306 my $hash = SetNextPage();
307 my %query = (@_, next => $hash);
308 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
309 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
313 =head2 TangentForLoginWithError ERROR
315 Localizes the passed error message, stashes it with L<LoginError> and then
316 calls L<TangentForLogin> with the appropriate results key.
320 sub TangentForLoginWithError {
321 my $key = LoginError(HTML::Mason::Commands::loc(@_));
322 TangentForLogin( results => $key );
325 =head2 IntuitNextPage
327 Attempt to figure out the path to which we should return the user after a
328 tangent. The current request URL is used, or failing that, the C<WebURL>
329 configuration variable.
336 # This includes any query parameters. Redirect will take care of making
337 # it an absolute URL.
338 if ($ENV{'REQUEST_URI'}) {
339 $req_uri = $ENV{'REQUEST_URI'};
341 # collapse multiple leading slashes so the first part doesn't look like
342 # a hostname of a schema-less URI
343 $req_uri =~ s{^/+}{/};
346 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
349 my $uri = URI->new($next);
351 # You get undef scheme with a relative uri like "/Search/Build.html"
352 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
353 $next = RT->Config->Get('WebURL');
356 # Make sure we're logging in to the same domain
357 # You can get an undef authority with a relative uri like "index.html"
358 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
359 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
360 $next = RT->Config->Get('WebURL');
366 =head2 MaybeShowInstallModePage
368 This function, called exclusively by RT's autohandler, dispatches
369 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
371 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
375 sub MaybeShowInstallModePage {
376 return unless RT->InstallMode;
378 my $m = $HTML::Mason::Commands::m;
379 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
381 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
382 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
389 =head2 MaybeShowNoAuthPage \%ARGS
391 This function, called exclusively by RT's autohandler, dispatches
392 a request to the page a user requested (but only if it matches the "noauth" regex.
394 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
398 sub MaybeShowNoAuthPage {
401 my $m = $HTML::Mason::Commands::m;
403 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
405 # Don't show the login page to logged in users
406 Redirect(RT->Config->Get('WebURL'))
407 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
409 # If it's a noauth file, don't ask for auth.
411 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
415 =head2 ShowRequestedPage \%ARGS
417 This function, called exclusively by RT's autohandler, dispatches
418 a request to the page a user requested (making sure that unpriviled users
419 can only see self-service pages.
423 sub ShowRequestedPage {
426 my $m = $HTML::Mason::Commands::m;
430 # If the user isn't privileged, they can only see SelfService
431 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
433 # if the user is trying to access a ticket, redirect them
434 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
435 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
438 # otherwise, drop the user at the SelfService default page
439 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
440 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
443 # if user is in SelfService dir let him do anything
445 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
448 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
453 sub AttemptExternalAuth {
456 return unless ( RT->Config->Get('WebExternalAuth') );
458 my $user = $ARGS->{user};
459 my $m = $HTML::Mason::Commands::m;
461 # If RT is configured for external auth, let's go through and get REMOTE_USER
463 # do we actually have a REMOTE_USER equivlent?
464 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
465 my $orig_user = $user;
467 $user = RT::Interface::Web::WebCanonicalizeInfo();
468 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
470 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
471 my $NodeName = Win32::NodeName();
472 $user =~ s/^\Q$NodeName\E\\//i;
475 InstantiateNewSession() unless _UserLoggedIn;
476 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
477 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
479 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
481 # Create users on-the-fly
482 my $UserObj = RT::User->new($RT::SystemUser);
483 my ( $val, $msg ) = $UserObj->Create(
484 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
491 # now get user specific information, to better create our user.
492 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
494 # set the attributes that have been defined.
495 foreach my $attribute ( $UserObj->WritableAttributes ) {
497 Attribute => $attribute,
499 UserInfo => $new_user_info,
500 CallbackName => 'NewUser',
501 CallbackPage => '/autohandler'
503 my $method = "Set$attribute";
504 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
506 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
509 # we failed to successfully create the user. abort abort abort.
510 delete $HTML::Mason::Commands::session{'CurrentUser'};
512 if (RT->Config->Get('WebFallbackToInternalAuth')) {
513 TangentForLoginWithError('Cannot create user: [_1]', $msg);
520 if ( _UserLoggedIn() ) {
521 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
523 delete $HTML::Mason::Commands::session{'CurrentUser'};
526 if ( RT->Config->Get('WebExternalOnly') ) {
527 TangentForLoginWithError('You are not an authorized user');
530 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
531 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
532 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
533 TangentForLoginWithError('You are not an authorized user');
537 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
538 # XXX: we must return AUTH_REQUIRED status or we fallback to
539 # internal auth here too.
540 delete $HTML::Mason::Commands::session{'CurrentUser'}
541 if defined $HTML::Mason::Commands::session{'CurrentUser'};
545 sub AttemptPasswordAuthentication {
547 return unless defined $ARGS->{user} && defined $ARGS->{pass};
549 my $user_obj = RT::CurrentUser->new();
550 $user_obj->Load( $ARGS->{user} );
552 my $m = $HTML::Mason::Commands::m;
554 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
555 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
556 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
557 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
560 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
562 # It's important to nab the next page from the session before we blow
564 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
566 InstantiateNewSession();
567 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
570 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
572 # Really the only time we don't want to redirect here is if we were
573 # passed user and pass as query params in the URL.
577 elsif ($ARGS->{'next'}) {
578 # Invalid hash, but still wants to go somewhere, take them to /
579 Redirect(RT->Config->Get('WebURL'));
582 return (1, HTML::Mason::Commands::loc('Logged in'));
586 =head2 LoadSessionFromCookie
588 Load or setup a session cookie for the current user.
592 sub _SessionCookieName {
593 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
594 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
598 sub LoadSessionFromCookie {
600 my %cookies = CGI::Cookie->fetch;
601 my $cookiename = _SessionCookieName();
602 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
603 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
604 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
605 undef $cookies{$cookiename};
607 if ( int RT->Config->Get('AutoLogoff') ) {
608 my $now = int( time / 60 );
609 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
611 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
612 InstantiateNewSession();
615 # save session on each request when AutoLogoff is turned on
616 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
620 sub InstantiateNewSession {
621 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
622 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
625 sub SendSessionCookie {
626 my $cookie = CGI::Cookie->new(
627 -name => _SessionCookieName(),
628 -value => $HTML::Mason::Commands::session{_session_id},
629 -path => RT->Config->Get('WebPath'),
630 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 )
633 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
638 This routine ells the current user's browser to redirect to URL.
639 Additionally, it unties the user's currently active session, helping to avoid
640 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
641 a cached DBI statement handle twice at the same time.
646 my $redir_to = shift;
647 untie $HTML::Mason::Commands::session;
648 my $uri = URI->new($redir_to);
649 my $server_uri = URI->new( RT->Config->Get('WebURL') );
651 # Make relative URIs absolute from the server host and scheme
652 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
653 if (not defined $uri->host) {
654 $uri->host($server_uri->host);
655 $uri->port($server_uri->port);
658 # If the user is coming in via a non-canonical
659 # hostname, don't redirect them to the canonical host,
660 # it will just upset them (and invalidate their credentials)
661 # don't do this if $RT::CanoniaclRedirectURLs is true
662 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
663 && $uri->host eq $server_uri->host
664 && $uri->port eq $server_uri->port )
666 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
667 $uri->scheme('https');
669 $uri->scheme('http');
672 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
673 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
674 $uri->port( $ENV{'SERVER_PORT'} );
677 # not sure why, but on some systems without this call mason doesn't
678 # set status to 302, but 200 instead and people see blank pages
679 $HTML::Mason::Commands::r->status(302);
681 # Perlbal expects a status message, but Mason's default redirect status
682 # doesn't provide one. See also rt.cpan.org #36689.
683 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
685 $HTML::Mason::Commands::m->abort;
688 =head2 StaticFileHeaders
690 Send the browser a few headers to try to get it to (somewhat agressively)
691 cache RT's static Javascript and CSS files.
693 This routine could really use _accurate_ heuristics. (XXX TODO)
697 sub StaticFileHeaders {
698 my $date = RT::Date->new($RT::SystemUser);
701 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
703 # Expire things in a month.
704 $date->Set( Value => time + 30 * 24 * 60 * 60 );
705 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
707 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
708 # request, but we don't handle it and generate full reply again
709 # Last modified at server start time
710 # $date->Set( Value => $^T );
711 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
716 Takes a C<< Path => path >> and returns a boolean indicating that
717 the path is safely within RT's control or not. The path I<must> be
720 This function does not consult the filesystem at all; it is merely
721 a logical sanity checking of the path. This explicitly does not handle
722 symlinks; if you have symlinks in RT's webroot pointing outside of it,
723 then we assume you know what you are doing.
730 my $path = $args{Path};
732 # Get File::Spec to clean up extra /s, ./, etc
733 my $cleaned_up = File::Spec->canonpath($path);
735 if (!defined($cleaned_up)) {
736 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
740 # Forbid too many ..s. We can't just sum then check because
741 # "../foo/bar/baz" should be illegal even though it has more
742 # downdirs than updirs. So as soon as we get a negative score
743 # (which means "breaking out" of the top level) we reject the path.
745 my @components = split '/', $cleaned_up;
747 for my $component (@components) {
748 if ($component eq '..') {
751 $RT::Logger->info("Rejecting unsafe path: $path");
755 elsif ($component eq '.' || $component eq '') {
756 # these two have no effect on $score
766 =head2 SendStaticFile
768 Takes a File => path and a Type => Content-type
770 If Type isn't provided and File is an image, it will
771 figure out a sane Content-type, otherwise it will
772 send application/octet-stream
774 Will set caching headers using StaticFileHeaders
781 my $file = $args{File};
782 my $type = $args{Type};
783 my $relfile = $args{RelativeFile};
785 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
786 $HTML::Mason::Commands::r->status(400);
787 $HTML::Mason::Commands::m->abort;
790 $self->StaticFileHeaders();
793 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
795 $type =~ s/jpg/jpeg/gi;
797 $type ||= "application/octet-stream";
799 $HTML::Mason::Commands::r->content_type($type);
800 open my $fh, "<$file" or die "couldn't open file: $!";
804 $HTML::Mason::Commands::m->out($_) while (<$fh>);
805 $HTML::Mason::Commands::m->flush_buffer;
812 my $content = $args{Content};
813 return '' unless $content;
815 # Make the content have no 'weird' newlines in it
816 $content =~ s/\r+\n/\n/g;
818 my $return_content = $content;
820 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
821 my $sigonly = $args{StripSignature};
823 # massage content to easily detect if there's any real content
824 $content =~ s/\s+//g; # yes! remove all the spaces
826 # remove html version of spaces and newlines
827 $content =~ s! !!g;
828 $content =~ s!<br/?>!!g;
831 # Filter empty content when type is text/html
832 return '' if $html && $content !~ /\S/;
834 # If we aren't supposed to strip the sig, just bail now.
835 return $return_content unless $sigonly;
838 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
841 # Check for plaintext sig
842 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
844 # Check for html-formatted sig
845 RT::Interface::Web::EscapeUTF8( \$sig );
848 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
851 return $return_content;
859 # if they've passed multiple values, they'll be an array. if they've
860 # passed just one, a scalar whatever they are, mark them as utf8
863 ? Encode::is_utf8($_)
865 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
866 : ( $type eq 'ARRAY' )
867 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
869 : ( $type eq 'HASH' )
870 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
876 sub PreprocessTimeUpdates {
879 # Later in the code we use
880 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
881 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
882 # The call_next method pass through original arguments and if you have
883 # an argument with unicode key then in a next component you'll get two
884 # records in the args hash: one with key without UTF8 flag and another
885 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
886 # is copied from mason's source to get the same results as we get from
887 # call_next method, this feature is not documented, so we just leave it
888 # here to avoid possible side effects.
890 # This code canonicalizes time inputs in hours into minutes
891 foreach my $field ( keys %$ARGS ) {
892 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
894 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
895 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
896 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
897 $ARGS->{$local} *= 60;
899 delete $ARGS->{$field};
904 sub MaybeEnableSQLStatementLog {
906 my $log_sql_statements = RT->Config->Get('StatementLog');
908 if ($log_sql_statements) {
909 $RT::Handle->ClearSQLStatementLog;
910 $RT::Handle->LogSQLStatements(1);
915 sub LogRecordedSQLStatements {
916 my $log_sql_statements = RT->Config->Get('StatementLog');
918 return unless ($log_sql_statements);
920 my @log = $RT::Handle->SQLStatementLog;
921 $RT::Handle->ClearSQLStatementLog;
922 for my $stmt (@log) {
923 my ( $time, $sql, $bind, $duration ) = @{$stmt};
933 level => $log_sql_statements,
935 . sprintf( "%.6f", $duration )
937 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
943 package HTML::Mason::Commands;
945 use vars qw/$r $m %session/;
951 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
952 with whatever it's called with. If there is no $session{'CurrentUser'},
953 it creates a temporary user, so we have something to get a localisation handle
960 if ( $session{'CurrentUser'}
961 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
963 return ( $session{'CurrentUser'}->loc(@_) );
966 RT::CurrentUser->new();
970 return ( $u->loc(@_) );
973 # pathetic case -- SystemUser is gone.
982 =head2 loc_fuzzy STRING
984 loc_fuzzy is for handling localizations of messages that may already
985 contain interpolated variables, typically returned from libraries
986 outside RT's control. It takes the message string and extracts the
987 variable array automatically by matching against the candidate entries
988 inside the lexicon file.
995 if ( $session{'CurrentUser'}
996 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
998 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1000 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1001 return ( $u->loc_fuzzy($msg) );
1008 # Error - calls Error and aborts
1013 if ( $session{'ErrorDocument'}
1014 && $session{'ErrorDocumentType'} )
1016 $r->content_type( $session{'ErrorDocumentType'} );
1017 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1020 $m->comp( "/Elements/Error", Why => $why, %args );
1027 # {{{ sub CreateTicket
1029 =head2 CreateTicket ARGS
1031 Create a new ticket, using Mason's %ARGS. returns @results.
1040 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1042 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1043 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1044 Abort('Queue not found');
1047 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1048 Abort('You have no permission to create tickets in that queue.');
1052 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1053 $due = new RT::Date( $session{'CurrentUser'} );
1054 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1057 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1058 $starts = new RT::Date( $session{'CurrentUser'} );
1059 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1062 my $sigless = RT::Interface::Web::StripContent(
1063 Content => $ARGS{Content},
1064 ContentType => $ARGS{ContentType},
1065 StripSignature => 1,
1066 CurrentUser => $session{'CurrentUser'},
1069 my $MIMEObj = MakeMIMEEntity(
1070 Subject => $ARGS{'Subject'},
1071 From => $ARGS{'From'},
1074 Type => $ARGS{'ContentType'},
1077 if ( $ARGS{'Attachments'} ) {
1078 my $rv = $MIMEObj->make_multipart;
1079 $RT::Logger->error("Couldn't make multipart message")
1080 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1082 foreach ( values %{ $ARGS{'Attachments'} } ) {
1084 $RT::Logger->error("Couldn't add empty attachemnt");
1087 $MIMEObj->add_part($_);
1091 foreach my $argument (qw(Encrypt Sign)) {
1092 $MIMEObj->head->add(
1093 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1094 ) if defined $ARGS{$argument};
1098 Type => $ARGS{'Type'} || 'ticket',
1099 Queue => $ARGS{'Queue'},
1100 Owner => $ARGS{'Owner'},
1103 Requestor => $ARGS{'Requestors'},
1105 AdminCc => $ARGS{'AdminCc'},
1106 InitialPriority => $ARGS{'InitialPriority'},
1107 FinalPriority => $ARGS{'FinalPriority'},
1108 TimeLeft => $ARGS{'TimeLeft'},
1109 TimeEstimated => $ARGS{'TimeEstimated'},
1110 TimeWorked => $ARGS{'TimeWorked'},
1111 Subject => $ARGS{'Subject'},
1112 Status => $ARGS{'Status'},
1113 Due => $due ? $due->ISO : undef,
1114 Starts => $starts ? $starts->ISO : undef,
1119 foreach my $type (qw(Requestor Cc AdminCc)) {
1120 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1121 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1125 if (@temp_squelch) {
1126 require RT::Action::SendEmail;
1127 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1130 if ( $ARGS{'AttachTickets'} ) {
1131 require RT::Action::SendEmail;
1132 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1133 ref $ARGS{'AttachTickets'}
1134 ? @{ $ARGS{'AttachTickets'} }
1135 : ( $ARGS{'AttachTickets'} ) );
1138 foreach my $arg ( keys %ARGS ) {
1139 next if $arg =~ /-(?:Magic|Category)$/;
1141 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1142 $create_args{$arg} = $ARGS{$arg};
1145 # Object-RT::Ticket--CustomField-3-Values
1146 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1149 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1151 unless ( $cf->id ) {
1152 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1156 if ( $arg =~ /-Upload$/ ) {
1157 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1161 my $type = $cf->Type;
1164 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1165 @values = @{ $ARGS{$arg} };
1166 } elsif ( $type =~ /text/i ) {
1167 @values = ( $ARGS{$arg} );
1169 no warnings 'uninitialized';
1170 @values = split /\r*\n/, $ARGS{$arg};
1172 @values = grep length, map {
1178 grep defined, @values;
1180 $create_args{"CustomField-$cfid"} = \@values;
1184 # turn new link lists into arrays, and pass in the proper arguments
1186 'new-DependsOn' => 'DependsOn',
1187 'DependsOn-new' => 'DependedOnBy',
1188 'new-MemberOf' => 'Parents',
1189 'MemberOf-new' => 'Children',
1190 'new-RefersTo' => 'RefersTo',
1191 'RefersTo-new' => 'ReferredToBy',
1193 foreach my $key ( keys %map ) {
1194 next unless $ARGS{$key};
1195 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1199 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1204 push( @Actions, split( "\n", $ErrMsg ) );
1205 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1206 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1208 return ( $Ticket, @Actions );
1214 # {{{ sub LoadTicket - loads a ticket
1216 =head2 LoadTicket id
1218 Takes a ticket id as its only variable. if it's handed an array, it takes
1221 Returns an RT::Ticket object as the current user.
1228 if ( ref($id) eq "ARRAY" ) {
1233 Abort("No ticket specified");
1236 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1238 unless ( $Ticket->id ) {
1239 Abort("Could not load ticket $id");
1246 # {{{ sub ProcessUpdateMessage
1248 =head2 ProcessUpdateMessage
1250 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1252 Don't write message if it only contains current user's signature and
1253 SkipSignatureOnly argument is true. Function anyway adds attachments
1254 and updates time worked field even if skips message. The default value
1259 sub ProcessUpdateMessage {
1264 SkipSignatureOnly => 1,
1268 if ( $args{ARGSRef}->{'UpdateAttachments'}
1269 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1271 delete $args{ARGSRef}->{'UpdateAttachments'};
1274 # Strip the signature
1275 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1276 Content => $args{ARGSRef}->{UpdateContent},
1277 ContentType => $args{ARGSRef}->{UpdateContentType},
1278 StripSignature => $args{SkipSignatureOnly},
1279 CurrentUser => $args{'TicketObj'}->CurrentUser,
1282 # If, after stripping the signature, we have no message, move the
1283 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1284 # ProcessBasics can deal -- then bail out.
1285 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1286 and not length $args{ARGSRef}->{'UpdateContent'} )
1288 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1289 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1294 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1295 $args{ARGSRef}->{'UpdateSubject'} = undef;
1298 my $Message = MakeMIMEEntity(
1299 Subject => $args{ARGSRef}->{'UpdateSubject'},
1300 Body => $args{ARGSRef}->{'UpdateContent'},
1301 Type => $args{ARGSRef}->{'UpdateContentType'},
1304 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1305 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1307 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1308 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1309 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1311 $old_txn = $args{TicketObj}->Transactions->First();
1314 if ( my $msg = $old_txn->Message->First ) {
1315 RT::Interface::Email::SetInReplyTo(
1316 Message => $Message,
1321 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1322 $Message->make_multipart;
1323 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1326 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1327 require RT::Action::SendEmail;
1328 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1329 ref $args{ARGSRef}->{'AttachTickets'}
1330 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1331 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1334 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1335 my $cc = $args{ARGSRef}->{'UpdateCc'};
1337 my %message_args = (
1339 BccMessageTo => $bcc,
1340 Sign => $args{ARGSRef}->{'Sign'},
1341 Encrypt => $args{ARGSRef}->{'Encrypt'},
1342 MIMEObj => $Message,
1343 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
1347 foreach my $type (qw(Cc AdminCc)) {
1348 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1349 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1350 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1351 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1354 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1355 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1356 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1359 if (@temp_squelch) {
1360 require RT::Action::SendEmail;
1361 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1364 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1365 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1366 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1368 my $var = ucfirst($1) . 'MessageTo';
1370 if ( $message_args{$var} ) {
1371 $message_args{$var} .= ", $value";
1373 $message_args{$var} = $value;
1379 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1380 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1381 push( @results, $Description );
1382 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1383 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1384 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1385 push( @results, $Description );
1386 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1389 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1396 # {{{ sub MakeMIMEEntity
1398 =head2 MakeMIMEEntity PARAMHASH
1400 Takes a paramhash Subject, Body and AttachmentFieldName.
1402 Also takes Form, Cc and Type as optional paramhash keys.
1404 Returns a MIME::Entity.
1408 sub MakeMIMEEntity {
1410 #TODO document what else this takes.
1416 AttachmentFieldName => undef,
1420 my $Message = MIME::Entity->build(
1421 Type => 'multipart/mixed',
1422 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1423 grep defined $args{$_}, qw(Subject From Cc)
1426 if ( defined $args{'Body'} && length $args{'Body'} ) {
1428 # Make the update content have no 'weird' newlines in it
1429 $args{'Body'} =~ s/\r\n/\n/gs;
1432 Type => $args{'Type'} || 'text/plain',
1434 Data => $args{'Body'},
1438 if ( $args{'AttachmentFieldName'} ) {
1440 my $cgi_object = $m->cgi_object;
1442 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1444 my ( @content, $buffer );
1445 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1446 push @content, $buffer;
1449 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1451 # Prefer the cached name first over CGI.pm stringification.
1452 my $filename = $RT::Mason::CGI::Filename;
1453 $filename = "$filehandle" unless defined $filename;
1454 $filename = Encode::encode_utf8( $filename );
1455 $filename =~ s{^.*[\\/]}{};
1458 Type => $uploadinfo->{'Content-Type'},
1459 Filename => $filename,
1462 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1463 $Message->head->set( 'Subject' => $filename );
1468 $Message->make_singlepart;
1470 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1478 # {{{ sub ParseDateToISO
1480 =head2 ParseDateToISO
1482 Takes a date in an arbitrary format.
1483 Returns an ISO date and time in GMT
1487 sub ParseDateToISO {
1490 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1492 Format => 'unknown',
1495 return ( $date_obj->ISO );
1500 # {{{ sub ProcessACLChanges
1502 sub ProcessACLChanges {
1503 my $ARGSref = shift;
1507 foreach my $arg ( keys %$ARGSref ) {
1508 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1510 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1513 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1514 @rights = @{ $ARGSref->{$arg} };
1516 @rights = $ARGSref->{$arg};
1518 @rights = grep $_, @rights;
1519 next unless @rights;
1521 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1522 $principal->Load($principal_id);
1525 if ( $object_type eq 'RT::System' ) {
1527 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1528 $obj = $object_type->new( $session{'CurrentUser'} );
1529 $obj->Load($object_id);
1530 unless ( $obj->id ) {
1531 $RT::Logger->error("couldn't load $object_type #$object_id");
1535 $RT::Logger->error("object type '$object_type' is incorrect");
1536 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1540 foreach my $right (@rights) {
1541 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1542 push( @results, $msg );
1551 # {{{ sub UpdateRecordObj
1553 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1555 @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.
1557 Returns an array of success/failure messages
1561 sub UpdateRecordObject {
1564 AttributesRef => undef,
1566 AttributePrefix => undef,
1570 my $Object = $args{'Object'};
1571 my @results = $Object->Update(
1572 AttributesRef => $args{'AttributesRef'},
1573 ARGSRef => $args{'ARGSRef'},
1574 AttributePrefix => $args{'AttributePrefix'},
1582 # {{{ Sub ProcessCustomFieldUpdates
1584 sub ProcessCustomFieldUpdates {
1586 CustomFieldObj => undef,
1591 my $Object = $args{'CustomFieldObj'};
1592 my $ARGSRef = $args{'ARGSRef'};
1594 my @attribs = qw(Name Type Description Queue SortOrder);
1595 my @results = UpdateRecordObject(
1596 AttributesRef => \@attribs,
1601 my $prefix = "CustomField-" . $Object->Id;
1602 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1603 my ( $addval, $addmsg ) = $Object->AddValue(
1604 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1605 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1606 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1608 push( @results, $addmsg );
1612 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1613 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1614 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1616 foreach my $id (@delete_values) {
1617 next unless defined $id;
1618 my ( $err, $msg ) = $Object->DeleteValue($id);
1619 push( @results, $msg );
1622 my $vals = $Object->Values();
1623 while ( my $cfv = $vals->Next() ) {
1624 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1625 if ( $cfv->SortOrder != $so ) {
1626 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1627 push( @results, $msg );
1637 # {{{ sub ProcessTicketBasics
1639 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1641 Returns an array of results messages.
1645 sub ProcessTicketBasics {
1653 my $TicketObj = $args{'TicketObj'};
1654 my $ARGSRef = $args{'ARGSRef'};
1656 # {{{ Set basic fields
1669 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1670 my $tempqueue = RT::Queue->new($RT::SystemUser);
1671 $tempqueue->Load( $ARGSRef->{'Queue'} );
1672 if ( $tempqueue->id ) {
1673 $ARGSRef->{'Queue'} = $tempqueue->id;
1677 # Status isn't a field that can be set to a null value.
1678 # RT core complains if you try
1679 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1681 my @results = UpdateRecordObject(
1682 AttributesRef => \@attribs,
1683 Object => $TicketObj,
1684 ARGSRef => $ARGSRef,
1687 # We special case owner changing, so we can use ForceOwnerChange
1688 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1690 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1691 $ChownType = "Force";
1693 $ChownType = "Give";
1696 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1697 push( @results, $msg );
1707 sub ProcessTicketCustomFieldUpdates {
1709 $args{'Object'} = delete $args{'TicketObj'};
1710 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1712 # Build up a list of objects that we want to work with
1713 my %custom_fields_to_mod;
1714 foreach my $arg ( keys %$ARGSRef ) {
1715 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1716 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1717 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1718 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1722 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1725 sub ProcessObjectCustomFieldUpdates {
1727 my $ARGSRef = $args{'ARGSRef'};
1730 # Build up a list of objects that we want to work with
1731 my %custom_fields_to_mod;
1732 foreach my $arg ( keys %$ARGSRef ) {
1734 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1735 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1737 # For each of those objects, find out what custom fields we want to work with.
1738 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1741 # For each of those objects
1742 foreach my $class ( keys %custom_fields_to_mod ) {
1743 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1744 my $Object = $args{'Object'};
1745 $Object = $class->new( $session{'CurrentUser'} )
1746 unless $Object && ref $Object eq $class;
1748 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1749 unless ( $Object->id ) {
1750 $RT::Logger->warning("Couldn't load object $class #$id");
1754 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1755 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1756 $CustomFieldObj->LoadById($cf);
1757 unless ( $CustomFieldObj->id ) {
1758 $RT::Logger->warning("Couldn't load custom field #$cf");
1762 _ProcessObjectCustomFieldUpdates(
1763 Prefix => "Object-$class-$id-CustomField-$cf-",
1765 CustomField => $CustomFieldObj,
1766 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1774 sub _ProcessObjectCustomFieldUpdates {
1776 my $cf = $args{'CustomField'};
1777 my $cf_type = $cf->Type;
1779 # Remove blank Values since the magic field will take care of this. Sometimes
1780 # the browser gives you a blank value which causes CFs to be processed twice
1781 if ( defined $args{'ARGS'}->{'Values'}
1782 && !length $args{'ARGS'}->{'Values'}
1783 && $args{'ARGS'}->{'Values-Magic'} )
1785 delete $args{'ARGS'}->{'Values'};
1789 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1791 # skip category argument
1792 next if $arg eq 'Category';
1794 # since http won't pass in a form element with a null value, we need
1796 if ( $arg eq 'Values-Magic' ) {
1798 # We don't care about the magic, if there's really a values element;
1799 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1800 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1802 # "Empty" values does not mean anything for Image and Binary fields
1803 next if $cf_type =~ /^(?:Image|Binary)$/;
1806 $args{'ARGS'}->{'Values'} = undef;
1810 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1811 @values = @{ $args{'ARGS'}->{$arg} };
1812 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1813 @values = ( $args{'ARGS'}->{$arg} );
1815 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1816 if defined $args{'ARGS'}->{$arg};
1818 @values = grep length, map {
1824 grep defined, @values;
1826 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1827 foreach my $value (@values) {
1828 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1832 push( @results, $msg );
1834 } elsif ( $arg eq 'Upload' ) {
1835 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1836 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1837 push( @results, $msg );
1838 } elsif ( $arg eq 'DeleteValues' ) {
1839 foreach my $value (@values) {
1840 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1844 push( @results, $msg );
1846 } elsif ( $arg eq 'DeleteValueIds' ) {
1847 foreach my $value (@values) {
1848 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1852 push( @results, $msg );
1854 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1855 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1858 foreach my $value (@values) {
1859 if ( my $entry = $cf_values->HasEntry($value) ) {
1860 $values_hash{ $entry->id } = 1;
1864 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1868 push( @results, $msg );
1869 $values_hash{$val} = 1 if $val;
1872 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1873 return @results if ( $cf->Type eq 'Date' && ! @values );
1875 $cf_values->RedoSearch;
1876 while ( my $cf_value = $cf_values->Next ) {
1877 next if $values_hash{ $cf_value->id };
1879 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1881 ValueId => $cf_value->id
1883 push( @results, $msg );
1885 } elsif ( $arg eq 'Values' ) {
1886 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1888 # keep everything up to the point of difference, delete the rest
1890 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1891 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1900 # now add/replace extra things, if any
1901 foreach my $value (@values) {
1902 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1906 push( @results, $msg );
1911 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1912 $cf->Name, ref $args{'Object'},
1921 # {{{ sub ProcessTicketWatchers
1923 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1925 Returns an array of results messages.
1929 sub ProcessTicketWatchers {
1937 my $Ticket = $args{'TicketObj'};
1938 my $ARGSRef = $args{'ARGSRef'};
1942 foreach my $key ( keys %$ARGSRef ) {
1944 # Delete deletable watchers
1945 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1946 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1950 push @results, $msg;
1953 # Delete watchers in the simple style demanded by the bulk manipulator
1954 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1955 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1956 Email => $ARGSRef->{$key},
1959 push @results, $msg;
1962 # Add new wathchers by email address
1963 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1964 and $key =~ /^WatcherTypeEmail(\d*)$/ )
1967 #They're in this order because otherwise $1 gets clobbered :/
1968 my ( $code, $msg ) = $Ticket->AddWatcher(
1969 Type => $ARGSRef->{$key},
1970 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1972 push @results, $msg;
1975 #Add requestors in the simple style demanded by the bulk manipulator
1976 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1977 my ( $code, $msg ) = $Ticket->AddWatcher(
1979 Email => $ARGSRef->{$key}
1981 push @results, $msg;
1984 # Add new watchers by owner
1985 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1986 my $principal_id = $1;
1987 my $form = $ARGSRef->{$key};
1988 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1989 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1991 my ( $code, $msg ) = $Ticket->AddWatcher(
1993 PrincipalId => $principal_id
1995 push @results, $msg;
2005 # {{{ sub ProcessTicketDates
2007 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2009 Returns an array of results messages.
2013 sub ProcessTicketDates {
2020 my $Ticket = $args{'TicketObj'};
2021 my $ARGSRef = $args{'ARGSRef'};
2025 # {{{ Set date fields
2026 my @date_fields = qw(
2034 #Run through each field in this list. update the value if apropriate
2035 foreach my $field (@date_fields) {
2036 next unless exists $ARGSRef->{ $field . '_Date' };
2037 next if $ARGSRef->{ $field . '_Date' } eq '';
2041 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2043 Format => 'unknown',
2044 Value => $ARGSRef->{ $field . '_Date' }
2047 my $obj = $field . "Obj";
2048 if ( ( defined $DateObj->Unix )
2049 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2051 my $method = "Set$field";
2052 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2053 push @results, "$msg";
2063 # {{{ sub ProcessTicketLinks
2065 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2067 Returns an array of results messages.
2071 sub ProcessTicketLinks {
2078 my $Ticket = $args{'TicketObj'};
2079 my $ARGSRef = $args{'ARGSRef'};
2081 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2083 #Merge if we need to
2084 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2085 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2086 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2087 push @results, $msg;
2095 sub ProcessRecordLinks {
2102 my $Record = $args{'RecordObj'};
2103 my $ARGSRef = $args{'ARGSRef'};
2107 # Delete links that are gone gone gone.
2108 foreach my $arg ( keys %$ARGSRef ) {
2109 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2114 my ( $val, $msg ) = $Record->DeleteLink(
2120 push @results, $msg;
2126 my @linktypes = qw( DependsOn MemberOf RefersTo );
2128 foreach my $linktype (@linktypes) {
2129 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2130 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2131 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2133 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2135 $luri =~ s/\s+$//; # Strip trailing whitespace
2136 my ( $val, $msg ) = $Record->AddLink(
2140 push @results, $msg;
2143 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2144 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2145 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2147 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2149 my ( $val, $msg ) = $Record->AddLink(
2154 push @results, $msg;
2162 =head2 _UploadedFile ( $arg );
2164 Takes a CGI parameter name; if a file is uploaded under that name,
2165 return a hash reference suitable for AddCustomFieldValue's use:
2166 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2168 Returns C<undef> if no files were uploaded in the C<$arg> field.
2174 my $cgi_object = $m->cgi_object;
2175 my $fh = $cgi_object->upload($arg) or return undef;
2176 my $upload_info = $cgi_object->uploadInfo($fh);
2178 my $filename = "$fh";
2179 $filename =~ s#^.*[\\/]##;
2184 LargeContent => do { local $/; scalar <$fh> },
2185 ContentType => $upload_info->{'Content-Type'},
2189 sub GetColumnMapEntry {
2190 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2192 # deal with the simplest thing first
2193 if ( $args{'Map'}{ $args{'Name'} } ) {
2194 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2198 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2199 return undef unless $args{'Map'}->{$mainkey};
2200 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2201 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2203 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2208 sub ProcessColumnMapValue {
2210 my %args = ( Arguments => [], Escape => 1, @_ );
2213 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2214 my @tmp = $value->( @{ $args{'Arguments'} } );
2215 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2216 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2217 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2218 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2223 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2227 =head2 _load_container_object ( $type, $id );
2229 Instantiate container object for saving searches.
2233 sub _load_container_object {
2234 my ( $obj_type, $obj_id ) = @_;
2235 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2238 =head2 _parse_saved_search ( $arg );
2240 Given a serialization string for saved search, and returns the
2241 container object and the search id.
2245 sub _parse_saved_search {
2247 return unless $spec;
2248 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2255 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2258 eval "require RT::Interface::Web_Vendor";
2259 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2260 eval "require RT::Interface::Web_Local";
2261 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );