1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2016 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::Menu;
69 use RT::Interface::Web::Session;
71 use List::MoreUtils qw();
75 =head2 SquishedCSS $style
81 my $style = shift or die "need name";
82 return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
83 require RT::Squish::CSS;
84 my $css = RT::Squish::CSS->new( Style => $style );
85 $SQUISHED_CSS{ $css->Style } = $css;
95 return $SQUISHED_JS if $SQUISHED_JS;
97 require RT::Squish::JS;
98 my $js = RT::Squish::JS->new();
111 jquery-ui-1.10.0.custom.min.js
112 jquery-ui-timepicker-addon.js
113 jquery-ui-patch-datepicker.js
115 jquery.modal-defaults.js
121 jquery.event.hover-1.0.js
124 jquery.supposition.js
128 event-registration.js
130 /static/RichText/ckeditor.js
131 }, RT->Config->Get('JSFiles');
136 Removes the cached CSS and JS entries, forcing them to be regenerated
146 =head2 EscapeHTML SCALARREF
148 does a css-busting but minimalist escaping of whatever html you're passing in.
154 return unless defined $$ref;
156 $$ref =~ s/&/&/g;
159 $$ref =~ s/\(/(/g;
160 $$ref =~ s/\)/)/g;
161 $$ref =~ s/"/"/g;
162 $$ref =~ s/'/'/g;
169 Instead => "EscapeHTML",
175 =head2 EscapeURI SCALARREF
177 Escapes URI component according to RFC2396
183 return unless defined $$ref;
186 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
189 =head2 EncodeJSON SCALAR
191 Encodes the SCALAR to JSON and returns a JSON Unicode (B<not> UTF-8) string.
192 SCALAR may be a simple value or a reference.
197 my $s = JSON::to_json(shift, { allow_nonref => 1 });
202 sub _encode_surrogates {
203 my $uni = $_[0] - 0x10000;
204 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
209 return unless defined $$ref;
211 $$ref = "'" . join('',
213 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
214 $_ <= 255 ? sprintf("\\x%02X", $_) :
215 $_ <= 65535 ? sprintf("\\u%04X", $_) :
216 sprintf("\\u%X\\u%X", _encode_surrogates($_))
217 } unpack('U*', $$ref))
221 =head2 WebCanonicalizeInfo();
223 Different web servers set different environmental varibles. This
224 function must return something suitable for REMOTE_USER. By default,
225 just downcase $ENV{'REMOTE_USER'}
229 sub WebCanonicalizeInfo {
230 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
235 =head2 WebRemoteUserAutocreateInfo($user);
237 Returns a hash of user attributes, used when WebRemoteUserAutocreate is set.
241 sub WebRemoteUserAutocreateInfo {
246 # default to making Privileged users, even if they specify
247 # some other default Attributes
248 if ( !$RT::UserAutocreateDefaultsOnLogin
249 || ( ref($RT::UserAutocreateDefaultsOnLogin) && not exists $RT::UserAutocreateDefaultsOnLogin->{Privileged} ) )
251 $user_info{'Privileged'} = 1;
254 # Populate fields with information from Unix /etc/passwd
255 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
256 $user_info{'Comments'} = $comments if defined $comments;
257 $user_info{'RealName'} = $realname if defined $realname;
259 # and return the wad of stuff
267 if (RT->Config->Get('DevelMode')) {
268 require Module::Refresh;
269 Module::Refresh->refresh;
272 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
274 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
276 # Roll back any dangling transactions from a previous failed connection
277 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
279 MaybeEnableSQLStatementLog();
281 # avoid reentrancy, as suggested by masonbook
282 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
284 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
285 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
290 local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
291 PreprocessTimeUpdates($ARGS);
294 MaybeShowInstallModePage();
296 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
299 if ( _UserLoggedIn() ) {
300 # make user info up to date
301 $HTML::Mason::Commands::session{'CurrentUser'}
302 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
303 undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
306 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
309 # Process session-related callbacks before any auth attempts
310 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
312 MaybeRejectPrivateComponentRequest();
314 MaybeShowNoAuthPage($ARGS);
316 AttemptExternalAuth($ARGS) if RT->Config->Get('WebRemoteUserContinuous') or not _UserLoggedIn();
318 _ForceLogout() unless _UserLoggedIn();
320 # Process per-page authentication callbacks
321 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
323 if ( $ARGS->{'NotMobile'} ) {
324 $HTML::Mason::Commands::session{'NotMobile'} = 1;
327 unless ( _UserLoggedIn() ) {
330 # Authenticate if the user is trying to login via user/pass query args
331 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
334 my $m = $HTML::Mason::Commands::m;
336 # REST urls get a special 401 response
337 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
338 $HTML::Mason::Commands::r->content_type("text/plain; charset=utf-8");
339 $m->error_format("text");
340 $m->out("RT/$RT::VERSION 401 Credentials required\n");
341 $m->out("\n$msg\n") if $msg;
344 # Specially handle /index.html and /m/index.html so that we get a nicer URL
345 elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
346 my $mobile = $1 ? 1 : 0;
347 my $next = SetNextPage($ARGS);
348 $m->comp('/NoAuth/Login.html',
355 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
360 MaybeShowInterstitialCSRFPage($ARGS);
362 # now it applies not only to home page, but any dashboard that can be used as a workspace
363 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
364 if ( $ARGS->{'HomeRefreshInterval'} );
366 # Process per-page global callbacks
367 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
369 ShowRequestedPage($ARGS);
370 LogRecordedSQLStatements(RequestData => {
371 Path => $HTML::Mason::Commands::m->request_path,
374 # Process per-page final cleanup callbacks
375 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
377 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
378 unless $HTML::Mason::Commands::r->content_type
379 =~ qr<^(text|application)/(x-)?(css|javascript)>;
384 delete $HTML::Mason::Commands::session{'CurrentUser'};
388 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
396 =head2 LoginError ERROR
398 Pushes a login error into the Actions session store and returns the hash key.
404 my $key = Digest::MD5::md5_hex( rand(1024) );
405 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
406 $HTML::Mason::Commands::session{'i'}++;
410 =head2 SetNextPage ARGSRef [PATH]
412 Intuits and stashes the next page in the sesssion hash. If PATH is
413 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
420 my $next = $_[0] ? $_[0] : IntuitNextPage();
421 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
422 my $page = { url => $next };
424 # If an explicit URL was passed and we didn't IntuitNextPage, then
425 # IsPossibleCSRF below is almost certainly unrelated to the actual
426 # destination. Currently explicit next pages aren't used in RT, but the
428 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
429 # This isn't really CSRF, but the CSRF heuristics are useful for catching
430 # requests which may have unintended side-effects.
431 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
434 "Marking original destination as having side-effects before redirecting for login.\n"
436 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
438 $page->{'HasSideEffects'} = [$msg, @loc];
442 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
443 $HTML::Mason::Commands::session{'i'}++;
447 =head2 FetchNextPage HASHKEY
449 Returns the stashed next page hashref for the given hash.
454 my $hash = shift || "";
455 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
458 =head2 RemoveNextPage HASHKEY
460 Removes the stashed next page for the given hash and returns it.
465 my $hash = shift || "";
466 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
469 =head2 TangentForLogin ARGSRef [HASH]
471 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
472 the next page. Takes a hashref of request %ARGS as the first parameter.
473 Optionally takes all other parameters as a hash which is dumped into query
478 sub TangentForLogin {
479 my $login = TangentForLoginURL(@_);
480 Redirect( RT->Config->Get('WebBaseURL') . $login );
483 =head2 TangentForLoginURL [HASH]
485 Returns a URL suitable for tangenting for login. Optionally takes a hash which
486 is dumped into query params.
490 sub TangentForLoginURL {
492 my $hash = SetNextPage($ARGS);
493 my %query = (@_, next => $hash);
496 if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
498 my $login = RT->Config->Get('WebPath') . '/NoAuth/Login.html?';
499 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
503 =head2 TangentForLoginWithError ERROR
505 Localizes the passed error message, stashes it with L<LoginError> and then
506 calls L<TangentForLogin> with the appropriate results key.
510 sub TangentForLoginWithError {
512 my $key = LoginError(HTML::Mason::Commands::loc(@_));
513 TangentForLogin( $ARGS, results => $key );
516 =head2 IntuitNextPage
518 Attempt to figure out the path to which we should return the user after a
519 tangent. The current request URL is used, or failing that, the C<WebURL>
520 configuration variable.
527 # This includes any query parameters. Redirect will take care of making
528 # it an absolute URL.
529 if ($ENV{'REQUEST_URI'}) {
530 $req_uri = $ENV{'REQUEST_URI'};
532 # collapse multiple leading slashes so the first part doesn't look like
533 # a hostname of a schema-less URI
534 $req_uri =~ s{^/+}{/};
537 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
540 my $uri = URI->new($next);
542 # You get undef scheme with a relative uri like "/Search/Build.html"
543 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
544 $next = RT->Config->Get('WebURL');
547 # Make sure we're logging in to the same domain
548 # You can get an undef authority with a relative uri like "index.html"
549 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
550 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
551 $next = RT->Config->Get('WebURL');
557 =head2 MaybeShowInstallModePage
559 This function, called exclusively by RT's autohandler, dispatches
560 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
562 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
566 sub MaybeShowInstallModePage {
567 return unless RT->InstallMode;
569 my $m = $HTML::Mason::Commands::m;
570 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
572 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
573 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
580 =head2 MaybeShowNoAuthPage \%ARGS
582 This function, called exclusively by RT's autohandler, dispatches
583 a request to the page a user requested (but only if it matches the "noauth" regex.
585 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
589 sub MaybeShowNoAuthPage {
592 my $m = $HTML::Mason::Commands::m;
594 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
596 # Don't show the login page to logged in users
597 Redirect(RT->Config->Get('WebURL'))
598 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
600 # If it's a noauth file, don't ask for auth.
601 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
605 =head2 MaybeRejectPrivateComponentRequest
607 This function will reject calls to private components, like those under
608 C</Elements>. If the requested path is a private component then we will
609 abort with a C<403> error.
613 sub MaybeRejectPrivateComponentRequest {
614 my $m = $HTML::Mason::Commands::m;
615 my $path = $m->request_comp->path;
617 # We do not check for dhandler here, because requesting our dhandlers
618 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
624 _elements | # mobile UI
627 autohandler | # requesting this directly is suspicious
628 l (_unsafe)? ) # loc component
629 ( $ | / ) # trailing slash or end of path
631 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
634 warn "rejecting private component $path\n";
642 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
643 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
644 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
649 =head2 ShowRequestedPage \%ARGS
651 This function, called exclusively by RT's autohandler, dispatches
652 a request to the page a user requested (making sure that unpriviled users
653 can only see self-service pages.
657 sub ShowRequestedPage {
660 my $m = $HTML::Mason::Commands::m;
662 # Ensure that the cookie that we send is up-to-date, in case the
663 # session-id has been modified in any way
666 # precache all system level rights for the current user
667 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
669 # If the user isn't privileged, they can only see SelfService
670 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
672 # if the user is trying to access a ticket, redirect them
673 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
674 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
677 # otherwise, drop the user at the SelfService default page
678 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
679 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
682 # if user is in SelfService dir let him do anything
684 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
687 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
692 sub AttemptExternalAuth {
695 return unless ( RT->Config->Get('WebRemoteUserAuth') );
697 my $user = $ARGS->{user};
698 my $m = $HTML::Mason::Commands::m;
700 my $logged_in_external_user = _UserLoggedIn() && $HTML::Mason::Commands::session{'WebExternallyAuthed'};
702 # If RT is configured for external auth, let's go through and get REMOTE_USER
704 # Do we actually have a REMOTE_USER or equivalent? We only check auth if
705 # 1) we have no logged in user, or 2) we have a user who is externally
706 # authed. If we have a logged in user who is internally authed, don't
707 # check remote user otherwise we may log them out.
708 if (RT::Interface::Web::WebCanonicalizeInfo()
709 and (not _UserLoggedIn() or $logged_in_external_user) )
711 $user = RT::Interface::Web::WebCanonicalizeInfo();
712 my $load_method = RT->Config->Get('WebRemoteUserGecos') ? 'LoadByGecos' : 'Load';
714 my $next = RemoveNextPage($ARGS->{'next'});
715 $next = $next->{'url'} if ref $next;
716 InstantiateNewSession() unless _UserLoggedIn;
717 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
718 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
720 if ( RT->Config->Get('WebRemoteUserAutocreate') and not _UserLoggedIn() ) {
722 # Create users on-the-fly
723 my $UserObj = RT::User->new(RT->SystemUser);
724 my ( $val, $msg ) = $UserObj->Create(
725 %{ ref RT->Config->Get('UserAutocreateDefaultsOnLogin') ? RT->Config->Get('UserAutocreateDefaultsOnLogin') : {} },
732 # now get user specific information, to better create our user.
733 my $new_user_info = RT::Interface::Web::WebRemoteUserAutocreateInfo($user);
735 # set the attributes that have been defined.
736 foreach my $attribute ( $UserObj->WritableAttributes, qw(Privileged Disabled) ) {
738 Attribute => $attribute,
740 UserInfo => $new_user_info,
741 CallbackName => 'NewUser',
742 CallbackPage => '/autohandler'
744 my $method = "Set$attribute";
745 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
747 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
749 RT->Logger->error("Couldn't auto-create user '$user' when attempting WebRemoteUser: $msg");
750 AbortExternalAuth( Error => "UserAutocreateDefaultsOnLogin" );
754 if ( _UserLoggedIn() ) {
755 $HTML::Mason::Commands::session{'WebExternallyAuthed'} = 1;
756 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
757 # It is possible that we did a redirect to the login page,
758 # if the external auth allows lack of auth through with no
759 # REMOTE_USER set, instead of forcing a "permission
760 # denied" message. Honor the $next.
761 Redirect($next) if $next;
762 # Unlike AttemptPasswordAuthentication below, we do not
763 # force a redirect to / if $next is not set -- otherwise,
764 # straight-up external auth would always redirect to /
765 # when you first hit it.
767 # Couldn't auth with the REMOTE_USER provided because an RT
768 # user doesn't exist and we're configured not to create one.
769 RT->Logger->error("Couldn't find internal user for '$user' when attempting WebRemoteUser and RT is not configured for auto-creation. Refer to `perldoc $RT::BasePath/docs/authentication.pod` if you want to allow auto-creation.");
771 Error => "NoInternalUser",
776 elsif ($logged_in_external_user) {
777 # The logged in external user was deauthed by the auth system and we
778 # should kick them out.
779 AbortExternalAuth( Error => "Deauthorized" );
781 elsif (not RT->Config->Get('WebFallbackToRTLogin')) {
782 # Abort if we don't want to fallback internally
783 AbortExternalAuth( Error => "NoRemoteUser" );
787 sub AbortExternalAuth {
789 my $error = $args{Error} ? "/Errors/WebRemoteUser/$args{Error}" : undef;
790 my $m = $HTML::Mason::Commands::m;
791 my $r = $HTML::Mason::Commands::r;
795 # Clear the decks, not that we should have partial content.
799 $m->comp($error, %args)
800 if $error and $m->comp_exists($error);
802 # Return a 403 Forbidden or we may fallback to a login page with no form
806 sub AttemptPasswordAuthentication {
808 return unless defined $ARGS->{user} && defined $ARGS->{pass};
810 my $user_obj = RT::CurrentUser->new();
811 $user_obj->Load( $ARGS->{user} );
813 my $m = $HTML::Mason::Commands::m;
815 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
816 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
817 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
818 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
821 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
823 # It's important to nab the next page from the session before we blow
825 my $next = RemoveNextPage($ARGS->{'next'});
826 $next = $next->{'url'} if ref $next;
828 InstantiateNewSession();
829 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
831 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler', RedirectTo => \$next );
833 # Really the only time we don't want to redirect here is if we were
834 # passed user and pass as query params in the URL.
838 elsif ($ARGS->{'next'}) {
839 # Invalid hash, but still wants to go somewhere, take them to /
840 Redirect(RT->Config->Get('WebURL'));
843 return (1, HTML::Mason::Commands::loc('Logged in'));
847 =head2 LoadSessionFromCookie
849 Load or setup a session cookie for the current user.
853 sub _SessionCookieName {
854 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
855 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
859 sub LoadSessionFromCookie {
861 my %cookies = CGI::Cookie->fetch;
862 my $cookiename = _SessionCookieName();
863 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
864 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
865 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
866 InstantiateNewSession();
868 if ( int RT->Config->Get('AutoLogoff') ) {
869 my $now = int( time / 60 );
870 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
872 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
873 InstantiateNewSession();
876 # save session on each request when AutoLogoff is turned on
877 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
881 sub InstantiateNewSession {
882 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
883 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
887 sub SendSessionCookie {
888 my $cookie = CGI::Cookie->new(
889 -name => _SessionCookieName(),
890 -value => $HTML::Mason::Commands::session{_session_id},
891 -path => RT->Config->Get('WebPath'),
892 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
893 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
896 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
899 =head2 GetWebURLFromRequest
901 People may use different web urls instead of C<$WebURL> in config.
902 Return the web url current user is using.
906 sub GetWebURLFromRequest {
908 my $uri = URI->new( RT->Config->Get('WebURL') );
910 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
911 $uri->scheme('https');
914 $uri->scheme('http');
917 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
918 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'} );
919 $uri->port( $ENV{'SERVER_PORT'} );
920 return "$uri"; # stringify to be consistent with WebURL in config
925 This routine ells the current user's browser to redirect to URL.
926 Additionally, it unties the user's currently active session, helping to avoid
927 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
928 a cached DBI statement handle twice at the same time.
933 my $redir_to = shift;
934 untie $HTML::Mason::Commands::session;
935 my $uri = URI->new($redir_to);
936 my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
938 # Make relative URIs absolute from the server host and scheme
939 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
940 if (not defined $uri->host) {
941 $uri->host($server_uri->host);
942 $uri->port($server_uri->port);
945 # If the user is coming in via a non-canonical
946 # hostname, don't redirect them to the canonical host,
947 # it will just upset them (and invalidate their credentials)
948 # don't do this if $RT::CanonicalizeRedirectURLs is true
949 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
950 && $uri->host eq $server_uri->host
951 && $uri->port eq $server_uri->port )
953 my $env_uri = URI->new(GetWebURLFromRequest());
954 $uri->scheme($env_uri->scheme);
955 $uri->host($env_uri->host);
956 $uri->port($env_uri->port);
959 # not sure why, but on some systems without this call mason doesn't
960 # set status to 302, but 200 instead and people see blank pages
961 $HTML::Mason::Commands::r->status(302);
963 # Perlbal expects a status message, but Mason's default redirect status
964 # doesn't provide one. See also rt.cpan.org #36689.
965 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
967 $HTML::Mason::Commands::m->abort;
970 =head2 GetStaticHeaders
972 return an arrayref of Headers (currently, Cache-Control and Expires).
976 sub GetStaticHeaders {
979 my $Visibility = 'private';
980 if ( ! defined $args{Time} ) {
982 } elsif ( $args{Time} eq 'no-cache' ) {
984 } elsif ( $args{Time} eq 'forever' ) {
985 $args{Time} = 30 * 24 * 60 * 60;
986 $Visibility = 'public';
989 my $CacheControl = $args{Time}
990 ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
994 my $expires = RT::Date->new(RT->SystemUser);
996 $expires->AddSeconds( $args{Time} ) if $args{Time};
999 Expires => $expires->RFC2616,
1000 'Cache-Control' => $CacheControl,
1004 =head2 CacheControlExpiresHeaders
1006 set both Cache-Control and Expires http headers
1010 sub CacheControlExpiresHeaders {
1011 Plack::Util::header_iter( GetStaticHeaders(@_), sub {
1012 my ( $key, $val ) = @_;
1013 $HTML::Mason::Commands::r->headers_out->{$key} = $val;
1017 =head2 StaticFileHeaders
1019 Send the browser a few headers to try to get it to (somewhat agressively)
1020 cache RT's static Javascript and CSS files.
1022 This routine could really use _accurate_ heuristics. (XXX TODO)
1026 sub StaticFileHeaders {
1027 # remove any cookie headers -- if it is cached publicly, it
1028 # shouldn't include anyone's cookie!
1029 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
1031 # Expire things in a month.
1032 CacheControlExpiresHeaders( Time => 'forever' );
1035 =head2 ComponentPathIsSafe PATH
1037 Takes C<PATH> and returns a boolean indicating that the user-specified partial
1038 component path is safe.
1040 Currently "safe" means that the path does not start with a dot (C<.>), does
1041 not contain a slash-dot C</.>, and does not contain any nulls.
1045 sub ComponentPathIsSafe {
1048 return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
1053 Takes a C<< Path => path >> and returns a boolean indicating that
1054 the path is safely within RT's control or not. The path I<must> be
1057 This function does not consult the filesystem at all; it is merely
1058 a logical sanity checking of the path. This explicitly does not handle
1059 symlinks; if you have symlinks in RT's webroot pointing outside of it,
1060 then we assume you know what you are doing.
1067 my $path = $args{Path};
1069 # Get File::Spec to clean up extra /s, ./, etc
1070 my $cleaned_up = File::Spec->canonpath($path);
1072 if (!defined($cleaned_up)) {
1073 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
1077 # Forbid too many ..s. We can't just sum then check because
1078 # "../foo/bar/baz" should be illegal even though it has more
1079 # downdirs than updirs. So as soon as we get a negative score
1080 # (which means "breaking out" of the top level) we reject the path.
1082 my @components = split '/', $cleaned_up;
1084 for my $component (@components) {
1085 if ($component eq '..') {
1088 $RT::Logger->info("Rejecting unsafe path: $path");
1092 elsif ($component eq '.' || $component eq '') {
1093 # these two have no effect on $score
1103 =head2 SendStaticFile
1105 Takes a File => path and a Type => Content-type
1107 If Type isn't provided and File is an image, it will
1108 figure out a sane Content-type, otherwise it will
1109 send application/octet-stream
1111 Will set caching headers using StaticFileHeaders
1115 sub SendStaticFile {
1118 my $file = $args{File};
1119 my $type = $args{Type};
1120 my $relfile = $args{RelativeFile};
1122 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
1123 $HTML::Mason::Commands::r->status(400);
1124 $HTML::Mason::Commands::m->abort;
1127 $self->StaticFileHeaders();
1130 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1132 $type =~ s/jpg/jpeg/gi;
1134 $type ||= "application/octet-stream";
1136 $HTML::Mason::Commands::r->content_type($type);
1137 open( my $fh, '<', $file ) or die "couldn't open file: $!";
1141 $HTML::Mason::Commands::m->out($_) while (<$fh>);
1142 $HTML::Mason::Commands::m->flush_buffer;
1153 if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
1164 my $content = $args{Content};
1165 return '' unless $content;
1167 # Make the content have no 'weird' newlines in it
1168 $content =~ s/\r+\n/\n/g;
1170 my $return_content = $content;
1172 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1173 my $sigonly = $args{StripSignature};
1175 # massage content to easily detect if there's any real content
1176 $content =~ s/\s+//g; # yes! remove all the spaces
1178 # remove html version of spaces and newlines
1179 $content =~ s! !!g;
1180 $content =~ s!<br/?>!!g;
1183 # Filter empty content when type is text/html
1184 return '' if $html && $content !~ /\S/;
1186 # If we aren't supposed to strip the sig, just bail now.
1187 return $return_content unless $sigonly;
1189 # Find the signature
1190 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1193 # Check for plaintext sig
1194 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1196 # Check for html-formatted sig; we don't use EscapeHTML here
1197 # because we want to precisely match the escapting that FCKEditor
1199 $sig =~ s/&/&/g;
1202 $sig =~ s/"/"/g;
1203 $sig =~ s/'/'/g;
1204 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1207 return $return_content;
1213 # Later in the code we use
1214 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1215 # instead of $m->call_next to avoid problems with UTF8 keys in
1216 # arguments. Specifically, the call_next method pass through
1217 # original arguments, which are still the encoded bytes, not
1218 # characters. "{ base_comp => $m->request_comp }" is copied from
1219 # mason's source to get the same results as we get from call_next
1220 # method; this feature is not documented.
1223 # if they've passed multiple values, they'll be an array. if they've
1224 # passed just one, a scalar whatever they are, mark them as utf8
1227 ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ )
1228 : ( $type eq 'ARRAY' )
1229 ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ]
1230 : ( $type eq 'HASH' )
1231 ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ }
1236 sub PreprocessTimeUpdates {
1239 # This code canonicalizes time inputs in hours into minutes
1240 foreach my $field ( keys %$ARGS ) {
1241 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1243 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1244 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1245 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1246 $ARGS->{$local} *= 60;
1248 delete $ARGS->{$field};
1253 sub MaybeEnableSQLStatementLog {
1255 my $log_sql_statements = RT->Config->Get('StatementLog');
1257 if ($log_sql_statements) {
1258 $RT::Handle->ClearSQLStatementLog;
1259 $RT::Handle->LogSQLStatements(1);
1264 sub LogRecordedSQLStatements {
1267 my $log_sql_statements = RT->Config->Get('StatementLog');
1269 return unless ($log_sql_statements);
1271 my @log = $RT::Handle->SQLStatementLog;
1272 $RT::Handle->ClearSQLStatementLog;
1274 $RT::Handle->AddRequestToHistory({
1275 %{ $args{RequestData} },
1279 for my $stmt (@log) {
1280 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1290 level => $log_sql_statements,
1292 . sprintf( "%.6f", $duration )
1294 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1300 my $_has_validated_web_config = 0;
1301 sub ValidateWebConfig {
1304 # do this once per server instance, not once per request
1305 return if $_has_validated_web_config;
1306 $_has_validated_web_config = 1;
1308 my $port = $ENV{SERVER_PORT};
1309 my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
1310 || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
1311 ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
1313 if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
1314 $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
1315 ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
1316 ."otherwise your internal hyperlinks may be broken.");
1319 if ( $host ne RT->Config->Get('WebDomain') ) {
1320 $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
1321 ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
1322 ."otherwise your internal hyperlinks may be broken.");
1325 return; #next warning flooding our logs, doesn't seem applicable to our use
1326 # (SCRIPT_NAME is the full path, WebPath is just the beginning)
1327 #in vanilla RT does something eat the local part of SCRIPT_NAME 1st?
1329 # Unfortunately, there is no reliable way to get the _path_ that was
1330 # requested at the proxy level; simply disable this warning if we're
1331 # proxied and there's a mismatch.
1332 my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
1333 if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
1334 $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
1335 ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
1336 ."otherwise your internal hyperlinks may be broken.");
1340 sub ComponentRoots {
1342 my %args = ( Names => 0, @_ );
1344 if (defined $HTML::Mason::Commands::m) {
1345 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1348 [ local => $RT::MasonLocalComponentRoot ],
1349 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1350 [ standard => $RT::MasonComponentRoot ]
1353 @roots = map { $_->[1] } @roots unless $args{Names};
1360 $RT::LocalStaticPath,
1361 (map { $_->StaticDir } @{RT->Plugins}),
1364 return grep { $_ and -d $_ } @static;
1367 our %IS_WHITELISTED_COMPONENT = (
1368 # The RSS feed embeds an auth token in the path, but query
1369 # information for the search. Because it's a straight-up read, in
1370 # addition to embedding its own auth, it's fine.
1371 '/NoAuth/rss/dhandler' => 1,
1373 # While these can be used for denial-of-service against RT
1374 # (construct a very inefficient query and trick lots of users into
1375 # running them against RT) it's incredibly useful to be able to link
1376 # to a search result (or chart) or bookmark a result page.
1377 '/Search/Results.html' => 1,
1378 '/Search/Simple.html' => 1,
1379 '/m/tickets/search' => 1,
1380 '/Search/Chart.html' => 1,
1381 '/User/Search.html' => 1,
1383 # This page takes Attachment and Transaction argument to figure
1384 # out what to show, but it's read only and will deny information if you
1385 # don't have ShowOutgoingEmail.
1386 '/Ticket/ShowEmailRecord.html' => 1,
1389 # Whitelist arguments that do not indicate an effectful request.
1390 our @GLOBAL_WHITELISTED_ARGS = (
1391 # For example, "id" is acceptable because that is how RT retrieves a
1395 # If they have a results= from MaybeRedirectForResults, that's also fine.
1398 # The homepage refresh, which uses the Refresh header, doesn't send
1399 # a referer in most browsers; whitelist the one parameter it reloads
1400 # with, HomeRefreshInterval, which is safe
1401 'HomeRefreshInterval',
1403 # The NotMobile flag is fine for any page; it's only used to toggle a flag
1404 # in the session related to which interface you get.
1408 our %WHITELISTED_COMPONENT_ARGS = (
1409 # SavedSearchLoad - This happens when you middle-(or ⌘ )-click "Edit" for a saved search on
1410 # the homepage. It's not going to do any damage
1411 # NewQuery - This is simply to clear the search query
1412 '/Search/Build.html' => ['SavedSearchLoad','NewQuery'],
1413 # Happens if you try and reply to a message in the ticket history or click a number
1414 # of options on a tickets Action menu
1415 '/Ticket/Update.html' => ['QuoteTransaction', 'Action', 'DefaultStatus'],
1416 # Action->Extract Article on a ticket's menu
1417 '/Articles/Article/ExtractIntoClass.html' => ['Ticket'],
1420 # Components which are blacklisted from automatic, argument-based whitelisting.
1421 # These pages are not idempotent when called with just an id.
1422 our %IS_BLACKLISTED_COMPONENT = (
1423 # Takes only id and toggles bookmark state
1424 '/Helpers/Toggle/TicketBookmark' => 1,
1427 sub IsCompCSRFWhitelisted {
1431 return 1 if $IS_WHITELISTED_COMPONENT{$comp};
1433 my %args = %{ $ARGS };
1435 # If the user specifies a *correct* user and pass then they are
1436 # golden. This acts on the presumption that external forms may
1437 # hardcode a username and password -- if a malicious attacker knew
1438 # both already, CSRF is the least of your problems.
1439 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1440 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1441 my $user_obj = RT::CurrentUser->new();
1442 $user_obj->Load($args{user});
1443 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1449 # Some pages aren't idempotent even with safe args like id; blacklist
1450 # them from the automatic whitelisting below.
1451 return 0 if $IS_BLACKLISTED_COMPONENT{$comp};
1453 if ( my %csrf_config = RT->Config->Get('ReferrerComponents') ) {
1454 my $value = $csrf_config{$comp};
1455 if ( ref $value eq 'ARRAY' ) {
1456 delete $args{$_} for @$value;
1457 return %args ? 0 : 1;
1460 return $value ? 1 : 0;
1464 return AreCompCSRFParametersWhitelisted($comp, \%args);
1467 sub AreCompCSRFParametersWhitelisted {
1471 my %leftover_args = %{ $ARGS };
1473 # Join global whitelist and component-specific whitelist
1474 my @whitelisted_args = (@GLOBAL_WHITELISTED_ARGS, @{ $WHITELISTED_COMPONENT_ARGS{$sub} || [] });
1476 for my $arg (@whitelisted_args) {
1477 delete $leftover_args{$arg};
1480 # If there are no arguments, then it's likely to be an idempotent
1481 # request, which are not susceptible to CSRF
1482 return !%leftover_args;
1485 sub IsRefererCSRFWhitelisted {
1486 my $referer = _NormalizeHost(shift);
1487 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1488 $base_url = $base_url->host_port;
1491 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1492 push @$configs,$config;
1494 my $host_port = $referer->host_port;
1495 if ($config =~ /\*/) {
1496 # Turn a literal * into a domain component or partial component match.
1497 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1498 my $regex = join "[a-zA-Z0-9\-]*",
1499 map { quotemeta($_) }
1500 split /\*/, $config;
1502 return 1 if $host_port =~ /^$regex$/i;
1504 return 1 if $host_port eq $config;
1508 return (0,$referer,$configs);
1511 =head3 _NormalizeHost
1513 Takes a URI and creates a URI object that's been normalized
1514 to handle common problems such as localhost vs 127.0.0.1
1518 sub _NormalizeHost {
1520 $s = "http://$s" unless $s =~ /^http/i;
1521 my $uri= URI->new($s);
1522 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1528 sub IsPossibleCSRF {
1531 # If first request on this session is to a REST endpoint, then
1532 # whitelist the REST endpoints -- and explicitly deny non-REST
1533 # endpoints. We do this because using a REST cookie in a browser
1534 # would open the user to CSRF attacks to the REST endpoints.
1535 my $path = $HTML::Mason::Commands::r->path_info;
1536 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1537 unless defined $HTML::Mason::Commands::session{'REST'};
1539 if ($HTML::Mason::Commands::session{'REST'}) {
1540 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1542 This login session belongs to a REST client, and cannot be used to
1543 access non-REST interfaces of RT for security reasons.
1545 my $details = <<EOT;
1546 Please log out and back in to obtain a session for normal browsing. If
1547 you understand the security implications, disabling RT's CSRF protection
1548 will remove this restriction.
1551 HTML::Mason::Commands::Abort( $why, Details => $details );
1554 return 0 if IsCompCSRFWhitelisted(
1555 $HTML::Mason::Commands::m->request_comp->path,
1559 # if there is no Referer header then assume the worst
1561 "your browser did not supply a Referrer header", # loc
1562 ) if !$ENV{HTTP_REFERER};
1564 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1565 return 0 if $whitelisted;
1567 if ( @$configs > 1 ) {
1569 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1570 $browser->host_port,
1572 join(', ', @$configs) );
1576 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1577 $browser->host_port,
1581 sub ExpandCSRFToken {
1584 my $token = delete $ARGS->{CSRF_Token};
1585 return unless $token;
1587 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1588 return unless $data;
1589 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1591 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1592 return unless $user->ValidateAuthString( $data->{auth}, $token );
1594 %{$ARGS} = %{$data->{args}};
1595 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1597 # We explicitly stored file attachments with the request, but not in
1598 # the session yet, as that would itself be an attack. Put them into
1599 # the session now, so they'll be visible.
1600 if ($data->{attach}) {
1601 my $filename = $data->{attach}{filename};
1602 my $mime = $data->{attach}{mime};
1603 $HTML::Mason::Commands::session{'Attachments'}{$ARGS->{'Token'}||''}{$filename}
1610 sub StoreRequestToken {
1613 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1614 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1616 auth => $user->GenerateAuthString( $token ),
1617 path => $HTML::Mason::Commands::r->path_info,
1620 if ($ARGS->{Attach}) {
1621 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1622 my $file_path = delete $ARGS->{'Attach'};
1624 # This needs to be decoded because the value is a reference;
1625 # hence it was not decoded along with all of the standard
1626 # arguments in DecodeARGS
1628 filename => Encode::decode("UTF-8", "$file_path"),
1629 mime => $attachment,
1633 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1634 $HTML::Mason::Commands::session{'i'}++;
1638 sub MaybeShowInterstitialCSRFPage {
1641 return unless RT->Config->Get('RestrictReferrer');
1643 # Deal with the form token provided by the interstitial, which lets
1644 # browsers which never set referer headers still use RT, if
1645 # painfully. This blows values into ARGS
1646 return if ExpandCSRFToken($ARGS);
1648 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1649 return if !$is_csrf;
1651 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1653 my $token = StoreRequestToken($ARGS);
1654 $HTML::Mason::Commands::m->comp(
1656 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1657 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1660 # Calls abort, never gets here
1663 our @POTENTIAL_PAGE_ACTIONS = (
1664 qr'/Ticket/Create.html' => "create a ticket", # loc
1665 qr'/Ticket/' => "update a ticket", # loc
1666 qr'/Admin/' => "modify RT's configuration", # loc
1667 qr'/Approval/' => "update an approval", # loc
1668 qr'/Articles/' => "update an article", # loc
1669 qr'/Dashboards/' => "modify a dashboard", # loc
1670 qr'/m/ticket/' => "update a ticket", # loc
1671 qr'Prefs' => "modify your preferences", # loc
1672 qr'/Search/' => "modify or access a search", # loc
1673 qr'/SelfService/Create' => "create a ticket", # loc
1674 qr'/SelfService/' => "update a ticket", # loc
1677 sub PotentialPageAction {
1679 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1680 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1681 return HTML::Mason::Commands::loc($result)
1682 if $page =~ $pattern;
1687 =head2 RewriteInlineImages PARAMHASH
1689 Turns C<< <img src="cid:..."> >> elements in HTML into working images pointing
1690 back to RT's stored copy.
1692 Takes the following parameters:
1698 Scalar ref of the HTML content to rewrite. Modified in place to support the
1699 most common use-case.
1703 The L<RT::Attachment> object from which the Content originates.
1705 =item Related (optional)
1707 Array ref of related L<RT::Attachment> objects to use for C<Content-ID> matching.
1709 Defaults to the result of the C<Siblings> method on the passed Attachment.
1711 =item AttachmentPath (optional)
1713 The base path to use when rewriting C<src> attributes.
1715 Defaults to C< $WebPath/Ticket/Attachment >
1719 In scalar context, returns the number of elements rewritten.
1721 In list content, returns the attachments IDs referred to by the rewritten <img>
1722 elements, in the order found. There may be duplicates.
1726 sub RewriteInlineImages {
1729 Attachment => undef,
1731 AttachmentPath => RT->Config->Get('WebPath')."/Ticket/Attachment",
1735 return unless defined $args{Content}
1736 and ref $args{Content} eq 'SCALAR'
1737 and defined $args{Attachment};
1739 my $related_part = $args{Attachment}->Closest("multipart/related")
1742 $args{Related} ||= $related_part->Children->ItemsArrayRef;
1743 return unless @{$args{Related}};
1745 my $content = $args{'Content'};
1748 require HTML::RewriteAttributes::Resources;
1749 $$content = HTML::RewriteAttributes::Resources->rewrite($$content, sub {
1752 return $cid unless lc $meta{tag} eq 'img'
1753 and lc $meta{attr} eq 'src'
1754 and $cid =~ s/^cid://i;
1756 for my $attach (@{$args{Related}}) {
1757 if (($attach->GetHeader('Content-ID') || '') =~ /^(<)?\Q$cid\E(?(1)>)$/) {
1758 push @rewritten, $attach->Id;
1759 return "$args{AttachmentPath}/" . $attach->TransactionId . '/' . $attach->Id;
1763 # No attachments means this is a bogus CID. Just pass it through.
1764 RT->Logger->debug(qq[Found bogus inline image src="cid:$cid"]);
1770 =head2 GetCustomFieldInputName(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1772 Returns the standard custom field input name; this is complementary to
1773 L</_ParseObjectCustomFieldArgs>. Takes the following arguments:
1777 =item CustomField => I<L<RT::CustomField> object>
1781 =item Object => I<object>
1783 The object that the custom field is applied to; optional. If omitted,
1784 defaults to a new object of the appropriate class for the custom field.
1786 =item Grouping => I<CF grouping>
1788 The grouping that the custom field is being rendered in. Groupings
1789 allow a custom field to appear in more than one location per form.
1795 sub GetCustomFieldInputName {
1797 CustomField => undef,
1803 my $name = GetCustomFieldInputNamePrefix(%args);
1805 if ( $args{CustomField}->Type eq 'Select' ) {
1806 if ( $args{CustomField}->RenderType eq 'List' and $args{CustomField}->SingleValue ) {
1813 elsif ( $args{CustomField}->Type =~ /^(?:Binary|Image)$/ ) {
1816 elsif ( $args{CustomField}->Type =~ /^(?:Date|DateTime|Text|Wikitext)$/ ) {
1820 if ( $args{CustomField}->SingleValue ) {
1831 =head2 GetCustomFieldInputNamePrefix(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1833 Returns the standard custom field input name prefix(without "Value" or alike suffix)
1837 sub GetCustomFieldInputNamePrefix {
1839 CustomField => undef,
1845 my $prefix = join '-', 'Object', ref( $args{Object} ) || $args{CustomField}->ObjectTypeFromLookupType,
1846 ( $args{Object} && $args{Object}->id ? $args{Object}->id : '' ),
1847 'CustomField' . ( $args{Grouping} ? ":$args{Grouping}" : '' ),
1848 $args{CustomField}->id, '';
1853 package HTML::Mason::Commands;
1855 use vars qw/$r $m %session/;
1857 use Scalar::Util qw(blessed);
1860 return $HTML::Mason::Commands::m->notes('menu');
1864 return $HTML::Mason::Commands::m->notes('page-menu');
1868 return $HTML::Mason::Commands::m->notes('page-widgets');
1872 my %args = (toplevel => 1, parent_id => '', depth => 0, @_);
1873 return unless $args{'menu'};
1875 my ($menu, $depth, $toplevel, $id, $parent_id)
1876 = @args{qw(menu depth toplevel id parent_id)};
1878 my $interp = $m->interp;
1879 my $web_path = RT->Config->Get('WebPath');
1882 $res .= ' ' x $depth;
1884 $res .= ' id="'. $interp->apply_escapes($id, 'h') .'"'
1886 $res .= ' class="toplevel"' if $toplevel;
1889 for my $child ($menu->children) {
1890 $res .= ' 'x ($depth+1);
1892 my $item_id = lc(($parent_id? "$parent_id-" : "") .$child->key);
1893 $item_id =~ s/\s/-/g;
1894 my $eitem_id = $interp->apply_escapes($item_id, 'h');
1895 $res .= qq{<li id="li-$eitem_id"};
1898 push @classes, 'has-children' if $child->has_children;
1899 push @classes, 'active' if $child->active;
1900 $res .= ' class="'. join( ' ', @classes ) .'"'
1905 if ( my $tmp = $child->raw_html ) {
1908 $res .= qq{<a id="$eitem_id" class="menu-item};
1909 if ( $tmp = $child->class ) {
1910 $res .= ' '. $interp->apply_escapes($tmp, 'h');
1914 my $path = $child->path;
1915 my $url = (not $path or $path =~ m{^\w+:/}) ? $path : $web_path . $path;
1917 $res .= ' href="'. $interp->apply_escapes($url, 'h') .'"';
1919 if ( $tmp = $child->target ) {
1920 $res .= ' target="'. $interp->apply_escapes($tmp, 'h') .'"'
1923 if ($child->attributes) {
1924 for my $key (keys %{$child->attributes}) {
1925 my ($name, $value) = map { $interp->apply_escapes($_, 'h') }
1926 $key, $child->attributes->{$key};
1927 $res .= " $name=\"$value\"";
1932 if ( $child->escape_title ) {
1933 $res .= $interp->apply_escapes($child->title, 'h');
1935 $res .= $child->title;
1940 if ( $child->has_children ) {
1945 parent_id => $item_id,
1950 $res .= ' ' x ($depth+1);
1954 $res .= ' ' x $depth;
1956 return $res if $args{'return'};
1964 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1965 with whatever it's called with. If there is no $session{'CurrentUser'},
1966 it creates a temporary user, so we have something to get a localisation handle
1973 if ( $session{'CurrentUser'}
1974 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1976 return ( $session{'CurrentUser'}->loc(@_) );
1979 RT::CurrentUser->new();
1983 return ( $u->loc(@_) );
1986 # pathetic case -- SystemUser is gone.
1993 =head2 loc_fuzzy STRING
1995 loc_fuzzy is for handling localizations of messages that may already
1996 contain interpolated variables, typically returned from libraries
1997 outside RT's control. It takes the message string and extracts the
1998 variable array automatically by matching against the candidate entries
1999 inside the lexicon file.
2006 if ( $session{'CurrentUser'}
2007 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
2009 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
2011 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
2012 return ( $u->loc_fuzzy($msg) );
2017 # Error - calls Error and aborts
2022 if ( $session{'ErrorDocument'}
2023 && $session{'ErrorDocumentType'} )
2025 $r->content_type( $session{'ErrorDocumentType'} );
2026 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
2029 $m->comp( "/Elements/Error", Why => $why, %args );
2034 sub MaybeRedirectForResults {
2036 Path => $HTML::Mason::Commands::m->request_comp->path,
2043 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
2044 return unless $has_actions || $args{'Force'};
2046 my %arguments = %{ $args{'Arguments'} };
2048 if ( $has_actions ) {
2049 my $key = Digest::MD5::md5_hex( rand(1024) );
2050 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
2052 $arguments{'results'} = $key;
2055 $args{'Path'} =~ s!^/+!!;
2056 my $url = RT->Config->Get('WebURL') . $args{Path};
2058 if ( keys %arguments ) {
2059 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
2061 if ( $args{'Anchor'} ) {
2062 $url .= "#". $args{'Anchor'};
2064 return RT::Interface::Web::Redirect($url);
2067 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
2069 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
2070 redirect to the approvals display page, preserving any arguments.
2072 C<Path>s matching C<Whitelist> are let through.
2074 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
2078 sub MaybeRedirectToApproval {
2080 Path => $HTML::Mason::Commands::m->request_comp->path,
2086 return unless $ENV{REQUEST_METHOD} eq 'GET';
2088 my $id = $args{ARGSRef}->{id};
2091 and RT->Config->Get('ForceApprovalsView')
2092 and not $args{Path} =~ /$args{Whitelist}/)
2094 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
2097 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
2098 MaybeRedirectForResults(
2099 Path => "/Approvals/Display.html",
2101 Anchor => $args{ARGSRef}->{Anchor},
2102 Arguments => $args{ARGSRef},
2108 =head2 CreateTicket ARGS
2110 Create a new ticket, using Mason's %ARGS. returns @results.
2119 my $current_user = $session{'CurrentUser'};
2120 my $Ticket = RT::Ticket->new( $current_user );
2122 my $Queue = RT::Queue->new( $current_user );
2123 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
2124 Abort('Queue not found');
2127 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
2128 Abort('You have no permission to create tickets in that queue.');
2132 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
2133 $due = RT::Date->new( $current_user );
2134 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
2137 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
2138 $starts = RT::Date->new( $current_user );
2139 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
2142 my $sigless = RT::Interface::Web::StripContent(
2143 Content => $ARGS{Content},
2144 ContentType => $ARGS{ContentType},
2145 StripSignature => 1,
2146 CurrentUser => $current_user,
2149 my $date_now = RT::Date->new( $current_user );
2150 $date_now->SetToNow;
2151 my $MIMEObj = MakeMIMEEntity(
2152 Subject => $ARGS{'Subject'},
2153 From => $ARGS{'From'} || $current_user->EmailAddress,
2154 To => $ARGS{'To'} || $Queue->CorrespondAddress
2155 || RT->Config->Get('CorrespondAddress'),
2157 Date => $date_now->RFC2822(Timezone => 'user'),
2159 Type => $ARGS{'ContentType'},
2160 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2164 if ( my $tmp = $session{'Attachments'}{ $ARGS{'Token'} || '' } ) {
2165 push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2167 delete $session{'Attachments'}{ $ARGS{'Token'} || '' }
2168 unless $ARGS{'KeepAttachments'};
2169 $session{'Attachments'} = $session{'Attachments'}
2172 if ( $ARGS{'Attachments'} ) {
2173 push @attachments, grep $_, map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} };
2175 if ( @attachments ) {
2176 $MIMEObj->make_multipart;
2177 $MIMEObj->add_part( $_ ) foreach @attachments;
2180 for my $argument (qw(Encrypt Sign)) {
2181 if ( defined $ARGS{ $argument } ) {
2182 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
2187 Type => $ARGS{'Type'} || 'ticket',
2188 Queue => $ARGS{'Queue'},
2189 Owner => $ARGS{'Owner'},
2192 Requestor => $ARGS{'Requestors'},
2194 AdminCc => $ARGS{'AdminCc'},
2195 InitialPriority => $ARGS{'InitialPriority'},
2196 FinalPriority => $ARGS{'FinalPriority'},
2197 TimeLeft => $ARGS{'TimeLeft'},
2198 TimeEstimated => $ARGS{'TimeEstimated'},
2199 TimeWorked => $ARGS{'TimeWorked'},
2200 Subject => $ARGS{'Subject'},
2201 Status => $ARGS{'Status'},
2202 Due => $due ? $due->ISO : undef,
2203 Starts => $starts ? $starts->ISO : undef,
2204 MIMEObj => $MIMEObj,
2205 SquelchMailTo => $ARGS{'SquelchMailTo'},
2206 TransSquelchMailTo => $ARGS{'TransSquelchMailTo'},
2209 if ($ARGS{'DryRun'}) {
2210 $create_args{DryRun} = 1;
2211 $create_args{Owner} ||= $RT::Nobody->Id;
2212 $create_args{Requestor} ||= $session{CurrentUser}->EmailAddress;
2213 $create_args{Subject} ||= '';
2214 $create_args{Status} ||= $Queue->Lifecycle->DefaultOnCreate,
2217 foreach my $type (qw(Requestor Cc AdminCc)) {
2218 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
2219 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
2221 push @{$create_args{TransSquelchMailTo}}, @txn_squelch;
2224 if ( $ARGS{'AttachTickets'} ) {
2225 require RT::Action::SendEmail;
2226 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2227 ref $ARGS{'AttachTickets'}
2228 ? @{ $ARGS{'AttachTickets'} }
2229 : ( $ARGS{'AttachTickets'} ) );
2232 my %cfs = ProcessObjectCustomFieldUpdatesForCreate(
2234 ContextObject => $Queue,
2237 my %links = ProcessLinksForCreate( ARGSRef => \%ARGS );
2239 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args, %links, %cfs);
2240 return $Trans if $ARGS{DryRun};
2246 push( @Actions, split( "\n", $ErrMsg ) );
2247 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
2248 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
2250 return ( $Ticket, @Actions );
2256 =head2 LoadTicket id
2258 Takes a ticket id as its only variable. if it's handed an array, it takes
2261 Returns an RT::Ticket object as the current user.
2268 if ( ref($id) eq "ARRAY" ) {
2273 Abort("No ticket specified");
2276 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
2278 unless ( $Ticket->id ) {
2279 Abort("Could not load ticket $id");
2286 =head2 ProcessUpdateMessage
2288 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
2290 Don't write message if it only contains current user's signature and
2291 SkipSignatureOnly argument is true. Function anyway adds attachments
2292 and updates time worked field even if skips message. The default value
2297 # change from stock: if txn custom fields are set but there's no content
2298 # or attachment, create a Touch txn instead of doing nothing
2300 sub ProcessUpdateMessage {
2305 SkipSignatureOnly => 1,
2310 if ( my $tmp = $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' } ) {
2311 push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2313 delete $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' }
2314 unless $args{'KeepAttachments'};
2315 $session{'Attachments'} = $session{'Attachments'}
2318 if ( $args{ARGSRef}{'UpdateAttachments'} ) {
2319 push @attachments, grep $_, map $args{ARGSRef}->{UpdateAttachments}{$_},
2320 sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2323 # Strip the signature
2324 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
2325 Content => $args{ARGSRef}->{UpdateContent},
2326 ContentType => $args{ARGSRef}->{UpdateContentType},
2327 StripSignature => $args{SkipSignatureOnly},
2328 CurrentUser => $args{'TicketObj'}->CurrentUser,
2331 my %txn_customfields;
2333 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2334 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
2335 next if $key =~ /(TimeUnits|Magic)$/;
2336 $txn_customfields{$key} = $args{ARGSRef}->{$key};
2340 # If, after stripping the signature, we have no message, create a
2341 # Touch transaction if necessary
2342 if ( not @attachments
2343 and not length $args{ARGSRef}->{'UpdateContent'} )
2345 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
2346 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
2347 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
2350 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
2351 if ( $timetaken or grep {length $_} values %txn_customfields ) {
2352 my ( $Transaction, $Description, $Object ) =
2353 $args{TicketObj}->Touch(
2354 CustomFields => \%txn_customfields,
2355 TimeTaken => $timetaken
2357 return $Description;
2362 if ( ($args{ARGSRef}->{'UpdateSubject'}||'') eq ($args{'TicketObj'}->Subject || '') ) {
2363 $args{ARGSRef}->{'UpdateSubject'} = undef;
2366 my $Message = MakeMIMEEntity(
2367 Subject => $args{ARGSRef}->{'UpdateSubject'},
2368 Body => $args{ARGSRef}->{'UpdateContent'},
2369 Type => $args{ARGSRef}->{'UpdateContentType'},
2370 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2373 $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
2374 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2376 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2377 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2378 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2380 $old_txn = $args{TicketObj}->Transactions->First();
2383 if ( my $msg = $old_txn->Message->First ) {
2384 RT::Interface::Email::SetInReplyTo(
2385 Message => $Message,
2387 Ticket => $args{'TicketObj'},
2391 if ( @attachments ) {
2392 $Message->make_multipart;
2393 $Message->add_part( $_ ) foreach @attachments;
2396 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2397 require RT::Action::SendEmail;
2398 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2399 ref $args{ARGSRef}->{'AttachTickets'}
2400 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2401 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2404 my %message_args = (
2405 Sign => $args{ARGSRef}->{'Sign'},
2406 Encrypt => $args{ARGSRef}->{'Encrypt'},
2407 MIMEObj => $Message,
2408 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2409 CustomFields => \%txn_customfields,
2412 _ProcessUpdateMessageRecipients(
2413 MessageArgs => \%message_args,
2418 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2419 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2420 push( @results, $Description );
2421 $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2422 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2423 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2424 push( @results, $Description );
2425 $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2428 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2433 sub _ProcessUpdateMessageRecipients {
2437 MessageArgs => undef,
2441 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2442 my $cc = $args{ARGSRef}->{'UpdateCc'};
2444 my $message_args = $args{MessageArgs};
2446 $message_args->{CcMessageTo} = $cc;
2447 $message_args->{BccMessageTo} = $bcc;
2450 foreach my $type (qw(Cc AdminCc)) {
2451 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2452 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2453 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2454 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2457 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2458 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2459 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2462 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2463 $message_args->{SquelchMailTo} = \@txn_squelch
2466 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2467 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2468 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2470 my $var = ucfirst($1) . 'MessageTo';
2472 if ( $message_args->{$var} ) {
2473 $message_args->{$var} .= ", $value";
2475 $message_args->{$var} = $value;
2481 sub ProcessAttachments {
2488 my $token = $args{'ARGSRef'}{'Token'}
2489 ||= $args{'Token'} ||= Digest::MD5::md5_hex( rand(1024) );
2491 my $update_session = 0;
2493 # deal with deleting uploaded attachments
2494 if ( my $del = $args{'ARGSRef'}{'DeleteAttach'} ) {
2495 delete $session{'Attachments'}{ $token }{ $_ }
2496 foreach ref $del? @$del : ($del);
2498 $update_session = 1;
2501 # store the uploaded attachment in session
2502 my $new = $args{'ARGSRef'}{'Attach'};
2503 if ( defined $new && length $new ) {
2504 my $attachment = MakeMIMEEntity(
2505 AttachmentFieldName => 'Attach'
2508 # This needs to be decoded because the value is a reference;
2509 # hence it was not decoded along with all of the standard
2510 # arguments in DecodeARGS
2511 my $file_path = Encode::decode( "UTF-8", "$new");
2512 $session{'Attachments'}{ $token }{ $file_path } = $attachment;
2514 $update_session = 1;
2516 $session{'Attachments'} = $session{'Attachments'} if $update_session;
2520 =head2 MakeMIMEEntity PARAMHASH
2522 Takes a paramhash Subject, Body and AttachmentFieldName.
2524 Also takes Form, Cc and Type as optional paramhash keys.
2526 Returns a MIME::Entity.
2530 sub MakeMIMEEntity {
2532 #TODO document what else this takes.
2538 AttachmentFieldName => undef,
2543 my $Message = MIME::Entity->build(
2544 Type => 'multipart/mixed',
2545 "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
2546 "X-RT-Interface" => $args{Interface},
2547 map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
2548 grep defined $args{$_}, qw(Subject From Cc To Date)
2551 if ( defined $args{'Body'} && length $args{'Body'} ) {
2553 # Make the update content have no 'weird' newlines in it
2554 $args{'Body'} =~ s/\r\n/\n/gs;
2557 Type => $args{'Type'} || 'text/plain',
2559 Data => Encode::encode( "UTF-8", $args{'Body'} ),
2563 if ( $args{'AttachmentFieldName'} ) {
2565 my $cgi_object = $m->cgi_object;
2566 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2567 if ( defined $filehandle && length $filehandle ) {
2569 my ( @content, $buffer );
2570 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2571 push @content, $buffer;
2574 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2576 my $filename = Encode::decode("UTF-8","$filehandle");
2577 $filename =~ s{^.*[\\/]}{};
2580 Type => $uploadinfo->{'Content-Type'},
2581 Filename => Encode::encode("UTF-8",$filename),
2582 Data => \@content, # Bytes, as read directly from the file, above
2584 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2585 $Message->head->replace( 'Subject' => Encode::encode( "UTF-8", $filename ) );
2588 # Attachment parts really shouldn't get a Message-ID or "interface"
2589 $Message->head->delete('Message-ID');
2590 $Message->head->delete('X-RT-Interface');
2594 $Message->make_singlepart;
2596 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2604 =head2 ParseDateToISO
2606 Takes a date in an arbitrary format.
2607 Returns an ISO date and time in GMT
2611 sub ParseDateToISO {
2614 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2616 Format => 'unknown',
2619 return ( $date_obj->ISO );
2624 sub ProcessACLChanges {
2625 my $ARGSref = shift;
2629 foreach my $arg ( keys %$ARGSref ) {
2630 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2632 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2635 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2636 @rights = @{ $ARGSref->{$arg} };
2638 @rights = $ARGSref->{$arg};
2640 @rights = grep $_, @rights;
2641 next unless @rights;
2643 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2644 $principal->Load($principal_id);
2647 if ( $object_type eq 'RT::System' ) {
2649 } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2650 $obj = $object_type->new( $session{'CurrentUser'} );
2651 $obj->Load($object_id);
2652 unless ( $obj->id ) {
2653 $RT::Logger->error("couldn't load $object_type #$object_id");
2657 $RT::Logger->error("object type '$object_type' is incorrect");
2658 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2662 foreach my $right (@rights) {
2663 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2664 push( @results, $msg );
2674 ProcessACLs expects values from a series of checkboxes that describe the full
2675 set of rights a principal should have on an object.
2677 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2678 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2679 listing the rights the principal should have, and ProcessACLs will modify the
2680 current rights to match. Additionally, the previously unused CheckACL input
2681 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2682 rights are removed from a principal and as such no SetRights input is
2688 my $ARGSref = shift;
2689 my (%state, @results);
2691 my $CheckACL = $ARGSref->{'CheckACL'};
2692 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2694 # Check if we want to grant rights to a previously rights-less user
2695 for my $type (qw(user group)) {
2696 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2699 unless ($principal->PrincipalId) {
2700 push @results, loc("Couldn't load the specified principal");
2704 my $principal_id = $principal->PrincipalId;
2706 # Turn our addprincipal rights spec into a real one
2707 for my $arg (keys %$ARGSref) {
2708 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2710 my $tuple = "$principal_id-$1";
2711 my $key = "SetRights-$tuple";
2713 # If we have it already, that's odd, but merge them
2714 if (grep { $_ eq $tuple } @check) {
2715 $ARGSref->{$key} = [
2716 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2717 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2720 $ARGSref->{$key} = $ARGSref->{$arg};
2721 push @check, $tuple;
2726 # Build our rights state for each Principal-Object tuple
2727 foreach my $arg ( keys %$ARGSref ) {
2728 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2731 my $value = $ARGSref->{$arg};
2732 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2733 next unless @rights;
2735 $state{$tuple} = { map { $_ => 1 } @rights };
2738 foreach my $tuple (List::MoreUtils::uniq @check) {
2739 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2741 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2743 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2744 $principal->Load($principal_id);
2747 if ( $object_type eq 'RT::System' ) {
2749 } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2750 $obj = $object_type->new( $session{'CurrentUser'} );
2751 $obj->Load($object_id);
2752 unless ( $obj->id ) {
2753 $RT::Logger->error("couldn't load $object_type #$object_id");
2757 $RT::Logger->error("object type '$object_type' is incorrect");
2758 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2762 my $acls = RT::ACL->new($session{'CurrentUser'});
2763 $acls->LimitToObject( $obj );
2764 $acls->LimitToPrincipal( Id => $principal_id );
2766 while ( my $ace = $acls->Next ) {
2767 my $right = $ace->RightName;
2769 # Has right and should have right
2770 next if delete $state{$tuple}->{$right};
2772 # Has right and shouldn't have right
2773 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2774 push @results, $msg;
2777 # For everything left, they don't have the right but they should
2778 for my $right (keys %{ $state{$tuple} || {} }) {
2779 delete $state{$tuple}->{$right};
2780 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2781 push @results, $msg;
2784 # Check our state for leftovers
2785 if ( keys %{ $state{$tuple} || {} } ) {
2786 my $missed = join '|', %{$state{$tuple} || {}};
2788 "Uh-oh, it looks like we somehow missed a right in "
2789 ."ProcessACLs. Here's what was leftover: $missed"
2797 =head2 _ParseACLNewPrincipal
2799 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2800 for the presence of rights being added on a principal of the specified type,
2801 and returns undef if no new principal is being granted rights. Otherwise loads
2802 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2803 may not be successfully loaded, and you should check C<->id> yourself.
2807 sub _ParseACLNewPrincipal {
2808 my $ARGSref = shift;
2809 my $type = lc shift;
2810 my $key = "AddPrincipalForRights-$type";
2812 return unless $ARGSref->{$key};
2815 if ( $type eq 'user' ) {
2816 $principal = RT::User->new( $session{'CurrentUser'} );
2817 $principal->LoadByCol( Name => $ARGSref->{$key} );
2819 elsif ( $type eq 'group' ) {
2820 $principal = RT::Group->new( $session{'CurrentUser'} );
2821 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2827 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2829 @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.
2831 Returns an array of success/failure messages
2835 sub UpdateRecordObject {
2838 AttributesRef => undef,
2840 AttributePrefix => undef,
2844 my $Object = $args{'Object'};
2845 my @results = $Object->Update(
2846 AttributesRef => $args{'AttributesRef'},
2847 ARGSRef => $args{'ARGSRef'},
2848 AttributePrefix => $args{'AttributePrefix'},
2856 sub ProcessCustomFieldUpdates {
2858 CustomFieldObj => undef,
2863 my $Object = $args{'CustomFieldObj'};
2864 my $ARGSRef = $args{'ARGSRef'};
2866 my @attribs = qw(Name Type Description Queue SortOrder);
2867 my @results = UpdateRecordObject(
2868 AttributesRef => \@attribs,
2873 my $prefix = "CustomField-" . $Object->Id;
2874 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2875 my ( $addval, $addmsg ) = $Object->AddValue(
2876 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2877 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2878 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2880 push( @results, $addmsg );
2884 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2885 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2886 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2888 foreach my $id (@delete_values) {
2889 next unless defined $id;
2890 my ( $err, $msg ) = $Object->DeleteValue($id);
2891 push( @results, $msg );
2894 my $vals = $Object->Values();
2895 while ( my $cfv = $vals->Next() ) {
2896 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2897 if ( $cfv->SortOrder != $so ) {
2898 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2899 push( @results, $msg );
2909 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2911 Returns an array of results messages.
2915 sub ProcessTicketBasics {
2923 my $TicketObj = $args{'TicketObj'};
2924 my $ARGSRef = $args{'ARGSRef'};
2926 my $OrigOwner = $TicketObj->Owner;
2941 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2942 for my $field (qw(Queue Owner)) {
2943 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2944 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2945 my $temp = $class->new(RT->SystemUser);
2946 $temp->Load( $ARGSRef->{$field} );
2948 $ARGSRef->{$field} = $temp->id;
2953 # Status isn't a field that can be set to a null value.
2954 # RT core complains if you try
2955 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2957 my @results = UpdateRecordObject(
2958 AttributesRef => \@attribs,
2959 Object => $TicketObj,
2960 ARGSRef => $ARGSRef,
2963 # We special case owner changing, so we can use ForceOwnerChange
2964 if ( $ARGSRef->{'Owner'}
2965 && $ARGSRef->{'Owner'} !~ /\D/
2966 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2968 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2969 $ChownType = "Force";
2975 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2976 push( @results, $msg );
2984 sub ProcessTicketReminders {
2991 my $Ticket = $args{'TicketObj'};
2992 my $args = $args{'ARGSRef'};
2995 my $reminder_collection = $Ticket->Reminders->Collection;
2997 if ( $args->{'update-reminders'} ) {
2998 while ( my $reminder = $reminder_collection->Next ) {
2999 my $resolve_status = $reminder->LifecycleObj->ReminderStatusOnResolve;
3000 my ( $status, $msg, $old_subject, @subresults );
3001 if ( $reminder->Status ne $resolve_status
3002 && $args->{ 'Complete-Reminder-' . $reminder->id } )
3004 ( $status, $msg ) = $Ticket->Reminders->Resolve($reminder);
3005 push @subresults, $msg;
3007 elsif ( $reminder->Status eq $resolve_status
3008 && !$args->{ 'Complete-Reminder-' . $reminder->id } )
3010 ( $status, $msg ) = $Ticket->Reminders->Open($reminder);
3011 push @subresults, $msg;
3015 exists( $args->{ 'Reminder-Subject-' . $reminder->id } )
3016 && ( $reminder->Subject ne
3017 $args->{ 'Reminder-Subject-' . $reminder->id } )
3020 $old_subject = $reminder->Subject;
3022 $reminder->SetSubject(
3023 $args->{ 'Reminder-Subject-' . $reminder->id } );
3024 push @subresults, $msg;
3028 exists( $args->{ 'Reminder-Owner-' . $reminder->id } )
3029 && ( $reminder->Owner !=
3030 $args->{ 'Reminder-Owner-' . $reminder->id } )
3034 $reminder->SetOwner(
3035 $args->{ 'Reminder-Owner-' . $reminder->id }, "Force" );
3036 push @subresults, $msg;
3039 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } )
3040 && $args->{ 'Reminder-Due-' . $reminder->id } ne '' )
3042 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3043 my $due = $args->{ 'Reminder-Due-' . $reminder->id };
3046 Format => 'unknown',
3049 if ( $DateObj->Unix != $reminder->DueObj->Unix ) {
3050 ( $status, $msg ) = $reminder->SetDue( $DateObj->ISO );
3053 $msg = loc( "invalid due date: [_1]", $due );
3056 push @subresults, $msg;
3059 push @results, map {
3060 loc( "Reminder '[_1]': [_2]", $old_subject || $reminder->Subject, $_ )
3065 if ( $args->{'NewReminder-Subject'} ) {
3066 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
3068 Format => 'unknown',
3069 Value => $args->{'NewReminder-Due'}
3071 my ( $status, $msg ) = $Ticket->Reminders->Add(
3072 Subject => $args->{'NewReminder-Subject'},
3073 Owner => $args->{'NewReminder-Owner'},
3074 Due => $due_obj->ISO
3078 loc( "Reminder '[_1]': [_2]", $args->{'NewReminder-Subject'}, loc("Created") )
3081 push @results, $msg;
3087 sub ProcessObjectCustomFieldUpdates {
3089 my $ARGSRef = $args{'ARGSRef'};
3092 # Build up a list of objects that we want to work with
3093 my %custom_fields_to_mod = _ParseObjectCustomFieldArgs($ARGSRef);
3095 # For each of those objects
3096 foreach my $class ( keys %custom_fields_to_mod ) {
3097 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
3098 my $Object = $args{'Object'};
3099 $Object = $class->new( $session{'CurrentUser'} )
3100 unless $Object && ref $Object eq $class;
3102 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
3103 unless ( $Object->id ) {
3104 $RT::Logger->warning("Couldn't load object $class #$id");
3108 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
3109 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
3110 $CustomFieldObj->SetContextObject($Object);
3111 $CustomFieldObj->LoadById($cf);
3112 unless ( $CustomFieldObj->id ) {
3113 $RT::Logger->warning("Couldn't load custom field #$cf");
3116 my @groupings = sort keys %{ $custom_fields_to_mod{$class}{$id}{$cf} };
3117 if (@groupings > 1) {
3118 # Check for consistency, in case of JS fail
3119 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3120 my $base = $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]}{$key};
3121 $base = [ $base ] unless ref $base;
3122 for my $grouping (@groupings[1..$#groupings]) {
3123 my $other = $custom_fields_to_mod{$class}{$id}{$cf}{$grouping}{$key};
3124 $other = [ $other ] unless ref $other;
3125 warn "CF $cf submitted with multiple differing values"
3126 if grep {$_} List::MoreUtils::pairwise {
3127 no warnings qw(uninitialized);
3129 } @{$base}, @{$other};
3132 # We'll just be picking the 1st grouping in the hash, alphabetically
3135 _ProcessObjectCustomFieldUpdates(
3136 Prefix => GetCustomFieldInputNamePrefix(
3138 CustomField => $CustomFieldObj,
3139 Grouping => $groupings[0],
3142 CustomField => $CustomFieldObj,
3143 ARGS => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] },
3151 sub _ParseObjectCustomFieldArgs {
3152 my $ARGSRef = shift || {};
3153 my %custom_fields_to_mod;
3155 foreach my $arg ( keys %$ARGSRef ) {
3157 # format: Object-<object class>-<object id>-CustomField[:<grouping>]-<CF id>-<commands>
3158 # or: Bulk-<Add or Delete>-CustomField[:<grouping>]-<CF id>-<commands>
3159 # you can use GetCustomFieldInputName to generate the complement input name
3160 next unless $arg =~ /^(?:Bulk-(?:Add|Delete)|Object-([\w:]+)-(\d*))-CustomField(?::(\w+))?-(\d+)-(.*)$/;
3162 next if $1 eq 'RT::Transaction';# don't try to update transaction fields
3164 # For each of those objects, find out what custom fields we want to work with.
3165 # Class ID CF grouping command
3166 $custom_fields_to_mod{$1}{ $2 || 0 }{$4}{$3 || ''}{$5} = $ARGSRef->{$arg};
3169 return wantarray ? %custom_fields_to_mod : \%custom_fields_to_mod;
3172 sub _ProcessObjectCustomFieldUpdates {
3174 my $cf = $args{'CustomField'};
3175 my $cf_type = $cf->Type || '';
3177 # Remove blank Values since the magic field will take care of this. Sometimes
3178 # the browser gives you a blank value which causes CFs to be processed twice
3179 if ( defined $args{'ARGS'}->{'Values'}
3180 && !length $args{'ARGS'}->{'Values'}
3181 && ($args{'ARGS'}->{'Values-Magic'}) )
3183 delete $args{'ARGS'}->{'Values'};
3187 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
3189 # skip category argument
3190 next if $arg =~ /-Category$/;
3193 next if $arg eq 'Value-TimeUnits';
3195 # since http won't pass in a form element with a null value, we need
3197 if ( $arg =~ /-Magic$/ ) {
3199 # We don't care about the magic, if there's really a values element;
3200 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
3201 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
3203 # "Empty" values does not mean anything for Image and Binary fields
3204 next if $cf_type =~ /^(?:Image|Binary)$/;
3207 $args{'ARGS'}->{'Values'} = undef;
3210 my @values = _NormalizeObjectCustomFieldValue(
3212 Param => $args{'Prefix'} . $arg,
3213 Value => $args{'ARGS'}->{$arg}
3216 # "Empty" values still don't mean anything for Image and Binary fields
3217 next if $cf_type =~ /^(?:Image|Binary)$/ and not @values;
3219 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
3220 foreach my $value (@values) {
3221 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3225 push( @results, $msg );
3227 } elsif ( $arg eq 'Upload' ) {
3228 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %{$values[0]}, Field => $cf, );
3229 push( @results, $msg );
3230 } elsif ( $arg eq 'DeleteValues' ) {
3231 foreach my $value (@values) {
3232 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3236 push( @results, $msg );
3238 } elsif ( $arg eq 'DeleteValueIds' ) {
3239 foreach my $value (@values) {
3240 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3244 push( @results, $msg );
3246 } elsif ( $arg eq 'Values' ) {
3247 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
3250 foreach my $value (@values) {
3251 if ( my $entry = $cf_values->HasEntry($value) ) {
3252 $values_hash{ $entry->id } = 1;
3256 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3260 push( @results, $msg );
3261 $values_hash{$val} = 1 if $val;
3264 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3265 return @results if ( $cf->Type eq 'Date' && ! @values );
3267 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3268 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
3270 $cf_values->RedoSearch;
3271 while ( my $cf_value = $cf_values->Next ) {
3272 next if $values_hash{ $cf_value->id };
3274 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3276 ValueId => $cf_value->id
3278 push( @results, $msg );
3283 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
3284 $cf->Name, ref $args{'Object'},
3293 sub ProcessObjectCustomFieldUpdatesForCreate {
3296 ContextObject => undef,
3299 my $context = $args{'ContextObject'};
3301 my %custom_fields = _ParseObjectCustomFieldArgs( $args{'ARGSRef'} );
3303 for my $class (keys %custom_fields) {
3304 # we're only interested in new objects, so only look at $id == 0
3305 for my $cfid (keys %{ $custom_fields{$class}{0} || {} }) {
3306 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3308 my $system_cf = RT::CustomField->new( RT->SystemUser );
3309 $system_cf->LoadById($cfid);
3310 if ($system_cf->ValidateContextObject($context)) {
3311 $cf->SetContextObject($context);
3314 sprintf "Invalid context object %s (%d) for CF %d; skipping CF",
3315 ref $context, $context->id, $system_cf->id
3320 $cf->LoadById($cfid);
3323 RT->Logger->warning("Couldn't load custom field #$cfid");
3327 my @groupings = sort keys %{ $custom_fields{$class}{0}{$cfid} };
3328 if (@groupings > 1) {
3329 # Check for consistency, in case of JS fail
3330 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3331 warn "CF $cfid submitted with multiple differing $key"
3332 if grep {($custom_fields{$class}{0}{$cfid}{$_}{$key} || '')
3333 ne ($custom_fields{$class}{0}{$cfid}{$groupings[0]}{$key} || '')}
3336 # We'll just be picking the 1st grouping in the hash, alphabetically
3340 my $name_prefix = GetCustomFieldInputNamePrefix(
3342 Grouping => $groupings[0],
3344 while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) {
3345 # Values-Magic doesn't matter on create; no previous values are being removed
3346 # Category is irrelevant for the actual value
3347 next if $arg =~ /-Magic$/ or $arg =~ /-Category$/;
3350 _NormalizeObjectCustomFieldValue(
3352 Param => $name_prefix . $arg,
3357 $parsed{"CustomField-$cfid"} = \@values if @values;
3361 return wantarray ? %parsed : \%parsed;
3364 sub _NormalizeObjectCustomFieldValue {
3369 my $cf_type = $args{CustomField}->Type;
3372 if ( ref $args{'Value'} eq 'ARRAY' ) {
3373 @values = @{ $args{'Value'} };
3374 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
3375 @values = ( $args{'Value'} );
3377 @values = split /\r*\n/, $args{'Value'}
3378 if defined $args{'Value'};
3380 @values = grep length, map {
3386 grep defined, @values;
3388 if ($args{'Param'} =~ /-Upload$/ and $cf_type =~ /^(Image|Binary)$/) {
3389 @values = _UploadedFile( $args{'Param'} ) || ();
3395 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3397 Returns an array of results messages.
3401 sub ProcessTicketWatchers {
3409 my $Ticket = $args{'TicketObj'};
3410 my $ARGSRef = $args{'ARGSRef'};
3414 foreach my $key ( keys %$ARGSRef ) {
3416 # Delete deletable watchers
3417 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
3418 my ( $code, $msg ) = $Ticket->DeleteWatcher(
3422 push @results, $msg;
3425 # Delete watchers in the simple style demanded by the bulk manipulator
3426 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
3427 my ( $code, $msg ) = $Ticket->DeleteWatcher(
3428 Email => $ARGSRef->{$key},
3431 push @results, $msg;
3434 # Add new wathchers by email address
3435 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
3436 and $key =~ /^WatcherTypeEmail(\d*)$/ )
3439 #They're in this order because otherwise $1 gets clobbered :/
3440 my ( $code, $msg ) = $Ticket->AddWatcher(
3441 Type => $ARGSRef->{$key},
3442 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
3444 push @results, $msg;
3447 #Add requestors in the simple style demanded by the bulk manipulator
3448 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
3449 my ( $code, $msg ) = $Ticket->AddWatcher(
3451 Email => $ARGSRef->{$key}
3453 push @results, $msg;
3456 # Add new watchers by owner
3457 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
3458 my $principal_id = $1;
3459 my $form = $ARGSRef->{$key};
3460 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
3461 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
3463 my ( $code, $msg ) = $Ticket->AddWatcher(
3465 PrincipalId => $principal_id
3467 push @results, $msg;
3477 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3479 Returns an array of results messages.
3483 sub ProcessTicketDates {
3490 my $Ticket = $args{'TicketObj'};
3491 my $ARGSRef = $args{'ARGSRef'};
3496 my @date_fields = qw(
3504 #Run through each field in this list. update the value if apropriate
3505 foreach my $field (@date_fields) {
3506 next unless exists $ARGSRef->{ $field . '_Date' };
3507 next if $ARGSRef->{ $field . '_Date' } eq '';
3511 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3513 Format => 'unknown',
3514 Value => $ARGSRef->{ $field . '_Date' }
3517 my $obj = $field . "Obj";
3518 if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) {
3519 my $method = "Set$field";
3520 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3521 push @results, "$msg";
3531 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3533 Returns an array of results messages.
3537 sub ProcessTicketLinks {
3545 my $Ticket = $args{'TicketObj'};
3546 my $TicketId = $args{'TicketId'} || $Ticket->Id;
3547 my $ARGSRef = $args{'ARGSRef'};
3549 my (@results) = ProcessRecordLinks(
3550 %args, RecordObj => $Ticket, RecordId => $TicketId, ARGSRef => $ARGSRef,
3553 #Merge if we need to
3554 my $input = $TicketId .'-MergeInto';
3555 if ( $ARGSRef->{ $input } ) {
3556 $ARGSRef->{ $input } =~ s/\s+//g;
3557 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $input } );
3558 push @results, $msg;
3565 sub ProcessRecordLinks {
3573 my $Record = $args{'RecordObj'};
3574 my $RecordId = $args{'RecordId'} || $Record->Id;
3575 my $ARGSRef = $args{'ARGSRef'};
3579 # Delete links that are gone gone gone.
3580 foreach my $arg ( keys %$ARGSRef ) {
3581 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3586 my ( $val, $msg ) = $Record->DeleteLink(
3592 push @results, $msg;
3598 my @linktypes = qw( DependsOn MemberOf RefersTo );
3600 foreach my $linktype (@linktypes) {
3601 my $input = $RecordId .'-'. $linktype;
3602 if ( $ARGSRef->{ $input } ) {
3603 $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3604 if ref $ARGSRef->{ $input };
3606 for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3608 $luri =~ s/\s+$//; # Strip trailing whitespace
3609 my ( $val, $msg ) = $Record->AddLink(
3613 push @results, $msg;
3616 $input = $linktype .'-'. $RecordId;
3617 if ( $ARGSRef->{ $input } ) {
3618 $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3619 if ref $ARGSRef->{ $input };
3621 for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3623 my ( $val, $msg ) = $Record->AddLink(
3628 push @results, $msg;
3636 =head2 ProcessLinksForCreate
3638 Takes a hash with a single key, C<ARGSRef>, the value of which is a hashref to
3641 Converts and returns submitted args in the form of C<new-LINKTYPE> and
3642 C<LINKTYPE-new> into their appropriate directional link types. For example,
3643 C<new-DependsOn> becomes C<DependsOn> and C<DependsOn-new> becomes
3644 C<DependedOnBy>. The incoming arg values are split on whitespace and
3645 normalized into arrayrefs before being returned.
3647 Primarily used by object creation pages for transforming incoming form inputs
3648 from F</Elements/EditLinks> into arguments appropriate for individual record
3651 Returns a hashref in scalar context and a hash in list context.
3655 sub ProcessLinksForCreate {
3659 foreach my $type ( keys %RT::Link::DIRMAP ) {
3660 for ([Base => "new-$type"], [Target => "$type-new"]) {
3661 my ($direction, $key) = @$_;
3662 next unless $args{ARGSRef}->{$key};
3663 $links{ $RT::Link::DIRMAP{$type}->{$direction} } = [
3664 grep $_, split ' ', $args{ARGSRef}->{$key}
3668 return wantarray ? %links : \%links;
3671 =head2 ProcessTransactionSquelching
3673 Takes a hashref of the submitted form arguments, C<%ARGS>.
3675 Returns a hash of squelched addresses.
3679 sub ProcessTransactionSquelching {
3681 my %checked = map { $_ => 1 } grep { defined }
3682 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3683 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3685 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3689 sub ProcessRecordBulkCustomFields {
3690 my %args = (RecordObj => undef, ARGSRef => {}, @_);
3692 my $ARGSRef = $args{'ARGSRef'};
3697 foreach my $key ( keys %$ARGSRef ) {
3698 next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/;
3699 my ($op, $cfid, $rest) = ($1, $2, $3);
3700 next if $rest =~ /-Category$/;
3702 my $res = $data{$cfid} ||= {};
3703 unless (keys %$res) {
3704 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3706 next unless $cf->Id;
3711 if ( $op eq 'Delete' && $rest eq 'AllValues' ) {
3712 $res->{'DeleteAll'} = $ARGSRef->{$key};
3716 my @values = _NormalizeObjectCustomFieldValue(
3717 CustomField => $res->{'cf'},
3718 Value => $ARGSRef->{$key},
3721 next unless @values;
3722 $res->{$op} = \@values;
3725 while ( my ($cfid, $data) = each %data ) {
3726 my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid );
3728 # just add one value for fields with single value
3729 if ( $data->{'Add'} && $data->{'cf'}->MaxValues == 1 ) {
3730 next if $current_values->HasEntry($data->{Add}[-1]);
3732 my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3734 Value => $data->{'Add'}[-1],
3736 push @results, $msg;
3740 if ( $data->{'DeleteAll'} ) {
3741 while ( my $value = $current_values->Next ) {
3742 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3744 ValueId => $value->id,
3746 push @results, $msg;
3749 foreach my $value ( @{ $data->{'Delete'} || [] } ) {
3750 my $entry = $current_values->HasEntry($value);
3753 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3755 ValueId => $entry->id,
3757 push @results, $msg;
3759 foreach my $value ( @{ $data->{'Add'} || [] } ) {
3760 next if $current_values->HasEntry($value);
3762 my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3766 push @results, $msg;
3772 =head2 _UploadedFile ( $arg );
3774 Takes a CGI parameter name; if a file is uploaded under that name,
3775 return a hash reference suitable for AddCustomFieldValue's use:
3776 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3778 Returns C<undef> if no files were uploaded in the C<$arg> field.
3784 my $cgi_object = $m->cgi_object;
3785 my $fh = $cgi_object->upload($arg) or return undef;
3786 my $upload_info = $cgi_object->uploadInfo($fh);
3788 my $filename = "$fh";
3789 $filename =~ s#^.*[\\/]##;
3794 LargeContent => do { local $/; scalar <$fh> },
3795 ContentType => $upload_info->{'Content-Type'},
3799 sub GetColumnMapEntry {
3800 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3802 # deal with the simplest thing first
3803 if ( $args{'Map'}{ $args{'Name'} } ) {
3804 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3808 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3809 $subkey =~ s/^\{(.*)\}$/$1/;
3810 return undef unless $args{'Map'}->{$mainkey};
3811 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3812 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3814 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3819 sub ProcessColumnMapValue {
3821 my %args = ( Arguments => [], Escape => 1, @_ );
3824 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3825 my @tmp = $value->( @{ $args{'Arguments'} } );
3826 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3827 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3828 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3829 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3833 if ($args{'Escape'}) {
3834 $value = $m->interp->apply_escapes( $value, 'h' );
3835 $value =~ s/\n/<br>/g if defined $value;
3841 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3843 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3844 principal collections mapped from the categories given.
3848 sub GetPrincipalsMap {
3853 my $system = RT::Groups->new($session{'CurrentUser'});
3854 $system->LimitToSystemInternalGroups();
3855 $system->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3857 'System' => $system, # loc_left_pair
3862 my $groups = RT::Groups->new($session{'CurrentUser'});
3863 $groups->LimitToUserDefinedGroups();
3864 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3866 # Only show groups who have rights granted on this object
3867 $groups->WithGroupRight(
3870 IncludeSystemRights => 0,
3871 IncludeSubgroupMembers => 0,
3875 'User Groups' => $groups, # loc_left_pair
3880 my $roles = RT::Groups->new($session{'CurrentUser'});
3882 if ($object->isa("RT::CustomField")) {
3883 # If we're a custom field, show the global roles for our LookupType.
3884 my $class = $object->RecordClassFromLookupType;
3885 if ($class and $class->DOES("RT::Record::Role::Roles")) {
3886 $roles->LimitToRolesForObject(RT->System);
3889 FUNCTION => 'LOWER(?)',
3891 VALUE => [ map {lc $_} $class->Roles ],
3895 # No roles to show; so show nothing
3899 $roles->LimitToRolesForObject($object);
3903 $roles->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3905 'Roles' => $roles, # loc_left_pair
3911 my $Users = RT->PrivilegedUsers->UserMembersObj();
3912 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3914 # Only show users who have rights granted on this object
3915 my $group_members = $Users->WhoHaveGroupRight(
3918 IncludeSystemRights => 0,
3919 IncludeSubgroupMembers => 0,
3922 # Limit to UserEquiv groups
3923 my $groups = $Users->Join(
3924 ALIAS1 => $group_members,
3925 FIELD1 => 'GroupId',
3929 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence', CASESENSITIVE => 0 );
3930 $Users->Limit( ALIAS => $groups, FIELD => 'Name', VALUE => 'UserEquiv', CASESENSITIVE => 0 );
3933 'Users' => $Users, # loc_left_pair
3941 =head2 _load_container_object ( $type, $id );
3943 Instantiate container object for saving searches.
3947 sub _load_container_object {
3948 my ( $obj_type, $obj_id ) = @_;
3949 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3952 =head2 _parse_saved_search ( $arg );
3954 Given a serialization string for saved search, and returns the
3955 container object and the search id.
3959 sub _parse_saved_search {
3961 return unless $spec;
3962 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3969 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3972 =head2 ScrubHTML content
3974 Removes unsafe and undesired HTML from the passed content
3980 my $Content = shift;
3981 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3983 $Content = '' if !defined($Content);
3984 return $SCRUBBER->scrub($Content);
3989 Returns a new L<HTML::Scrubber> object.
3991 If you need to be more lax about what HTML tags and attributes are allowed,
3992 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3995 package HTML::Mason::Commands;
3996 # Let tables through
3997 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
4002 our @SCRUBBER_ALLOWED_TAGS = qw(
4003 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP S DEL STRIKE H1 H2 H3 H4 H5
4004 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
4007 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
4008 # Match http, https, ftp, mailto and relative urls
4009 # XXX: we also scrub format strings with this module then allow simple config options
4010 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|HomePath|BaseURL|URL)__)}i,
4017 (?:(?:background-)?color: \s*
4018 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
4019 \#[a-f0-9]{3,6} | # #fff or #ffffff
4020 [\w\-]+ # green, light-blue, etc.
4022 text-align: \s* \w+ |
4023 font-size: \s* [\w.\-]+ |
4024 font-family: \s* [\w\s"',.\-]+ |
4025 font-weight: \s* [\w\-]+ |
4027 border-style: \s* \w+ |
4028 border-color: \s* [#\w]+ |
4029 border-width: \s* [\s\w]+ |
4030 padding: \s* [\s\w]+ |
4031 margin: \s* [\s\w]+ |
4033 # MS Office styles, which are probably fine. If we don't, then any
4034 # associated styles in the same attribute get stripped.
4035 mso-[\w\-]+?: \s* [\w\s"',.\-]+
4037 +$ # one or more of these allowed properties from here 'till sunset
4039 dir => qr/^(rtl|ltr)$/i,
4040 lang => qr/^\w+(-\w+)?$/,
4043 our %SCRUBBER_RULES = ();
4045 # If we're displaying images, let embedded ones through
4046 if (RT->Config->Get('ShowTransactionImages') or RT->Config->Get('ShowRemoteImages')) {
4047 $SCRUBBER_RULES{'img'} = {
4053 push @src, qr/^cid:/i
4054 if RT->Config->Get('ShowTransactionImages');
4056 push @src, $SCRUBBER_ALLOWED_ATTRIBUTES{'href'}
4057 if RT->Config->Get('ShowRemoteImages');
4059 $SCRUBBER_RULES{'img'}->{'src'} = join "|", @src;
4063 require HTML::Scrubber;
4064 my $scrubber = HTML::Scrubber->new();
4066 if (HTML::Gumbo->require) {
4067 no warnings 'redefine';
4068 my $orig = \&HTML::Scrubber::scrub;
4069 *HTML::Scrubber::scrub = sub {
4072 eval { $_[0] = HTML::Gumbo->new->parse( $_[0] ); chomp $_[0] };
4073 warn "HTML::Gumbo pre-parse failed: $@" if $@;
4074 return $orig->($self, @_);
4076 push @SCRUBBER_ALLOWED_TAGS, qw/TABLE THEAD TBODY TFOOT TR TD TH/;
4077 $SCRUBBER_ALLOWED_ATTRIBUTES{$_} = 1 for
4078 qw/colspan rowspan align valign cellspacing cellpadding border width height/;
4084 %SCRUBBER_ALLOWED_ATTRIBUTES,
4085 '*' => 0, # require attributes be explicitly allowed
4088 $scrubber->deny(qw[*]);
4089 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
4090 $scrubber->rules(%SCRUBBER_RULES);
4092 # Scrubbing comments is vital since IE conditional comments can contain
4093 # arbitrary HTML and we'd pass it right on through.
4094 $scrubber->comment(0);
4101 Redispatches to L<RT::Interface::Web/EncodeJSON>
4106 RT::Interface::Web::EncodeJSON(@_);
4111 return '' unless defined $value;
4112 $value =~ s/[^A-Za-z0-9_-]/_/g;
4116 sub GetCustomFieldInputName {
4117 RT::Interface::Web::GetCustomFieldInputName(@_);
4120 sub GetCustomFieldInputNamePrefix {
4121 RT::Interface::Web::GetCustomFieldInputNamePrefix(@_);
4124 package RT::Interface::Web;
4125 RT::Base->_ImportOverlays();