1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2017 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('RestrictLoginReferrer');
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('WebBaseURL') . 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 # skip if we have no object to update
3103 next unless $id || $Object->id;
3105 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
3106 unless ( $Object->id ) {
3107 $RT::Logger->warning("Couldn't load object $class #$id");
3111 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
3112 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
3113 $CustomFieldObj->SetContextObject($Object);
3114 $CustomFieldObj->LoadById($cf);
3115 unless ( $CustomFieldObj->id ) {
3116 $RT::Logger->warning("Couldn't load custom field #$cf");
3119 my @groupings = sort keys %{ $custom_fields_to_mod{$class}{$id}{$cf} };
3120 if (@groupings > 1) {
3121 # Check for consistency, in case of JS fail
3122 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3123 my $base = $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]}{$key};
3124 $base = [ $base ] unless ref $base;
3125 for my $grouping (@groupings[1..$#groupings]) {
3126 my $other = $custom_fields_to_mod{$class}{$id}{$cf}{$grouping}{$key};
3127 $other = [ $other ] unless ref $other;
3128 warn "CF $cf submitted with multiple differing values"
3129 if grep {$_} List::MoreUtils::pairwise {
3130 no warnings qw(uninitialized);
3132 } @{$base}, @{$other};
3135 # We'll just be picking the 1st grouping in the hash, alphabetically
3138 _ProcessObjectCustomFieldUpdates(
3139 Prefix => GetCustomFieldInputNamePrefix(
3141 CustomField => $CustomFieldObj,
3142 Grouping => $groupings[0],
3145 CustomField => $CustomFieldObj,
3146 ARGS => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] },
3154 sub _ParseObjectCustomFieldArgs {
3155 my $ARGSRef = shift || {};
3157 IncludeBulkUpdate => 0,
3160 my %custom_fields_to_mod;
3162 foreach my $arg ( keys %$ARGSRef ) {
3164 # format: Object-<object class>-<object id>-CustomField[:<grouping>]-<CF id>-<commands>
3165 # you can use GetCustomFieldInputName to generate the complement input name
3166 # or if IncludeBulkUpdate: Bulk-<Add or Delete>-CustomField[:<grouping>]-<CF id>-<commands>
3167 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField(?::(\w+))?-(\d+)-(.*)$/
3168 || ($args{IncludeBulkUpdate} && $arg =~ /^Bulk-(?:Add|Delete)-()()CustomField(?::(\w+))?-(\d+)-(.*)$/);
3169 # need two empty groups because we must consume $1 and $2 with empty
3172 next if $1 eq 'RT::Transaction';# don't try to update transaction fields
3174 # For each of those objects, find out what custom fields we want to work with.
3175 # Class ID CF grouping command
3176 $custom_fields_to_mod{$1}{ $2 || 0 }{$4}{$3 || ''}{$5} = $ARGSRef->{$arg};
3179 return wantarray ? %custom_fields_to_mod : \%custom_fields_to_mod;
3182 sub _ProcessObjectCustomFieldUpdates {
3184 my $cf = $args{'CustomField'};
3185 my $cf_type = $cf->Type || '';
3187 # Remove blank Values since the magic field will take care of this. Sometimes
3188 # the browser gives you a blank value which causes CFs to be processed twice
3189 if ( defined $args{'ARGS'}->{'Values'}
3190 && !length $args{'ARGS'}->{'Values'}
3191 && ($args{'ARGS'}->{'Values-Magic'}) )
3193 delete $args{'ARGS'}->{'Values'};
3197 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
3199 # skip category argument
3200 next if $arg =~ /-Category$/;
3203 next if $arg eq 'Value-TimeUnits';
3205 # since http won't pass in a form element with a null value, we need
3207 if ( $arg =~ /-Magic$/ ) {
3209 # We don't care about the magic, if there's really a values element;
3210 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
3211 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
3213 # "Empty" values does not mean anything for Image and Binary fields
3214 next if $cf_type =~ /^(?:Image|Binary)$/;
3217 $args{'ARGS'}->{'Values'} = undef;
3220 my @values = _NormalizeObjectCustomFieldValue(
3222 Param => $args{'Prefix'} . $arg,
3223 Value => $args{'ARGS'}->{$arg}
3226 # "Empty" values still don't mean anything for Image and Binary fields
3227 next if $cf_type =~ /^(?:Image|Binary)$/ and not @values;
3229 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
3230 foreach my $value (@values) {
3231 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3235 push( @results, $msg );
3237 } elsif ( $arg eq 'Upload' ) {
3238 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %{$values[0]}, Field => $cf, );
3239 push( @results, $msg );
3240 } elsif ( $arg eq 'DeleteValues' ) {
3241 foreach my $value (@values) {
3242 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3246 push( @results, $msg );
3248 } elsif ( $arg eq 'DeleteValueIds' ) {
3249 foreach my $value (@values) {
3250 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3254 push( @results, $msg );
3256 } elsif ( $arg eq 'Values' ) {
3257 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
3260 foreach my $value (@values) {
3261 if ( my $entry = $cf_values->HasEntry($value) ) {
3262 $values_hash{ $entry->id } = 1;
3266 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3270 push( @results, $msg );
3271 $values_hash{$val} = 1 if $val;
3274 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3275 return @results if ( $cf->Type eq 'Date' && ! @values );
3277 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3278 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
3280 $cf_values->RedoSearch;
3281 while ( my $cf_value = $cf_values->Next ) {
3282 next if $values_hash{ $cf_value->id };
3284 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3286 ValueId => $cf_value->id
3288 push( @results, $msg );
3293 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
3294 $cf->Name, ref $args{'Object'},
3303 sub ProcessObjectCustomFieldUpdatesForCreate {
3306 ContextObject => undef,
3309 my $context = $args{'ContextObject'};
3311 my %custom_fields = _ParseObjectCustomFieldArgs( $args{'ARGSRef'} );
3313 for my $class (keys %custom_fields) {
3314 # we're only interested in new objects, so only look at $id == 0
3315 for my $cfid (keys %{ $custom_fields{$class}{0} || {} }) {
3316 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3318 my $system_cf = RT::CustomField->new( RT->SystemUser );
3319 $system_cf->LoadById($cfid);
3320 if ($system_cf->ValidateContextObject($context)) {
3321 $cf->SetContextObject($context);
3324 sprintf "Invalid context object %s (%d) for CF %d; skipping CF",
3325 ref $context, $context->id, $system_cf->id
3330 $cf->LoadById($cfid);
3333 RT->Logger->warning("Couldn't load custom field #$cfid");
3337 my @groupings = sort keys %{ $custom_fields{$class}{0}{$cfid} };
3338 if (@groupings > 1) {
3339 # Check for consistency, in case of JS fail
3340 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3341 warn "CF $cfid submitted with multiple differing $key"
3342 if grep {($custom_fields{$class}{0}{$cfid}{$_}{$key} || '')
3343 ne ($custom_fields{$class}{0}{$cfid}{$groupings[0]}{$key} || '')}
3346 # We'll just be picking the 1st grouping in the hash, alphabetically
3350 my $name_prefix = GetCustomFieldInputNamePrefix(
3352 Grouping => $groupings[0],
3354 while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) {
3355 # Values-Magic doesn't matter on create; no previous values are being removed
3356 # Category is irrelevant for the actual value
3357 next if $arg =~ /-Magic$/ or $arg =~ /-Category$/;
3360 _NormalizeObjectCustomFieldValue(
3362 Param => $name_prefix . $arg,
3367 $parsed{"CustomField-$cfid"} = \@values if @values;
3371 return wantarray ? %parsed : \%parsed;
3374 sub _NormalizeObjectCustomFieldValue {
3379 my $cf_type = $args{CustomField}->Type;
3382 if ( ref $args{'Value'} eq 'ARRAY' ) {
3383 @values = @{ $args{'Value'} };
3384 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
3385 @values = ( $args{'Value'} );
3387 @values = split /\r*\n/, $args{'Value'}
3388 if defined $args{'Value'};
3390 @values = grep length, map {
3396 grep defined, @values;
3398 if ($args{'Param'} =~ /-Upload$/ and $cf_type =~ /^(Image|Binary)$/) {
3399 @values = _UploadedFile( $args{'Param'} ) || ();
3405 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3407 Returns an array of results messages.
3411 sub ProcessTicketWatchers {
3419 my $Ticket = $args{'TicketObj'};
3420 my $ARGSRef = $args{'ARGSRef'};
3424 foreach my $key ( keys %$ARGSRef ) {
3426 # Delete deletable watchers
3427 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
3428 my ( $code, $msg ) = $Ticket->DeleteWatcher(
3432 push @results, $msg;
3435 # Delete watchers in the simple style demanded by the bulk manipulator
3436 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
3437 my ( $code, $msg ) = $Ticket->DeleteWatcher(
3438 Email => $ARGSRef->{$key},
3441 push @results, $msg;
3444 # Add new wathchers by email address
3445 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
3446 and $key =~ /^WatcherTypeEmail(\d*)$/ )
3449 #They're in this order because otherwise $1 gets clobbered :/
3450 my ( $code, $msg ) = $Ticket->AddWatcher(
3451 Type => $ARGSRef->{$key},
3452 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
3454 push @results, $msg;
3457 #Add requestors in the simple style demanded by the bulk manipulator
3458 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
3459 my ( $code, $msg ) = $Ticket->AddWatcher(
3461 Email => $ARGSRef->{$key}
3463 push @results, $msg;
3466 # Add new watchers by owner
3467 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
3468 my $principal_id = $1;
3469 my $form = $ARGSRef->{$key};
3470 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
3471 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
3473 my ( $code, $msg ) = $Ticket->AddWatcher(
3475 PrincipalId => $principal_id
3477 push @results, $msg;
3487 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3489 Returns an array of results messages.
3493 sub ProcessTicketDates {
3500 my $Ticket = $args{'TicketObj'};
3501 my $ARGSRef = $args{'ARGSRef'};
3506 my @date_fields = qw(
3514 #Run through each field in this list. update the value if apropriate
3515 foreach my $field (@date_fields) {
3516 next unless exists $ARGSRef->{ $field . '_Date' };
3517 next if $ARGSRef->{ $field . '_Date' } eq '';
3521 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3523 Format => 'unknown',
3524 Value => $ARGSRef->{ $field . '_Date' }
3527 my $obj = $field . "Obj";
3528 if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) {
3529 my $method = "Set$field";
3530 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3531 push @results, "$msg";
3541 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3543 Returns an array of results messages.
3547 sub ProcessTicketLinks {
3555 my $Ticket = $args{'TicketObj'};
3556 my $TicketId = $args{'TicketId'} || $Ticket->Id;
3557 my $ARGSRef = $args{'ARGSRef'};
3559 my (@results) = ProcessRecordLinks(
3560 %args, RecordObj => $Ticket, RecordId => $TicketId, ARGSRef => $ARGSRef,
3563 #Merge if we need to
3564 my $input = $TicketId .'-MergeInto';
3565 if ( $ARGSRef->{ $input } ) {
3566 $ARGSRef->{ $input } =~ s/\s+//g;
3567 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $input } );
3568 push @results, $msg;
3575 sub ProcessRecordLinks {
3583 my $Record = $args{'RecordObj'};
3584 my $RecordId = $args{'RecordId'} || $Record->Id;
3585 my $ARGSRef = $args{'ARGSRef'};
3589 # Delete links that are gone gone gone.
3590 foreach my $arg ( keys %$ARGSRef ) {
3591 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3596 my ( $val, $msg ) = $Record->DeleteLink(
3602 push @results, $msg;
3608 my @linktypes = qw( DependsOn MemberOf RefersTo );
3610 foreach my $linktype (@linktypes) {
3611 my $input = $RecordId .'-'. $linktype;
3612 if ( $ARGSRef->{ $input } ) {
3613 $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3614 if ref $ARGSRef->{ $input };
3616 for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3618 $luri =~ s/\s+$//; # Strip trailing whitespace
3619 my ( $val, $msg ) = $Record->AddLink(
3623 push @results, $msg;
3626 $input = $linktype .'-'. $RecordId;
3627 if ( $ARGSRef->{ $input } ) {
3628 $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3629 if ref $ARGSRef->{ $input };
3631 for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3633 my ( $val, $msg ) = $Record->AddLink(
3638 push @results, $msg;
3646 =head2 ProcessLinksForCreate
3648 Takes a hash with a single key, C<ARGSRef>, the value of which is a hashref to
3651 Converts and returns submitted args in the form of C<new-LINKTYPE> and
3652 C<LINKTYPE-new> into their appropriate directional link types. For example,
3653 C<new-DependsOn> becomes C<DependsOn> and C<DependsOn-new> becomes
3654 C<DependedOnBy>. The incoming arg values are split on whitespace and
3655 normalized into arrayrefs before being returned.
3657 Primarily used by object creation pages for transforming incoming form inputs
3658 from F</Elements/EditLinks> into arguments appropriate for individual record
3661 Returns a hashref in scalar context and a hash in list context.
3665 sub ProcessLinksForCreate {
3669 foreach my $type ( keys %RT::Link::DIRMAP ) {
3670 for ([Base => "new-$type"], [Target => "$type-new"]) {
3671 my ($direction, $key) = @$_;
3672 next unless $args{ARGSRef}->{$key};
3673 $links{ $RT::Link::DIRMAP{$type}->{$direction} } = [
3674 grep $_, split ' ', $args{ARGSRef}->{$key}
3678 return wantarray ? %links : \%links;
3681 =head2 ProcessTransactionSquelching
3683 Takes a hashref of the submitted form arguments, C<%ARGS>.
3685 Returns a hash of squelched addresses.
3689 sub ProcessTransactionSquelching {
3691 my %checked = map { $_ => 1 } grep { defined }
3692 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3693 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3695 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3699 sub ProcessRecordBulkCustomFields {
3700 my %args = (RecordObj => undef, ARGSRef => {}, @_);
3702 my $ARGSRef = $args{'ARGSRef'};
3707 foreach my $key ( keys %$ARGSRef ) {
3708 next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/;
3709 my ($op, $cfid, $rest) = ($1, $2, $3);
3710 next if $rest =~ /-Category$/;
3712 my $res = $data{$cfid} ||= {};
3713 unless (keys %$res) {
3714 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3716 next unless $cf->Id;
3721 if ( $op eq 'Delete' && $rest eq 'AllValues' ) {
3722 $res->{'DeleteAll'} = $ARGSRef->{$key};
3726 my @values = _NormalizeObjectCustomFieldValue(
3727 CustomField => $res->{'cf'},
3728 Value => $ARGSRef->{$key},
3731 next unless @values;
3732 $res->{$op} = \@values;
3735 while ( my ($cfid, $data) = each %data ) {
3736 my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid );
3738 # just add one value for fields with single value
3739 if ( $data->{'Add'} && $data->{'cf'}->MaxValues == 1 ) {
3740 next if $current_values->HasEntry($data->{Add}[-1]);
3742 my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3744 Value => $data->{'Add'}[-1],
3746 push @results, $msg;
3750 if ( $data->{'DeleteAll'} ) {
3751 while ( my $value = $current_values->Next ) {
3752 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3754 ValueId => $value->id,
3756 push @results, $msg;
3759 foreach my $value ( @{ $data->{'Delete'} || [] } ) {
3760 my $entry = $current_values->HasEntry($value);
3763 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3765 ValueId => $entry->id,
3767 push @results, $msg;
3769 foreach my $value ( @{ $data->{'Add'} || [] } ) {
3770 next if $current_values->HasEntry($value);
3772 my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3776 push @results, $msg;
3782 =head2 _UploadedFile ( $arg );
3784 Takes a CGI parameter name; if a file is uploaded under that name,
3785 return a hash reference suitable for AddCustomFieldValue's use:
3786 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3788 Returns C<undef> if no files were uploaded in the C<$arg> field.
3794 my $cgi_object = $m->cgi_object;
3795 my $fh = $cgi_object->upload($arg) or return undef;
3796 my $upload_info = $cgi_object->uploadInfo($fh);
3798 my $filename = "$fh";
3799 $filename =~ s#^.*[\\/]##;
3804 LargeContent => do { local $/; scalar <$fh> },
3805 ContentType => $upload_info->{'Content-Type'},
3809 sub GetColumnMapEntry {
3810 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3812 # deal with the simplest thing first
3813 if ( $args{'Map'}{ $args{'Name'} } ) {
3814 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3818 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3819 $subkey =~ s/^\{(.*)\}$/$1/;
3820 return undef unless $args{'Map'}->{$mainkey};
3821 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3822 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3824 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3829 sub ProcessColumnMapValue {
3831 my %args = ( Arguments => [], Escape => 1, @_ );
3834 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3835 my @tmp = $value->( @{ $args{'Arguments'} } );
3836 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3837 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3838 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3839 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3843 if ($args{'Escape'}) {
3844 $value = $m->interp->apply_escapes( $value, 'h' );
3845 $value =~ s/\n/<br>/g if defined $value;
3851 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3853 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3854 principal collections mapped from the categories given.
3858 sub GetPrincipalsMap {
3863 my $system = RT::Groups->new($session{'CurrentUser'});
3864 $system->LimitToSystemInternalGroups();
3865 $system->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3867 'System' => $system, # loc_left_pair
3872 my $groups = RT::Groups->new($session{'CurrentUser'});
3873 $groups->LimitToUserDefinedGroups();
3874 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3876 # Only show groups who have rights granted on this object
3877 $groups->WithGroupRight(
3880 IncludeSystemRights => 0,
3881 IncludeSubgroupMembers => 0,
3885 'User Groups' => $groups, # loc_left_pair
3890 my $roles = RT::Groups->new($session{'CurrentUser'});
3892 if ($object->isa("RT::CustomField")) {
3893 # If we're a custom field, show the global roles for our LookupType.
3894 my $class = $object->RecordClassFromLookupType;
3895 if ($class and $class->DOES("RT::Record::Role::Roles")) {
3896 $roles->LimitToRolesForObject(RT->System);
3899 FUNCTION => 'LOWER(?)',
3901 VALUE => [ map {lc $_} $class->Roles ],
3905 # No roles to show; so show nothing
3909 $roles->LimitToRolesForObject($object);
3913 $roles->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3915 'Roles' => $roles, # loc_left_pair
3921 my $Users = RT->PrivilegedUsers->UserMembersObj();
3922 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3924 # Only show users who have rights granted on this object
3925 my $group_members = $Users->WhoHaveGroupRight(
3928 IncludeSystemRights => 0,
3929 IncludeSubgroupMembers => 0,
3932 # Limit to UserEquiv groups
3933 my $groups = $Users->Join(
3934 ALIAS1 => $group_members,
3935 FIELD1 => 'GroupId',
3939 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence', CASESENSITIVE => 0 );
3940 $Users->Limit( ALIAS => $groups, FIELD => 'Name', VALUE => 'UserEquiv', CASESENSITIVE => 0 );
3943 'Users' => $Users, # loc_left_pair
3951 =head2 _load_container_object ( $type, $id );
3953 Instantiate container object for saving searches.
3957 sub _load_container_object {
3958 my ( $obj_type, $obj_id ) = @_;
3959 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3962 =head2 _parse_saved_search ( $arg );
3964 Given a serialization string for saved search, and returns the
3965 container object and the search id.
3969 sub _parse_saved_search {
3971 return unless $spec;
3972 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3979 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3982 =head2 ScrubHTML content
3984 Removes unsafe and undesired HTML from the passed content
3990 my $Content = shift;
3991 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3993 $Content = '' if !defined($Content);
3994 return $SCRUBBER->scrub($Content);
3999 Returns a new L<HTML::Scrubber> object.
4001 If you need to be more lax about what HTML tags and attributes are allowed,
4002 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
4005 package HTML::Mason::Commands;
4006 # Let tables through
4007 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
4012 our @SCRUBBER_ALLOWED_TAGS = qw(
4013 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP S DEL STRIKE H1 H2 H3 H4 H5
4014 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
4017 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
4018 # Match http, https, ftp, mailto and relative urls
4019 # XXX: we also scrub format strings with this module then allow simple config options
4020 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|HomePath|BaseURL|URL)__)}i,
4027 (?:(?:background-)?color: \s*
4028 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
4029 \#[a-f0-9]{3,6} | # #fff or #ffffff
4030 [\w\-]+ # green, light-blue, etc.
4032 text-align: \s* \w+ |
4033 font-size: \s* [\w.\-]+ |
4034 font-family: \s* [\w\s"',.\-]+ |
4035 font-weight: \s* [\w\-]+ |
4037 border-style: \s* \w+ |
4038 border-color: \s* [#\w]+ |
4039 border-width: \s* [\s\w]+ |
4040 padding: \s* [\s\w]+ |
4041 margin: \s* [\s\w]+ |
4043 # MS Office styles, which are probably fine. If we don't, then any
4044 # associated styles in the same attribute get stripped.
4045 mso-[\w\-]+?: \s* [\w\s"',.\-]+
4047 +$ # one or more of these allowed properties from here 'till sunset
4049 dir => qr/^(rtl|ltr)$/i,
4050 lang => qr/^\w+(-\w+)?$/,
4053 our %SCRUBBER_RULES = ();
4055 # If we're displaying images, let embedded ones through
4056 if (RT->Config->Get('ShowTransactionImages') or RT->Config->Get('ShowRemoteImages')) {
4057 $SCRUBBER_RULES{'img'} = {
4063 push @src, qr/^cid:/i
4064 if RT->Config->Get('ShowTransactionImages');
4066 push @src, $SCRUBBER_ALLOWED_ATTRIBUTES{'href'}
4067 if RT->Config->Get('ShowRemoteImages');
4069 $SCRUBBER_RULES{'img'}->{'src'} = join "|", @src;
4073 require HTML::Scrubber;
4074 my $scrubber = HTML::Scrubber->new();
4076 if (HTML::Gumbo->require) {
4077 no warnings 'redefine';
4078 my $orig = \&HTML::Scrubber::scrub;
4079 *HTML::Scrubber::scrub = sub {
4082 eval { $_[0] = HTML::Gumbo->new->parse( $_[0] ); chomp $_[0] };
4083 warn "HTML::Gumbo pre-parse failed: $@" if $@;
4084 return $orig->($self, @_);
4086 push @SCRUBBER_ALLOWED_TAGS, qw/TABLE THEAD TBODY TFOOT TR TD TH/;
4087 $SCRUBBER_ALLOWED_ATTRIBUTES{$_} = 1 for
4088 qw/colspan rowspan align valign cellspacing cellpadding border width height/;
4094 %SCRUBBER_ALLOWED_ATTRIBUTES,
4095 '*' => 0, # require attributes be explicitly allowed
4098 $scrubber->deny(qw[*]);
4099 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
4100 $scrubber->rules(%SCRUBBER_RULES);
4102 # Scrubbing comments is vital since IE conditional comments can contain
4103 # arbitrary HTML and we'd pass it right on through.
4104 $scrubber->comment(0);
4111 Redispatches to L<RT::Interface::Web/EncodeJSON>
4116 RT::Interface::Web::EncodeJSON(@_);
4121 return '' unless defined $value;
4122 $value =~ s/[^A-Za-z0-9_-]/_/g;
4126 sub GetCustomFieldInputName {
4127 RT::Interface::Web::GetCustomFieldInputName(@_);
4130 sub GetCustomFieldInputNamePrefix {
4131 RT::Interface::Web::GetCustomFieldInputNamePrefix(@_);
4134 package RT::Interface::Web;
4135 RT::Base->_ImportOverlays();