1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2013 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 sub _encode_surrogates {
114 my $uni = $_[0] - 0x10000;
115 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
120 return unless defined $$ref;
122 $$ref = "'" . join('',
124 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
125 $_ <= 255 ? sprintf("\\x%02X", $_) :
126 $_ <= 65535 ? sprintf("\\u%04X", $_) :
127 sprintf("\\u%X\\u%X", _encode_surrogates($_))
128 } unpack('U*', $$ref))
132 # {{{ WebCanonicalizeInfo
134 =head2 WebCanonicalizeInfo();
136 Different web servers set different environmental varibles. This
137 function must return something suitable for REMOTE_USER. By default,
138 just downcase $ENV{'REMOTE_USER'}
142 sub WebCanonicalizeInfo {
143 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
148 # {{{ WebExternalAutoInfo
150 =head2 WebExternalAutoInfo($user);
152 Returns a hash of user attributes, used when WebExternalAuto is set.
156 sub WebExternalAutoInfo {
161 # default to making Privileged users, even if they specify
162 # some other default Attributes
163 if ( !$RT::AutoCreate
164 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
166 $user_info{'Privileged'} = 1;
169 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
171 # Populate fields with information from Unix /etc/passwd
173 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
174 $user_info{'Comments'} = $comments if defined $comments;
175 $user_info{'RealName'} = $realname if defined $realname;
176 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
178 # Populate fields with information from NT domain controller
181 # and return the wad of stuff
190 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
192 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
194 # Roll back any dangling transactions from a previous failed connection
195 $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth;
197 MaybeEnableSQLStatementLog();
199 # avoid reentrancy, as suggested by masonbook
200 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
202 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
203 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
206 PreprocessTimeUpdates($ARGS);
208 MaybeShowInstallModePage();
210 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
212 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
214 # Process session-related callbacks before any auth attempts
215 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
217 MaybeRejectPrivateComponentRequest();
219 MaybeShowNoAuthPage($ARGS);
221 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
223 _ForceLogout() unless _UserLoggedIn();
225 # Process per-page authentication callbacks
226 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
228 unless ( _UserLoggedIn() ) {
231 # Authenticate if the user is trying to login via user/pass query args
232 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
235 my $m = $HTML::Mason::Commands::m;
237 # REST urls get a special 401 response
238 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
239 $HTML::Mason::Commands::r->content_type("text/plain");
240 $m->error_format("text");
241 $m->out("RT/$RT::VERSION 401 Credentials required\n");
242 $m->out("\n$msg\n") if $msg;
245 # Specially handle /index.html so that we get a nicer URL
246 elsif ( $m->request_comp->path eq '/index.html' ) {
247 my $next = SetNextPage($ARGS);
248 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
252 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
257 MaybeShowInterstitialCSRFPage($ARGS);
259 # now it applies not only to home page, but any dashboard that can be used as a workspace
260 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
261 if ( $ARGS->{'HomeRefreshInterval'} );
263 # Process per-page global callbacks
264 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
266 ShowRequestedPage($ARGS);
267 LogRecordedSQLStatements();
269 # Process per-page final cleanup callbacks
270 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
275 delete $HTML::Mason::Commands::session{'CurrentUser'};
279 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
287 =head2 LoginError ERROR
289 Pushes a login error into the Actions session store and returns the hash key.
295 my $key = Digest::MD5::md5_hex( rand(1024) );
296 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
297 $HTML::Mason::Commands::session{'i'}++;
301 =head2 SetNextPage ARGSRef [PATH]
303 Intuits and stashes the next page in the sesssion hash. If PATH is
304 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
311 my $next = $_[0] ? $_[0] : IntuitNextPage();
312 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
313 my $page = { url => $next };
315 # If an explicit URL was passed and we didn't IntuitNextPage, then
316 # IsPossibleCSRF below is almost certainly unrelated to the actual
317 # destination. Currently explicit next pages aren't used in RT, but the
319 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
320 # This isn't really CSRF, but the CSRF heuristics are useful for catching
321 # requests which may have unintended side-effects.
322 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
325 "Marking original destination as having side-effects before redirecting for login.\n"
327 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
329 $page->{'HasSideEffects'} = [$msg, @loc];
333 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
334 $HTML::Mason::Commands::session{'i'}++;
338 =head2 FetchNextPage HASHKEY
340 Returns the stashed next page hashref for the given hash.
345 my $hash = shift || "";
346 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
349 =head2 RemoveNextPage HASHKEY
351 Removes the stashed next page for the given hash and returns it.
356 my $hash = shift || "";
357 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
360 =head2 TangentForLogin ARGSRef [HASH]
362 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
363 the next page. Takes a hashref of request %ARGS as the first parameter.
364 Optionally takes all other parameters as a hash which is dumped into query
369 sub TangentForLogin {
371 my $hash = SetNextPage($ARGS);
372 my %query = (@_, next => $hash);
373 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
374 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
378 =head2 TangentForLoginWithError ERROR
380 Localizes the passed error message, stashes it with L<LoginError> and then
381 calls L<TangentForLogin> with the appropriate results key.
385 sub TangentForLoginWithError {
387 my $key = LoginError(HTML::Mason::Commands::loc(@_));
388 TangentForLogin( $ARGS, results => $key );
391 =head2 IntuitNextPage
393 Attempt to figure out the path to which we should return the user after a
394 tangent. The current request URL is used, or failing that, the C<WebURL>
395 configuration variable.
402 # This includes any query parameters. Redirect will take care of making
403 # it an absolute URL.
404 if ($ENV{'REQUEST_URI'}) {
405 $req_uri = $ENV{'REQUEST_URI'};
407 # collapse multiple leading slashes so the first part doesn't look like
408 # a hostname of a schema-less URI
409 $req_uri =~ s{^/+}{/};
412 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
415 my $uri = URI->new($next);
417 # You get undef scheme with a relative uri like "/Search/Build.html"
418 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
419 $next = RT->Config->Get('WebURL');
422 # Make sure we're logging in to the same domain
423 # You can get an undef authority with a relative uri like "index.html"
424 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
425 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
426 $next = RT->Config->Get('WebURL');
432 =head2 MaybeShowInstallModePage
434 This function, called exclusively by RT's autohandler, dispatches
435 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
437 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
441 sub MaybeShowInstallModePage {
442 return unless RT->InstallMode;
444 my $m = $HTML::Mason::Commands::m;
445 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
447 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
448 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
455 =head2 MaybeShowNoAuthPage \%ARGS
457 This function, called exclusively by RT's autohandler, dispatches
458 a request to the page a user requested (but only if it matches the "noauth" regex.
460 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
464 sub MaybeShowNoAuthPage {
467 my $m = $HTML::Mason::Commands::m;
469 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
471 # Don't show the login page to logged in users
472 Redirect(RT->Config->Get('WebURL'))
473 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
475 # If it's a noauth file, don't ask for auth.
476 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
480 =head2 MaybeRejectPrivateComponentRequest
482 This function will reject calls to private components, like those under
483 C</Elements>. If the requested path is a private component then we will
484 abort with a C<403> error.
488 sub MaybeRejectPrivateComponentRequest {
489 my $m = $HTML::Mason::Commands::m;
490 my $path = $m->request_comp->path;
492 # We do not check for dhandler here, because requesting our dhandlers
493 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
499 _elements | # mobile UI
502 autohandler | # requesting this directly is suspicious
503 l (_unsafe)? ) # loc component
504 ( $ | / ) # trailing slash or end of path
506 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
509 warn "rejecting private component $path\n";
516 =head2 ShowRequestedPage \%ARGS
518 This function, called exclusively by RT's autohandler, dispatches
519 a request to the page a user requested (making sure that unpriviled users
520 can only see self-service pages.
524 sub ShowRequestedPage {
527 my $m = $HTML::Mason::Commands::m;
529 # Ensure that the cookie that we send is up-to-date, in case the
530 # session-id has been modified in any way
533 # If the user isn't privileged, they can only see SelfService
534 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
536 # if the user is trying to access a ticket, redirect them
537 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
538 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
541 # otherwise, drop the user at the SelfService default page
542 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
543 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
546 # if user is in SelfService dir let him do anything
548 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
551 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
556 sub AttemptExternalAuth {
559 return unless ( RT->Config->Get('WebExternalAuth') );
561 my $user = $ARGS->{user};
562 my $m = $HTML::Mason::Commands::m;
564 # If RT is configured for external auth, let's go through and get REMOTE_USER
566 # do we actually have a REMOTE_USER equivlent?
567 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
568 my $orig_user = $user;
570 $user = RT::Interface::Web::WebCanonicalizeInfo();
571 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
573 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
574 my $NodeName = Win32::NodeName();
575 $user =~ s/^\Q$NodeName\E\\//i;
578 my $next = RemoveNextPage($ARGS->{'next'});
579 $next = $next->{'url'} if ref $next;
580 InstantiateNewSession() unless _UserLoggedIn;
581 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
582 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
584 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
586 # Create users on-the-fly
587 my $UserObj = RT::User->new($RT::SystemUser);
588 my ( $val, $msg ) = $UserObj->Create(
589 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
596 # now get user specific information, to better create our user.
597 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
599 # set the attributes that have been defined.
600 foreach my $attribute ( $UserObj->WritableAttributes ) {
602 Attribute => $attribute,
604 UserInfo => $new_user_info,
605 CallbackName => 'NewUser',
606 CallbackPage => '/autohandler'
608 my $method = "Set$attribute";
609 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
611 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
614 # we failed to successfully create the user. abort abort abort.
615 delete $HTML::Mason::Commands::session{'CurrentUser'};
617 if (RT->Config->Get('WebFallbackToInternalAuth')) {
618 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
625 if ( _UserLoggedIn() ) {
626 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
627 # It is possible that we did a redirect to the login page,
628 # if the external auth allows lack of auth through with no
629 # REMOTE_USER set, instead of forcing a "permission
630 # denied" message. Honor the $next.
631 Redirect($next) if $next;
632 # Unlike AttemptPasswordAuthentication below, we do not
633 # force a redirect to / if $next is not set -- otherwise,
634 # straight-up external auth would always redirect to /
635 # when you first hit it.
637 delete $HTML::Mason::Commands::session{'CurrentUser'};
640 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
641 TangentForLoginWithError($ARGS, 'You are not an authorized user');
644 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
645 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
646 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
647 TangentForLoginWithError($ARGS, 'You are not an authorized user');
651 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
652 # XXX: we must return AUTH_REQUIRED status or we fallback to
653 # internal auth here too.
654 delete $HTML::Mason::Commands::session{'CurrentUser'}
655 if defined $HTML::Mason::Commands::session{'CurrentUser'};
659 sub AttemptPasswordAuthentication {
661 return unless defined $ARGS->{user} && defined $ARGS->{pass};
663 my $user_obj = RT::CurrentUser->new();
664 $user_obj->Load( $ARGS->{user} );
666 my $m = $HTML::Mason::Commands::m;
668 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
669 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
670 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
671 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
674 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
676 # It's important to nab the next page from the session before we blow
678 my $next = RemoveNextPage($ARGS->{'next'});
679 $next = $next->{'url'} if ref $next;
681 InstantiateNewSession();
682 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
684 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
686 # Really the only time we don't want to redirect here is if we were
687 # passed user and pass as query params in the URL.
691 elsif ($ARGS->{'next'}) {
692 # Invalid hash, but still wants to go somewhere, take them to /
693 Redirect(RT->Config->Get('WebURL'));
696 return (1, HTML::Mason::Commands::loc('Logged in'));
700 =head2 LoadSessionFromCookie
702 Load or setup a session cookie for the current user.
706 sub _SessionCookieName {
707 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
708 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
712 sub LoadSessionFromCookie {
714 my %cookies = CGI::Cookie->fetch;
715 my $cookiename = _SessionCookieName();
716 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
717 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
718 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
719 undef $cookies{$cookiename};
721 if ( int RT->Config->Get('AutoLogoff') ) {
722 my $now = int( time / 60 );
723 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
725 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
726 InstantiateNewSession();
729 # save session on each request when AutoLogoff is turned on
730 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
734 sub InstantiateNewSession {
735 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
736 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
740 sub SendSessionCookie {
741 my $cookie = CGI::Cookie->new(
742 -name => _SessionCookieName(),
743 -value => $HTML::Mason::Commands::session{_session_id},
744 -path => RT->Config->Get('WebPath'),
745 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
746 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
749 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
754 This routine ells the current user's browser to redirect to URL.
755 Additionally, it unties the user's currently active session, helping to avoid
756 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
757 a cached DBI statement handle twice at the same time.
762 my $redir_to = shift;
763 untie $HTML::Mason::Commands::session;
764 my $uri = URI->new($redir_to);
765 my $server_uri = URI->new( RT->Config->Get('WebURL') );
767 # Make relative URIs absolute from the server host and scheme
768 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
769 if (not defined $uri->host) {
770 $uri->host($server_uri->host);
771 $uri->port($server_uri->port);
774 # If the user is coming in via a non-canonical
775 # hostname, don't redirect them to the canonical host,
776 # it will just upset them (and invalidate their credentials)
777 # don't do this if $RT::CanoniaclRedirectURLs is true
778 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
779 && $uri->host eq $server_uri->host
780 && $uri->port eq $server_uri->port )
782 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
783 $uri->scheme('https');
785 $uri->scheme('http');
788 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
789 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
790 $uri->port( $ENV{'SERVER_PORT'} );
793 # not sure why, but on some systems without this call mason doesn't
794 # set status to 302, but 200 instead and people see blank pages
795 $HTML::Mason::Commands::r->status(302);
797 # Perlbal expects a status message, but Mason's default redirect status
798 # doesn't provide one. See also rt.cpan.org #36689.
799 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
801 $HTML::Mason::Commands::m->abort;
804 =head2 StaticFileHeaders
806 Send the browser a few headers to try to get it to (somewhat agressively)
807 cache RT's static Javascript and CSS files.
809 This routine could really use _accurate_ heuristics. (XXX TODO)
813 sub StaticFileHeaders {
814 my $date = RT::Date->new($RT::SystemUser);
817 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
819 # remove any cookie headers -- if it is cached publicly, it
820 # shouldn't include anyone's cookie!
821 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
823 # Expire things in a month.
824 $date->Set( Value => time + 30 * 24 * 60 * 60 );
825 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
827 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
828 # request, but we don't handle it and generate full reply again
829 # Last modified at server start time
830 # $date->Set( Value => $^T );
831 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
834 =head2 ComponentPathIsSafe PATH
836 Takes C<PATH> and returns a boolean indicating that the user-specified partial
837 component path is safe.
839 Currently "safe" means that the path does not start with a dot (C<.>), does
840 not contain a slash-dot C</.>, and does not contain any nulls.
844 sub ComponentPathIsSafe {
847 return $path !~ m{(?:^|/)\.} and $path !~ m{\0};
852 Takes a C<< Path => path >> and returns a boolean indicating that
853 the path is safely within RT's control or not. The path I<must> be
856 This function does not consult the filesystem at all; it is merely
857 a logical sanity checking of the path. This explicitly does not handle
858 symlinks; if you have symlinks in RT's webroot pointing outside of it,
859 then we assume you know what you are doing.
866 my $path = $args{Path};
868 # Get File::Spec to clean up extra /s, ./, etc
869 my $cleaned_up = File::Spec->canonpath($path);
871 if (!defined($cleaned_up)) {
872 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
876 # Forbid too many ..s. We can't just sum then check because
877 # "../foo/bar/baz" should be illegal even though it has more
878 # downdirs than updirs. So as soon as we get a negative score
879 # (which means "breaking out" of the top level) we reject the path.
881 my @components = split '/', $cleaned_up;
883 for my $component (@components) {
884 if ($component eq '..') {
887 $RT::Logger->info("Rejecting unsafe path: $path");
891 elsif ($component eq '.' || $component eq '') {
892 # these two have no effect on $score
902 =head2 SendStaticFile
904 Takes a File => path and a Type => Content-type
906 If Type isn't provided and File is an image, it will
907 figure out a sane Content-type, otherwise it will
908 send application/octet-stream
910 Will set caching headers using StaticFileHeaders
917 my $file = $args{File};
918 my $type = $args{Type};
919 my $relfile = $args{RelativeFile};
921 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
922 $HTML::Mason::Commands::r->status(400);
923 $HTML::Mason::Commands::m->abort;
926 $self->StaticFileHeaders();
929 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
931 $type =~ s/jpg/jpeg/gi;
933 $type ||= "application/octet-stream";
936 # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
937 # since we don't specify a charset
938 if ( $type =~ m{application/javascript} &&
939 $type !~ m{charset=([\w-]+)$} ) {
940 $type .= "; charset=utf-8";
942 $HTML::Mason::Commands::r->content_type($type);
943 open( my $fh, '<', $file ) or die "couldn't open file: $!";
947 $HTML::Mason::Commands::m->out($_) while (<$fh>);
948 $HTML::Mason::Commands::m->flush_buffer;
955 my $content = $args{Content};
956 return '' unless $content;
958 # Make the content have no 'weird' newlines in it
959 $content =~ s/\r+\n/\n/g;
961 my $return_content = $content;
963 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
964 my $sigonly = $args{StripSignature};
966 # massage content to easily detect if there's any real content
967 $content =~ s/\s+//g; # yes! remove all the spaces
969 # remove html version of spaces and newlines
970 $content =~ s! !!g;
971 $content =~ s!<br/?>!!g;
974 # Filter empty content when type is text/html
975 return '' if $html && $content !~ /\S/;
977 # If we aren't supposed to strip the sig, just bail now.
978 return $return_content unless $sigonly;
981 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
984 # Check for plaintext sig
985 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
987 # Check for html-formatted sig; we don't use EscapeUTF8 here
988 # because we want to precisely match the escaping that FCKEditor
989 # uses. see also 311223f5, which fixed this for 4.0
996 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
999 return $return_content;
1007 # if they've passed multiple values, they'll be an array. if they've
1008 # passed just one, a scalar whatever they are, mark them as utf8
1011 ? Encode::is_utf8($_)
1013 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1014 : ( $type eq 'ARRAY' )
1015 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1017 : ( $type eq 'HASH' )
1018 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1024 sub PreprocessTimeUpdates {
1027 # Later in the code we use
1028 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1029 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1030 # The call_next method pass through original arguments and if you have
1031 # an argument with unicode key then in a next component you'll get two
1032 # records in the args hash: one with key without UTF8 flag and another
1033 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1034 # is copied from mason's source to get the same results as we get from
1035 # call_next method, this feature is not documented, so we just leave it
1036 # here to avoid possible side effects.
1038 # This code canonicalizes time inputs in hours into minutes
1039 foreach my $field ( keys %$ARGS ) {
1040 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1042 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1043 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1044 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1045 $ARGS->{$local} *= 60;
1047 delete $ARGS->{$field};
1052 sub MaybeEnableSQLStatementLog {
1054 my $log_sql_statements = RT->Config->Get('StatementLog');
1056 if ($log_sql_statements) {
1057 $RT::Handle->ClearSQLStatementLog;
1058 $RT::Handle->LogSQLStatements(1);
1063 sub LogRecordedSQLStatements {
1064 my $log_sql_statements = RT->Config->Get('StatementLog');
1066 return unless ($log_sql_statements);
1068 my @log = $RT::Handle->SQLStatementLog;
1069 $RT::Handle->ClearSQLStatementLog;
1070 for my $stmt (@log) {
1071 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1081 level => $log_sql_statements,
1083 . sprintf( "%.6f", $duration )
1085 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
1091 our %is_whitelisted_component = (
1092 # The RSS feed embeds an auth token in the path, but query
1093 # information for the search. Because it's a straight-up read, in
1094 # addition to embedding its own auth, it's fine.
1095 '/NoAuth/rss/dhandler' => 1,
1097 # IE doesn't send referer in window.open()
1098 # besides, as a harmless calendar select page, it's fine
1099 '/Helpers/CalPopup.html' => 1,
1101 # While both of these can be used for denial-of-service against RT
1102 # (construct a very inefficient query and trick lots of users into
1103 # running them against RT) it's incredibly useful to be able to link
1104 # to a search result or bookmark a result page.
1105 '/Search/Results.html' => 1,
1106 '/Search/Simple.html' => 1,
1109 # Components which are blacklisted from automatic, argument-based whitelisting.
1110 # These pages are not idempotent when called with just an id.
1111 our %is_blacklisted_component = (
1112 # Takes only id and toggles bookmark state
1113 '/Helpers/Toggle/TicketBookmark' => 1,
1116 sub IsCompCSRFWhitelisted {
1120 return 1 if $is_whitelisted_component{$comp};
1122 my %args = %{ $ARGS };
1124 # If the user specifies a *correct* user and pass then they are
1125 # golden. This acts on the presumption that external forms may
1126 # hardcode a username and password -- if a malicious attacker knew
1127 # both already, CSRF is the least of your problems.
1128 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1129 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1130 my $user_obj = RT::CurrentUser->new();
1131 $user_obj->Load($args{user});
1132 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1138 # Some pages aren't idempotent even with safe args like id; blacklist
1139 # them from the automatic whitelisting below.
1140 return 0 if $is_blacklisted_component{$comp};
1142 # Eliminate arguments that do not indicate an effectful request.
1143 # For example, "id" is acceptable because that is how RT retrieves a
1147 # If they have a valid results= from MaybeRedirectForResults, that's
1149 delete $args{results} if $args{results}
1150 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1152 # The homepage refresh, which uses the Refresh header, doesn't send
1153 # a referer in most browsers; whitelist the one parameter it reloads
1154 # with, HomeRefreshInterval, which is safe
1155 delete $args{HomeRefreshInterval};
1157 # If there are no arguments, then it's likely to be an idempotent
1158 # request, which are not susceptible to CSRF
1164 sub IsRefererCSRFWhitelisted {
1165 my $referer = _NormalizeHost(shift);
1166 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1167 $base_url = $base_url->host_port;
1170 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1171 push @$configs,$config;
1172 return 1 if $referer->host_port eq $config;
1175 return (0,$referer,$configs);
1178 =head3 _NormalizeHost
1180 Takes a URI and creates a URI object that's been normalized
1181 to handle common problems such as localhost vs 127.0.0.1
1185 sub _NormalizeHost {
1187 my $uri= URI->new(shift);
1188 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1194 sub IsPossibleCSRF {
1197 # If first request on this session is to a REST endpoint, then
1198 # whitelist the REST endpoints -- and explicitly deny non-REST
1199 # endpoints. We do this because using a REST cookie in a browser
1200 # would open the user to CSRF attacks to the REST endpoints.
1201 my $comp = $HTML::Mason::Commands::m->request_comp->path;
1202 $HTML::Mason::Commands::session{'REST'} = $comp =~ m{^/REST/\d+\.\d+/}
1203 unless defined $HTML::Mason::Commands::session{'REST'};
1205 if ($HTML::Mason::Commands::session{'REST'}) {
1206 return 0 if $comp =~ m{^/REST/\d+\.\d+/};
1208 This login session belongs to a REST client, and cannot be used to
1209 access non-REST interfaces of RT for security reasons.
1211 my $details = <<EOT;
1212 Please log out and back in to obtain a session for normal browsing. If
1213 you understand the security implications, disabling RT's CSRF protection
1214 will remove this restriction.
1217 HTML::Mason::Commands::Abort( $why, Details => $details );
1220 return 0 if IsCompCSRFWhitelisted( $comp, $ARGS );
1222 # if there is no Referer header then assume the worst
1224 "your browser did not supply a Referrer header", # loc
1225 ) if !$ENV{HTTP_REFERER};
1227 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1228 return 0 if $whitelisted;
1230 if ( @$configs > 1 ) {
1232 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1233 $browser->host_port,
1235 join(', ', @$configs) );
1239 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1240 $browser->host_port,
1244 sub ExpandCSRFToken {
1247 my $token = delete $ARGS->{CSRF_Token};
1248 return unless $token;
1250 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1251 return unless $data;
1252 return unless $data->{uri} eq $HTML::Mason::Commands::r->uri;
1254 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1255 return unless $user->ValidateAuthString( $data->{auth}, $token );
1257 %{$ARGS} = %{$data->{args}};
1259 # We explicitly stored file attachments with the request, but not in
1260 # the session yet, as that would itself be an attack. Put them into
1261 # the session now, so they'll be visible.
1262 if ($data->{attach}) {
1263 my $filename = $data->{attach}{filename};
1264 my $mime = $data->{attach}{mime};
1265 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1272 sub StoreRequestToken {
1275 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1276 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1278 auth => $user->GenerateAuthString( $token ),
1279 uri => $HTML::Mason::Commands::r->uri,
1282 if ($ARGS->{Attach}) {
1283 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1284 my $file_path = delete $ARGS->{'Attach'};
1286 filename => Encode::decode_utf8("$file_path"),
1287 mime => $attachment,
1291 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1292 $HTML::Mason::Commands::session{'i'}++;
1296 sub MaybeShowInterstitialCSRFPage {
1299 return unless RT->Config->Get('RestrictReferrer');
1301 # Deal with the form token provided by the interstitial, which lets
1302 # browsers which never set referer headers still use RT, if
1303 # painfully. This blows values into ARGS
1304 return if ExpandCSRFToken($ARGS);
1306 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1307 return if !$is_csrf;
1309 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1311 my $token = StoreRequestToken($ARGS);
1312 $HTML::Mason::Commands::m->comp(
1314 OriginalURL => $HTML::Mason::Commands::r->uri,
1315 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1318 # Calls abort, never gets here
1321 our @POTENTIAL_PAGE_ACTIONS = (
1322 qr'/Ticket/Create.html' => "create a ticket", # loc
1323 qr'/Ticket/' => "update a ticket", # loc
1324 qr'/Admin/' => "modify RT's configuration", # loc
1325 qr'/Approval/' => "update an approval", # loc
1326 qr'/Dashboards/' => "modify a dashboard", # loc
1327 qr'/m/ticket/' => "update a ticket", # loc
1328 qr'Prefs' => "modify your preferences", # loc
1329 qr'/Search/' => "modify or access a search", # loc
1330 qr'/SelfService/Create' => "create a ticket", # loc
1331 qr'/SelfService/' => "update a ticket", # loc
1334 sub PotentialPageAction {
1336 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1337 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1338 return HTML::Mason::Commands::loc($result)
1339 if $page =~ $pattern;
1344 package HTML::Mason::Commands;
1346 use vars qw/$r $m %session/;
1352 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1353 with whatever it's called with. If there is no $session{'CurrentUser'},
1354 it creates a temporary user, so we have something to get a localisation handle
1361 if ( $session{'CurrentUser'}
1362 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1364 return ( $session{'CurrentUser'}->loc(@_) );
1367 RT::CurrentUser->new();
1371 return ( $u->loc(@_) );
1374 # pathetic case -- SystemUser is gone.
1383 =head2 loc_fuzzy STRING
1385 loc_fuzzy is for handling localizations of messages that may already
1386 contain interpolated variables, typically returned from libraries
1387 outside RT's control. It takes the message string and extracts the
1388 variable array automatically by matching against the candidate entries
1389 inside the lexicon file.
1396 if ( $session{'CurrentUser'}
1397 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1399 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1401 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1402 return ( $u->loc_fuzzy($msg) );
1409 # Error - calls Error and aborts
1414 if ( $session{'ErrorDocument'}
1415 && $session{'ErrorDocumentType'} )
1417 $r->content_type( $session{'ErrorDocumentType'} );
1418 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1421 $m->comp( "/Elements/Error", Why => $why, %args );
1428 # {{{ sub CreateTicket
1430 =head2 CreateTicket ARGS
1432 Create a new ticket, using Mason's %ARGS. returns @results.
1441 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1443 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1444 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1445 Abort('Queue not found');
1448 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1449 Abort('You have no permission to create tickets in that queue.');
1453 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1454 $due = new RT::Date( $session{'CurrentUser'} );
1455 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1458 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1459 $starts = new RT::Date( $session{'CurrentUser'} );
1460 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1463 my $sigless = RT::Interface::Web::StripContent(
1464 Content => $ARGS{Content},
1465 ContentType => $ARGS{ContentType},
1466 StripSignature => 1,
1467 CurrentUser => $session{'CurrentUser'},
1470 my $MIMEObj = MakeMIMEEntity(
1471 Subject => $ARGS{'Subject'},
1472 From => $ARGS{'From'},
1475 Type => $ARGS{'ContentType'},
1478 if ( $ARGS{'Attachments'} ) {
1479 my $rv = $MIMEObj->make_multipart;
1480 $RT::Logger->error("Couldn't make multipart message")
1481 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1483 foreach ( values %{ $ARGS{'Attachments'} } ) {
1485 $RT::Logger->error("Couldn't add empty attachemnt");
1488 $MIMEObj->add_part($_);
1492 for my $argument (qw(Encrypt Sign)) {
1493 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1497 Type => $ARGS{'Type'} || 'ticket',
1498 Queue => $ARGS{'Queue'},
1499 Owner => $ARGS{'Owner'},
1502 Requestor => $ARGS{'Requestors'},
1504 AdminCc => $ARGS{'AdminCc'},
1505 InitialPriority => $ARGS{'InitialPriority'},
1506 FinalPriority => $ARGS{'FinalPriority'},
1507 TimeLeft => $ARGS{'TimeLeft'},
1508 TimeEstimated => $ARGS{'TimeEstimated'},
1509 TimeWorked => $ARGS{'TimeWorked'},
1510 Subject => $ARGS{'Subject'},
1511 Status => $ARGS{'Status'},
1512 Due => $due ? $due->ISO : undef,
1513 Starts => $starts ? $starts->ISO : undef,
1518 foreach my $type (qw(Requestor Cc AdminCc)) {
1519 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1520 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1524 if (@temp_squelch) {
1525 require RT::Action::SendEmail;
1526 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1529 if ( $ARGS{'AttachTickets'} ) {
1530 require RT::Action::SendEmail;
1531 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1532 ref $ARGS{'AttachTickets'}
1533 ? @{ $ARGS{'AttachTickets'} }
1534 : ( $ARGS{'AttachTickets'} ) );
1537 foreach my $arg ( keys %ARGS ) {
1538 next if $arg =~ /-(?:Magic|Category)$/;
1540 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1541 $create_args{$arg} = $ARGS{$arg};
1544 # Object-RT::Ticket--CustomField-3-Values
1545 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1548 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1549 $cf->SetContextObject( $Queue );
1551 unless ( $cf->id ) {
1552 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1556 if ( $arg =~ /-Upload$/ ) {
1557 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1561 my $type = $cf->Type;
1564 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1565 @values = @{ $ARGS{$arg} };
1566 } elsif ( $type =~ /text/i ) {
1567 @values = ( $ARGS{$arg} );
1569 no warnings 'uninitialized';
1570 @values = split /\r*\n/, $ARGS{$arg};
1572 @values = grep length, map {
1578 grep defined, @values;
1580 $create_args{"CustomField-$cfid"} = \@values;
1584 # turn new link lists into arrays, and pass in the proper arguments
1586 'new-DependsOn' => 'DependsOn',
1587 'DependsOn-new' => 'DependedOnBy',
1588 'new-MemberOf' => 'Parents',
1589 'MemberOf-new' => 'Children',
1590 'new-RefersTo' => 'RefersTo',
1591 'RefersTo-new' => 'ReferredToBy',
1593 foreach my $key ( keys %map ) {
1594 next unless $ARGS{$key};
1595 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1599 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1604 push( @Actions, split( "\n", $ErrMsg ) );
1605 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1606 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1608 return ( $Ticket, @Actions );
1614 # {{{ sub LoadTicket - loads a ticket
1616 =head2 LoadTicket id
1618 Takes a ticket id as its only variable. if it's handed an array, it takes
1621 Returns an RT::Ticket object as the current user.
1628 if ( ref($id) eq "ARRAY" ) {
1633 Abort("No ticket specified");
1636 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1638 unless ( $Ticket->id ) {
1639 Abort("Could not load ticket $id");
1646 # {{{ sub ProcessUpdateMessage
1648 =head2 ProcessUpdateMessage
1650 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1652 Don't write message if it only contains current user's signature and
1653 SkipSignatureOnly argument is true. Function anyway adds attachments
1654 and updates time worked field even if skips message. The default value
1659 # change from stock: if txn custom fields are set but there's no content
1660 # or attachment, create a Touch txn instead of doing nothing
1662 sub ProcessUpdateMessage {
1667 SkipSignatureOnly => 1,
1671 if ( $args{ARGSRef}->{'UpdateAttachments'}
1672 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1674 delete $args{ARGSRef}->{'UpdateAttachments'};
1677 # Strip the signature
1678 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1679 Content => $args{ARGSRef}->{UpdateContent},
1680 ContentType => $args{ARGSRef}->{UpdateContentType},
1681 StripSignature => $args{SkipSignatureOnly},
1682 CurrentUser => $args{'TicketObj'}->CurrentUser,
1685 my %txn_customfields;
1687 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1688 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1689 next if $key =~ /(TimeUnits|Magic)$/;
1690 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1694 # If, after stripping the signature, we have no message, create a
1695 # Touch transaction if necessary
1696 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1697 and not length $args{ARGSRef}->{'UpdateContent'} )
1699 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1700 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1701 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
1704 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1705 if ( $timetaken or grep {length $_} values %txn_customfields ) {
1706 my ( $Transaction, $Description, $Object ) =
1707 $args{TicketObj}->Touch(
1708 CustomFields => \%txn_customfields,
1709 TimeTaken => $timetaken
1711 return $Description;
1716 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1717 $args{ARGSRef}->{'UpdateSubject'} = undef;
1720 my $Message = MakeMIMEEntity(
1721 Subject => $args{ARGSRef}->{'UpdateSubject'},
1722 Body => $args{ARGSRef}->{'UpdateContent'},
1723 Type => $args{ARGSRef}->{'UpdateContentType'},
1726 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1727 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1729 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1730 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1731 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1733 $old_txn = $args{TicketObj}->Transactions->First();
1736 if ( my $msg = $old_txn->Message->First ) {
1737 RT::Interface::Email::SetInReplyTo(
1738 Message => $Message,
1743 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1744 $Message->make_multipart;
1745 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1748 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1749 require RT::Action::SendEmail;
1750 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1751 ref $args{ARGSRef}->{'AttachTickets'}
1752 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1753 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1756 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1757 my $cc = $args{ARGSRef}->{'UpdateCc'};
1759 my %message_args = (
1761 BccMessageTo => $bcc,
1762 Sign => $args{ARGSRef}->{'Sign'},
1763 Encrypt => $args{ARGSRef}->{'Encrypt'},
1764 MIMEObj => $Message,
1765 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1766 CustomFields => \%txn_customfields,
1770 foreach my $type (qw(Cc AdminCc)) {
1771 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1772 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1773 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1774 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1777 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1778 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1779 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1782 if (@temp_squelch) {
1783 require RT::Action::SendEmail;
1784 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1787 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1788 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1789 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1791 my $var = ucfirst($1) . 'MessageTo';
1793 if ( $message_args{$var} ) {
1794 $message_args{$var} .= ", $value";
1796 $message_args{$var} = $value;
1802 # Do the update via the appropriate Ticket method
1803 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1804 my ( $Transaction, $Description, $Object ) =
1805 $args{TicketObj}->Comment(%message_args);
1806 push( @results, $Description );
1807 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1808 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1809 my ( $Transaction, $Description, $Object ) =
1810 $args{TicketObj}->Correspond(%message_args);
1811 push( @results, $Description );
1812 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1815 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1822 # {{{ sub MakeMIMEEntity
1824 =head2 MakeMIMEEntity PARAMHASH
1826 Takes a paramhash Subject, Body and AttachmentFieldName.
1828 Also takes Form, Cc and Type as optional paramhash keys.
1830 Returns a MIME::Entity.
1834 sub MakeMIMEEntity {
1836 #TODO document what else this takes.
1842 AttachmentFieldName => undef,
1846 my $Message = MIME::Entity->build(
1847 Type => 'multipart/mixed',
1848 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1849 grep defined $args{$_}, qw(Subject From Cc)
1852 if ( defined $args{'Body'} && length $args{'Body'} ) {
1854 # Make the update content have no 'weird' newlines in it
1855 $args{'Body'} =~ s/\r\n/\n/gs;
1858 Type => $args{'Type'} || 'text/plain',
1860 Data => $args{'Body'},
1864 if ( $args{'AttachmentFieldName'} ) {
1866 my $cgi_object = $m->cgi_object;
1868 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1870 my ( @content, $buffer );
1871 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1872 push @content, $buffer;
1875 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1877 # Prefer the cached name first over CGI.pm stringification.
1878 my $filename = $RT::Mason::CGI::Filename;
1879 $filename = "$filehandle" unless defined $filename;
1880 $filename = Encode::encode_utf8( $filename );
1881 $filename =~ s{^.*[\\/]}{};
1884 Type => $uploadinfo->{'Content-Type'},
1885 Filename => $filename,
1888 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1889 $Message->head->set( 'Subject' => $filename );
1894 $Message->make_singlepart;
1896 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1904 # {{{ sub ParseDateToISO
1906 =head2 ParseDateToISO
1908 Takes a date in an arbitrary format.
1909 Returns an ISO date and time in GMT
1913 sub ParseDateToISO {
1916 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1918 Format => 'unknown',
1921 return ( $date_obj->ISO );
1926 # {{{ sub ProcessACLChanges
1928 sub ProcessACLChanges {
1929 my $ARGSref = shift;
1933 foreach my $arg ( keys %$ARGSref ) {
1934 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1936 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1939 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1940 @rights = @{ $ARGSref->{$arg} };
1942 @rights = $ARGSref->{$arg};
1944 @rights = grep $_, @rights;
1945 next unless @rights;
1947 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1948 $principal->Load($principal_id);
1951 if ( $object_type eq 'RT::System' ) {
1953 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1954 $obj = $object_type->new( $session{'CurrentUser'} );
1955 $obj->Load($object_id);
1956 unless ( $obj->id ) {
1957 $RT::Logger->error("couldn't load $object_type #$object_id");
1961 $RT::Logger->error("object type '$object_type' is incorrect");
1962 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1966 foreach my $right (@rights) {
1967 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1968 push( @results, $msg );
1977 # {{{ sub UpdateRecordObj
1979 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1981 @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.
1983 Returns an array of success/failure messages
1987 sub UpdateRecordObject {
1990 AttributesRef => undef,
1992 AttributePrefix => undef,
1996 my $Object = $args{'Object'};
1997 my @results = $Object->Update(
1998 AttributesRef => $args{'AttributesRef'},
1999 ARGSRef => $args{'ARGSRef'},
2000 AttributePrefix => $args{'AttributePrefix'},
2008 # {{{ Sub ProcessCustomFieldUpdates
2010 sub ProcessCustomFieldUpdates {
2012 CustomFieldObj => undef,
2017 my $Object = $args{'CustomFieldObj'};
2018 my $ARGSRef = $args{'ARGSRef'};
2020 my @attribs = qw(Name Type Description Queue SortOrder);
2021 my @results = UpdateRecordObject(
2022 AttributesRef => \@attribs,
2027 my $prefix = "CustomField-" . $Object->Id;
2028 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2029 my ( $addval, $addmsg ) = $Object->AddValue(
2030 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2031 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2032 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2034 push( @results, $addmsg );
2038 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2039 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2040 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2042 foreach my $id (@delete_values) {
2043 next unless defined $id;
2044 my ( $err, $msg ) = $Object->DeleteValue($id);
2045 push( @results, $msg );
2048 my $vals = $Object->Values();
2049 while ( my $cfv = $vals->Next() ) {
2050 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2051 if ( $cfv->SortOrder != $so ) {
2052 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2053 push( @results, $msg );
2063 # {{{ sub ProcessTicketBasics
2065 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2067 Returns an array of results messages.
2071 sub ProcessTicketBasics {
2079 my $TicketObj = $args{'TicketObj'};
2080 my $ARGSRef = $args{'ARGSRef'};
2082 # {{{ Set basic fields
2095 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
2096 my $tempqueue = RT::Queue->new($RT::SystemUser);
2097 $tempqueue->Load( $ARGSRef->{'Queue'} );
2098 if ( $tempqueue->id ) {
2099 $ARGSRef->{'Queue'} = $tempqueue->id;
2103 # Status isn't a field that can be set to a null value.
2104 # RT core complains if you try
2105 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2107 my @results = UpdateRecordObject(
2108 AttributesRef => \@attribs,
2109 Object => $TicketObj,
2110 ARGSRef => $ARGSRef,
2113 # We special case owner changing, so we can use ForceOwnerChange
2114 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2116 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2117 $ChownType = "Force";
2119 $ChownType = "Give";
2122 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2123 push( @results, $msg );
2133 sub ProcessTicketCustomFieldUpdates {
2135 $args{'Object'} = delete $args{'TicketObj'};
2136 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2138 # Build up a list of objects that we want to work with
2139 my %custom_fields_to_mod;
2140 foreach my $arg ( keys %$ARGSRef ) {
2141 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2142 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2143 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2144 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2145 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2146 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2150 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2153 sub ProcessObjectCustomFieldUpdates {
2155 my $ARGSRef = $args{'ARGSRef'};
2158 # Build up a list of objects that we want to work with
2159 my %custom_fields_to_mod;
2160 foreach my $arg ( keys %$ARGSRef ) {
2162 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2163 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2165 # For each of those objects, find out what custom fields we want to work with.
2166 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2169 # For each of those objects
2170 foreach my $class ( keys %custom_fields_to_mod ) {
2171 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2172 my $Object = $args{'Object'};
2173 $Object = $class->new( $session{'CurrentUser'} )
2174 unless $Object && ref $Object eq $class;
2176 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2177 unless ( $Object->id ) {
2178 $RT::Logger->warning("Couldn't load object $class #$id");
2182 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2183 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2184 $CustomFieldObj->SetContextObject($Object);
2185 $CustomFieldObj->LoadById($cf);
2186 unless ( $CustomFieldObj->id ) {
2187 $RT::Logger->warning("Couldn't load custom field #$cf");
2191 _ProcessObjectCustomFieldUpdates(
2192 Prefix => "Object-$class-$id-CustomField-$cf-",
2194 CustomField => $CustomFieldObj,
2195 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2203 sub _ProcessObjectCustomFieldUpdates {
2205 my $cf = $args{'CustomField'};
2206 my $cf_type = $cf->Type;
2208 # Remove blank Values since the magic field will take care of this. Sometimes
2209 # the browser gives you a blank value which causes CFs to be processed twice
2210 if ( defined $args{'ARGS'}->{'Values'}
2211 && !length $args{'ARGS'}->{'Values'}
2212 && $args{'ARGS'}->{'Values-Magic'} )
2214 delete $args{'ARGS'}->{'Values'};
2218 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2220 # skip category argument
2221 next if $arg eq 'Category';
2224 next if $arg eq 'Value-TimeUnits';
2226 # since http won't pass in a form element with a null value, we need
2228 if ( $arg eq 'Values-Magic' ) {
2230 # We don't care about the magic, if there's really a values element;
2231 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2232 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2234 # "Empty" values does not mean anything for Image and Binary fields
2235 next if $cf_type =~ /^(?:Image|Binary)$/;
2238 $args{'ARGS'}->{'Values'} = undef;
2242 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2243 @values = @{ $args{'ARGS'}->{$arg} };
2244 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2245 @values = ( $args{'ARGS'}->{$arg} );
2247 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2248 if defined $args{'ARGS'}->{$arg};
2250 @values = grep length, map {
2256 grep defined, @values;
2258 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2259 foreach my $value (@values) {
2260 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2264 push( @results, $msg );
2266 } elsif ( $arg eq 'Upload' ) {
2267 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2268 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2269 push( @results, $msg );
2270 } elsif ( $arg eq 'DeleteValues' ) {
2271 foreach my $value (@values) {
2272 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2276 push( @results, $msg );
2278 } elsif ( $arg eq 'DeleteValueIds' ) {
2279 foreach my $value (@values) {
2280 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2284 push( @results, $msg );
2286 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2287 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2290 foreach my $value (@values) {
2291 if ( my $entry = $cf_values->HasEntry($value) ) {
2292 $values_hash{ $entry->id } = 1;
2296 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2300 push( @results, $msg );
2301 $values_hash{$val} = 1 if $val;
2304 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2305 return @results if ( $cf->Type eq 'Date' && ! @values );
2307 $cf_values->RedoSearch;
2308 while ( my $cf_value = $cf_values->Next ) {
2309 next if $values_hash{ $cf_value->id };
2311 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2313 ValueId => $cf_value->id
2315 push( @results, $msg );
2317 } elsif ( $arg eq 'Values' ) {
2318 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2320 # keep everything up to the point of difference, delete the rest
2322 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2323 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2332 # now add/replace extra things, if any
2333 foreach my $value (@values) {
2334 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2338 push( @results, $msg );
2343 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2344 $cf->Name, ref $args{'Object'},
2353 # {{{ sub ProcessTicketWatchers
2355 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2357 Returns an array of results messages.
2361 sub ProcessTicketWatchers {
2369 my $Ticket = $args{'TicketObj'};
2370 my $ARGSRef = $args{'ARGSRef'};
2374 foreach my $key ( keys %$ARGSRef ) {
2376 # Delete deletable watchers
2377 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2378 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2382 push @results, $msg;
2385 # Delete watchers in the simple style demanded by the bulk manipulator
2386 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2387 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2388 Email => $ARGSRef->{$key},
2391 push @results, $msg;
2394 # Add new wathchers by email address
2395 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2396 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2399 #They're in this order because otherwise $1 gets clobbered :/
2400 my ( $code, $msg ) = $Ticket->AddWatcher(
2401 Type => $ARGSRef->{$key},
2402 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2404 push @results, $msg;
2407 #Add requestors in the simple style demanded by the bulk manipulator
2408 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2409 my ( $code, $msg ) = $Ticket->AddWatcher(
2411 Email => $ARGSRef->{$key}
2413 push @results, $msg;
2416 # Add new watchers by owner
2417 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2418 my $principal_id = $1;
2419 my $form = $ARGSRef->{$key};
2420 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2421 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2423 my ( $code, $msg ) = $Ticket->AddWatcher(
2425 PrincipalId => $principal_id
2427 push @results, $msg;
2437 # {{{ sub ProcessTicketDates
2439 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2441 Returns an array of results messages.
2445 sub ProcessTicketDates {
2452 my $Ticket = $args{'TicketObj'};
2453 my $ARGSRef = $args{'ARGSRef'};
2457 # {{{ Set date fields
2458 my @date_fields = qw(
2466 #Run through each field in this list. update the value if apropriate
2467 foreach my $field (@date_fields) {
2468 next unless exists $ARGSRef->{ $field . '_Date' };
2469 next if $ARGSRef->{ $field . '_Date' } eq '';
2473 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2475 Format => 'unknown',
2476 Value => $ARGSRef->{ $field . '_Date' }
2479 my $obj = $field . "Obj";
2480 if ( ( defined $DateObj->Unix )
2481 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2483 my $method = "Set$field";
2484 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2485 push @results, "$msg";
2495 # {{{ sub ProcessTicketLinks
2497 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2499 Returns an array of results messages.
2503 sub ProcessTicketLinks {
2510 my $Ticket = $args{'TicketObj'};
2511 my $ARGSRef = $args{'ARGSRef'};
2513 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2515 #Merge if we need to
2516 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2517 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2518 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2519 push @results, $msg;
2527 sub ProcessRecordLinks {
2534 my $Record = $args{'RecordObj'};
2535 my $ARGSRef = $args{'ARGSRef'};
2539 # Delete links that are gone gone gone.
2540 foreach my $arg ( keys %$ARGSRef ) {
2541 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2546 my ( $val, $msg ) = $Record->DeleteLink(
2552 push @results, $msg;
2558 my @linktypes = qw( DependsOn MemberOf RefersTo );
2560 foreach my $linktype (@linktypes) {
2561 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2562 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2563 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2565 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2567 $luri =~ s/\s+$//; # Strip trailing whitespace
2568 my ( $val, $msg ) = $Record->AddLink(
2572 push @results, $msg;
2575 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2576 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2577 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2579 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2581 my ( $val, $msg ) = $Record->AddLink(
2586 push @results, $msg;
2594 =head2 _UploadedFile ( $arg );
2596 Takes a CGI parameter name; if a file is uploaded under that name,
2597 return a hash reference suitable for AddCustomFieldValue's use:
2598 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2600 Returns C<undef> if no files were uploaded in the C<$arg> field.
2606 my $cgi_object = $m->cgi_object;
2607 my $fh = $cgi_object->upload($arg) or return undef;
2608 my $upload_info = $cgi_object->uploadInfo($fh);
2610 my $filename = "$fh";
2611 $filename =~ s#^.*[\\/]##;
2616 LargeContent => do { local $/; scalar <$fh> },
2617 ContentType => $upload_info->{'Content-Type'},
2621 sub GetColumnMapEntry {
2622 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2624 # deal with the simplest thing first
2625 if ( $args{'Map'}{ $args{'Name'} } ) {
2626 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2630 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2631 return undef unless $args{'Map'}->{$mainkey};
2632 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2633 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2635 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2640 sub ProcessColumnMapValue {
2642 my %args = ( Arguments => [], Escape => 1, @_ );
2645 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2646 my @tmp = $value->( @{ $args{'Arguments'} } );
2647 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2648 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2649 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2650 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2655 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2659 =head2 _load_container_object ( $type, $id );
2661 Instantiate container object for saving searches.
2665 sub _load_container_object {
2666 my ( $obj_type, $obj_id ) = @_;
2667 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2670 =head2 _parse_saved_search ( $arg );
2672 Given a serialization string for saved search, and returns the
2673 container object and the search id.
2677 sub _parse_saved_search {
2679 return unless $spec;
2680 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2687 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2690 =head2 ScrubHTML content
2692 Removes unsafe and undesired HTML from the passed content
2698 my $Content = shift;
2699 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2701 $Content = '' if !defined($Content);
2702 return $SCRUBBER->scrub($Content);
2707 Returns a new L<HTML::Scrubber> object.
2709 If you need to be more lax about what HTML tags and attributes are allowed,
2710 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2713 package HTML::Mason::Commands;
2714 # Let tables through
2715 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2720 our @SCRUBBER_ALLOWED_TAGS = qw(
2721 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2722 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2725 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2726 # Match http, ftp and relative urls
2727 # XXX: we also scrub format strings with this module then allow simple config options
2728 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2734 (?:(?:background-)?color: \s*
2735 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
2736 \#[a-f0-9]{3,6} | # #fff or #ffffff
2737 [\w\-]+ # green, light-blue, etc.
2739 text-align: \s* \w+ |
2740 font-size: \s* [\w.\-]+ |
2741 font-family: \s* [\w\s"',.\-]+ |
2742 font-weight: \s* [\w\-]+ |
2744 # MS Office styles, which are probably fine. If we don't, then any
2745 # associated styles in the same attribute get stripped.
2746 mso-[\w\-]+?: \s* [\w\s"',.\-]+
2748 +$ # one or more of these allowed properties from here 'till sunset
2752 our %SCRUBBER_RULES = ();
2755 require HTML::Scrubber;
2756 my $scrubber = HTML::Scrubber->new();
2760 %SCRUBBER_ALLOWED_ATTRIBUTES,
2761 '*' => 0, # require attributes be explicitly allowed
2764 $scrubber->deny(qw[*]);
2765 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2766 $scrubber->rules(%SCRUBBER_RULES);
2768 # Scrubbing comments is vital since IE conditional comments can contain
2769 # arbitrary HTML and we'd pass it right on through.
2770 $scrubber->comment(0);
2775 package RT::Interface::Web;
2776 RT::Base->_ImportOverlays();