1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2012 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;
72 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();
105 Removes the cached CSS and JS entries, forcing them to be regenerated
115 =head2 EscapeUTF8 SCALARREF
117 does a css-busting but minimalist escaping of whatever html you're passing in.
123 return unless defined $$ref;
125 $$ref =~ s/&/&/g;
128 $$ref =~ s/\(/(/g;
129 $$ref =~ s/\)/)/g;
130 $$ref =~ s/"/"/g;
131 $$ref =~ s/'/'/g;
136 =head2 EscapeURI SCALARREF
138 Escapes URI component according to RFC2396
144 return unless defined $$ref;
147 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
150 =head2 EncodeJSON SCALAR
152 Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple
153 value or a reference.
158 JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 });
161 sub _encode_surrogates {
162 my $uni = $_[0] - 0x10000;
163 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
168 return unless defined $$ref;
170 $$ref = "'" . join('',
172 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
173 $_ <= 255 ? sprintf("\\x%02X", $_) :
174 $_ <= 65535 ? sprintf("\\u%04X", $_) :
175 sprintf("\\u%X\\u%X", _encode_surrogates($_))
176 } unpack('U*', $$ref))
180 =head2 WebCanonicalizeInfo();
182 Different web servers set different environmental varibles. This
183 function must return something suitable for REMOTE_USER. By default,
184 just downcase $ENV{'REMOTE_USER'}
188 sub WebCanonicalizeInfo {
189 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
194 =head2 WebExternalAutoInfo($user);
196 Returns a hash of user attributes, used when WebExternalAuto is set.
200 sub WebExternalAutoInfo {
205 # default to making Privileged users, even if they specify
206 # some other default Attributes
207 if ( !$RT::AutoCreate
208 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
210 $user_info{'Privileged'} = 1;
213 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
215 # Populate fields with information from Unix /etc/passwd
217 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
218 $user_info{'Comments'} = $comments if defined $comments;
219 $user_info{'RealName'} = $realname if defined $realname;
220 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
222 # Populate fields with information from NT domain controller
225 # and return the wad of stuff
233 if (RT->Config->Get('DevelMode')) {
234 require Module::Refresh;
235 Module::Refresh->refresh;
238 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
240 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
242 # Roll back any dangling transactions from a previous failed connection
243 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
245 MaybeEnableSQLStatementLog();
247 # avoid reentrancy, as suggested by masonbook
248 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
250 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
251 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
256 local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
257 PreprocessTimeUpdates($ARGS);
260 MaybeShowInstallModePage();
262 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
265 if ( _UserLoggedIn() ) {
266 # make user info up to date
267 $HTML::Mason::Commands::session{'CurrentUser'}
268 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
271 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
274 # Process session-related callbacks before any auth attempts
275 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
277 MaybeRejectPrivateComponentRequest();
279 MaybeShowNoAuthPage($ARGS);
281 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
283 _ForceLogout() unless _UserLoggedIn();
285 # Process per-page authentication callbacks
286 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
288 unless ( _UserLoggedIn() ) {
291 # Authenticate if the user is trying to login via user/pass query args
292 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
295 my $m = $HTML::Mason::Commands::m;
297 # REST urls get a special 401 response
298 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
299 $HTML::Mason::Commands::r->content_type("text/plain");
300 $m->error_format("text");
301 $m->out("RT/$RT::VERSION 401 Credentials required\n");
302 $m->out("\n$msg\n") if $msg;
305 # Specially handle /index.html so that we get a nicer URL
306 elsif ( $m->request_comp->path eq '/index.html' ) {
307 my $next = SetNextPage($ARGS);
308 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
312 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
317 MaybeShowInterstitialCSRFPage($ARGS);
319 # now it applies not only to home page, but any dashboard that can be used as a workspace
320 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
321 if ( $ARGS->{'HomeRefreshInterval'} );
323 # Process per-page global callbacks
324 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
326 ShowRequestedPage($ARGS);
327 LogRecordedSQLStatements(RequestData => {
328 Path => $HTML::Mason::Commands::m->request_comp->path,
331 # Process per-page final cleanup callbacks
332 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
334 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
335 unless $HTML::Mason::Commands::r->content_type
336 =~ qr<^(text|application)/(x-)?(css|javascript)>;
341 delete $HTML::Mason::Commands::session{'CurrentUser'};
345 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
353 =head2 LoginError ERROR
355 Pushes a login error into the Actions session store and returns the hash key.
361 my $key = Digest::MD5::md5_hex( rand(1024) );
362 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
363 $HTML::Mason::Commands::session{'i'}++;
367 =head2 SetNextPage ARGSRef [PATH]
369 Intuits and stashes the next page in the sesssion hash. If PATH is
370 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
377 my $next = $_[0] ? $_[0] : IntuitNextPage();
378 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
379 my $page = { url => $next };
381 # If an explicit URL was passed and we didn't IntuitNextPage, then
382 # IsPossibleCSRF below is almost certainly unrelated to the actual
383 # destination. Currently explicit next pages aren't used in RT, but the
385 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
386 # This isn't really CSRF, but the CSRF heuristics are useful for catching
387 # requests which may have unintended side-effects.
388 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
391 "Marking original destination as having side-effects before redirecting for login.\n"
393 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
395 $page->{'HasSideEffects'} = [$msg, @loc];
399 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
400 $HTML::Mason::Commands::session{'i'}++;
404 =head2 FetchNextPage HASHKEY
406 Returns the stashed next page hashref for the given hash.
411 my $hash = shift || "";
412 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
415 =head2 RemoveNextPage HASHKEY
417 Removes the stashed next page for the given hash and returns it.
422 my $hash = shift || "";
423 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
426 =head2 TangentForLogin ARGSRef [HASH]
428 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
429 the next page. Takes a hashref of request %ARGS as the first parameter.
430 Optionally takes all other parameters as a hash which is dumped into query
435 sub TangentForLogin {
437 my $hash = SetNextPage($ARGS);
438 my %query = (@_, next => $hash);
439 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
440 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
444 =head2 TangentForLoginWithError ERROR
446 Localizes the passed error message, stashes it with L<LoginError> and then
447 calls L<TangentForLogin> with the appropriate results key.
451 sub TangentForLoginWithError {
453 my $key = LoginError(HTML::Mason::Commands::loc(@_));
454 TangentForLogin( $ARGS, results => $key );
457 =head2 IntuitNextPage
459 Attempt to figure out the path to which we should return the user after a
460 tangent. The current request URL is used, or failing that, the C<WebURL>
461 configuration variable.
468 # This includes any query parameters. Redirect will take care of making
469 # it an absolute URL.
470 if ($ENV{'REQUEST_URI'}) {
471 $req_uri = $ENV{'REQUEST_URI'};
473 # collapse multiple leading slashes so the first part doesn't look like
474 # a hostname of a schema-less URI
475 $req_uri =~ s{^/+}{/};
478 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
481 my $uri = URI->new($next);
483 # You get undef scheme with a relative uri like "/Search/Build.html"
484 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
485 $next = RT->Config->Get('WebURL');
488 # Make sure we're logging in to the same domain
489 # You can get an undef authority with a relative uri like "index.html"
490 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
491 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
492 $next = RT->Config->Get('WebURL');
498 =head2 MaybeShowInstallModePage
500 This function, called exclusively by RT's autohandler, dispatches
501 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
503 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
507 sub MaybeShowInstallModePage {
508 return unless RT->InstallMode;
510 my $m = $HTML::Mason::Commands::m;
511 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
513 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
514 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
521 =head2 MaybeShowNoAuthPage \%ARGS
523 This function, called exclusively by RT's autohandler, dispatches
524 a request to the page a user requested (but only if it matches the "noauth" regex.
526 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
530 sub MaybeShowNoAuthPage {
533 my $m = $HTML::Mason::Commands::m;
535 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
537 # Don't show the login page to logged in users
538 Redirect(RT->Config->Get('WebURL'))
539 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
541 # If it's a noauth file, don't ask for auth.
542 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
546 =head2 MaybeRejectPrivateComponentRequest
548 This function will reject calls to private components, like those under
549 C</Elements>. If the requested path is a private component then we will
550 abort with a C<403> error.
554 sub MaybeRejectPrivateComponentRequest {
555 my $m = $HTML::Mason::Commands::m;
556 my $path = $m->request_comp->path;
558 # We do not check for dhandler here, because requesting our dhandlers
559 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
565 _elements | # mobile UI
567 autohandler | # requesting this directly is suspicious
568 l (_unsafe)? ) # loc component
569 ( $ | / ) # trailing slash or end of path
571 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
574 warn "rejecting private component $path\n";
582 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
583 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
584 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
589 =head2 ShowRequestedPage \%ARGS
591 This function, called exclusively by RT's autohandler, dispatches
592 a request to the page a user requested (making sure that unpriviled users
593 can only see self-service pages.
597 sub ShowRequestedPage {
600 my $m = $HTML::Mason::Commands::m;
602 # Ensure that the cookie that we send is up-to-date, in case the
603 # session-id has been modified in any way
606 # precache all system level rights for the current user
607 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
609 # If the user isn't privileged, they can only see SelfService
610 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
612 # if the user is trying to access a ticket, redirect them
613 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
614 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
617 # otherwise, drop the user at the SelfService default page
618 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
619 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
622 # if user is in SelfService dir let him do anything
624 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
627 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
632 sub AttemptExternalAuth {
635 return unless ( RT->Config->Get('WebExternalAuth') );
637 my $user = $ARGS->{user};
638 my $m = $HTML::Mason::Commands::m;
640 # If RT is configured for external auth, let's go through and get REMOTE_USER
642 # do we actually have a REMOTE_USER equivlent?
643 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
644 my $orig_user = $user;
646 $user = RT::Interface::Web::WebCanonicalizeInfo();
647 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
649 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
650 my $NodeName = Win32::NodeName();
651 $user =~ s/^\Q$NodeName\E\\//i;
654 my $next = RemoveNextPage($ARGS->{'next'});
655 $next = $next->{'url'} if ref $next;
656 InstantiateNewSession() unless _UserLoggedIn;
657 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
658 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
660 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
662 # Create users on-the-fly
663 my $UserObj = RT::User->new(RT->SystemUser);
664 my ( $val, $msg ) = $UserObj->Create(
665 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
672 # now get user specific information, to better create our user.
673 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
675 # set the attributes that have been defined.
676 foreach my $attribute ( $UserObj->WritableAttributes ) {
678 Attribute => $attribute,
680 UserInfo => $new_user_info,
681 CallbackName => 'NewUser',
682 CallbackPage => '/autohandler'
684 my $method = "Set$attribute";
685 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
687 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
690 # we failed to successfully create the user. abort abort abort.
691 delete $HTML::Mason::Commands::session{'CurrentUser'};
693 if (RT->Config->Get('WebFallbackToInternalAuth')) {
694 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
701 if ( _UserLoggedIn() ) {
702 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
703 # It is possible that we did a redirect to the login page,
704 # if the external auth allows lack of auth through with no
705 # REMOTE_USER set, instead of forcing a "permission
706 # denied" message. Honor the $next.
707 Redirect($next) if $next;
708 # Unlike AttemptPasswordAuthentication below, we do not
709 # force a redirect to / if $next is not set -- otherwise,
710 # straight-up external auth would always redirect to /
711 # when you first hit it.
713 delete $HTML::Mason::Commands::session{'CurrentUser'};
716 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
717 TangentForLoginWithError($ARGS, 'You are not an authorized user');
720 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
721 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
722 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
723 TangentForLoginWithError($ARGS, 'You are not an authorized user');
727 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
728 # XXX: we must return AUTH_REQUIRED status or we fallback to
729 # internal auth here too.
730 delete $HTML::Mason::Commands::session{'CurrentUser'}
731 if defined $HTML::Mason::Commands::session{'CurrentUser'};
735 sub AttemptPasswordAuthentication {
737 return unless defined $ARGS->{user} && defined $ARGS->{pass};
739 my $user_obj = RT::CurrentUser->new();
740 $user_obj->Load( $ARGS->{user} );
742 my $m = $HTML::Mason::Commands::m;
744 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
745 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
746 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
747 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
750 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
752 # It's important to nab the next page from the session before we blow
754 my $next = RemoveNextPage($ARGS->{'next'});
755 $next = $next->{'url'} if ref $next;
757 InstantiateNewSession();
758 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
760 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
762 # Really the only time we don't want to redirect here is if we were
763 # passed user and pass as query params in the URL.
767 elsif ($ARGS->{'next'}) {
768 # Invalid hash, but still wants to go somewhere, take them to /
769 Redirect(RT->Config->Get('WebURL'));
772 return (1, HTML::Mason::Commands::loc('Logged in'));
776 =head2 LoadSessionFromCookie
778 Load or setup a session cookie for the current user.
782 sub _SessionCookieName {
783 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
784 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
788 sub LoadSessionFromCookie {
790 my %cookies = CGI::Cookie->fetch;
791 my $cookiename = _SessionCookieName();
792 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
793 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
794 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
795 undef $cookies{$cookiename};
797 if ( int RT->Config->Get('AutoLogoff') ) {
798 my $now = int( time / 60 );
799 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
801 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
802 InstantiateNewSession();
805 # save session on each request when AutoLogoff is turned on
806 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
810 sub InstantiateNewSession {
811 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
812 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
816 sub SendSessionCookie {
817 my $cookie = CGI::Cookie->new(
818 -name => _SessionCookieName(),
819 -value => $HTML::Mason::Commands::session{_session_id},
820 -path => RT->Config->Get('WebPath'),
821 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
822 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
825 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
830 This routine ells the current user's browser to redirect to URL.
831 Additionally, it unties the user's currently active session, helping to avoid
832 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
833 a cached DBI statement handle twice at the same time.
838 my $redir_to = shift;
839 untie $HTML::Mason::Commands::session;
840 my $uri = URI->new($redir_to);
841 my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
843 # Make relative URIs absolute from the server host and scheme
844 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
845 if (not defined $uri->host) {
846 $uri->host($server_uri->host);
847 $uri->port($server_uri->port);
850 # If the user is coming in via a non-canonical
851 # hostname, don't redirect them to the canonical host,
852 # it will just upset them (and invalidate their credentials)
853 # don't do this if $RT::CanonicalizeRedirectURLs is true
854 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
855 && $uri->host eq $server_uri->host
856 && $uri->port eq $server_uri->port )
858 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
859 $uri->scheme('https');
861 $uri->scheme('http');
864 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
865 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
866 $uri->port( $ENV{'SERVER_PORT'} );
869 # not sure why, but on some systems without this call mason doesn't
870 # set status to 302, but 200 instead and people see blank pages
871 $HTML::Mason::Commands::r->status(302);
873 # Perlbal expects a status message, but Mason's default redirect status
874 # doesn't provide one. See also rt.cpan.org #36689.
875 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
877 $HTML::Mason::Commands::m->abort;
880 =head2 StaticFileHeaders
882 Send the browser a few headers to try to get it to (somewhat agressively)
883 cache RT's static Javascript and CSS files.
885 This routine could really use _accurate_ heuristics. (XXX TODO)
889 sub StaticFileHeaders {
890 my $date = RT::Date->new(RT->SystemUser);
893 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
895 # remove any cookie headers -- if it is cached publicly, it
896 # shouldn't include anyone's cookie!
897 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
899 # Expire things in a month.
900 $date->Set( Value => time + 30 * 24 * 60 * 60 );
901 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
903 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
904 # request, but we don't handle it and generate full reply again
905 # Last modified at server start time
906 # $date->Set( Value => $^T );
907 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
910 =head2 ComponentPathIsSafe PATH
912 Takes C<PATH> and returns a boolean indicating that the user-specified partial
913 component path is safe.
915 Currently "safe" means that the path does not start with a dot (C<.>) and does
916 not contain a slash-dot C</.>.
920 sub ComponentPathIsSafe {
923 return $path !~ m{(?:^|/)\.};
928 Takes a C<< Path => path >> and returns a boolean indicating that
929 the path is safely within RT's control or not. The path I<must> be
932 This function does not consult the filesystem at all; it is merely
933 a logical sanity checking of the path. This explicitly does not handle
934 symlinks; if you have symlinks in RT's webroot pointing outside of it,
935 then we assume you know what you are doing.
942 my $path = $args{Path};
944 # Get File::Spec to clean up extra /s, ./, etc
945 my $cleaned_up = File::Spec->canonpath($path);
947 if (!defined($cleaned_up)) {
948 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
952 # Forbid too many ..s. We can't just sum then check because
953 # "../foo/bar/baz" should be illegal even though it has more
954 # downdirs than updirs. So as soon as we get a negative score
955 # (which means "breaking out" of the top level) we reject the path.
957 my @components = split '/', $cleaned_up;
959 for my $component (@components) {
960 if ($component eq '..') {
963 $RT::Logger->info("Rejecting unsafe path: $path");
967 elsif ($component eq '.' || $component eq '') {
968 # these two have no effect on $score
978 =head2 SendStaticFile
980 Takes a File => path and a Type => Content-type
982 If Type isn't provided and File is an image, it will
983 figure out a sane Content-type, otherwise it will
984 send application/octet-stream
986 Will set caching headers using StaticFileHeaders
993 my $file = $args{File};
994 my $type = $args{Type};
995 my $relfile = $args{RelativeFile};
997 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
998 $HTML::Mason::Commands::r->status(400);
999 $HTML::Mason::Commands::m->abort;
1002 $self->StaticFileHeaders();
1005 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1007 $type =~ s/jpg/jpeg/gi;
1009 $type ||= "application/octet-stream";
1011 $HTML::Mason::Commands::r->content_type($type);
1012 open( my $fh, '<', $file ) or die "couldn't open file: $!";
1016 $HTML::Mason::Commands::m->out($_) while (<$fh>);
1017 $HTML::Mason::Commands::m->flush_buffer;
1028 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'}) {
1039 my $content = $args{Content};
1040 return '' unless $content;
1042 # Make the content have no 'weird' newlines in it
1043 $content =~ s/\r+\n/\n/g;
1045 my $return_content = $content;
1047 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1048 my $sigonly = $args{StripSignature};
1050 # massage content to easily detect if there's any real content
1051 $content =~ s/\s+//g; # yes! remove all the spaces
1053 # remove html version of spaces and newlines
1054 $content =~ s! !!g;
1055 $content =~ s!<br/?>!!g;
1058 # Filter empty content when type is text/html
1059 return '' if $html && $content !~ /\S/;
1061 # If we aren't supposed to strip the sig, just bail now.
1062 return $return_content unless $sigonly;
1064 # Find the signature
1065 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1068 # Check for plaintext sig
1069 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1071 # Check for html-formatted sig; we don't use EscapeUTF8 here
1072 # because we want to precisely match the escapting that FCKEditor
1074 $sig =~ s/&/&/g;
1077 $sig =~ s/"/"/g;
1078 $sig =~ s/'/'/g;
1079 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1082 return $return_content;
1090 # if they've passed multiple values, they'll be an array. if they've
1091 # passed just one, a scalar whatever they are, mark them as utf8
1094 ? Encode::is_utf8($_)
1096 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1097 : ( $type eq 'ARRAY' )
1098 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1100 : ( $type eq 'HASH' )
1101 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1107 sub PreprocessTimeUpdates {
1110 # Later in the code we use
1111 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1112 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1113 # The call_next method pass through original arguments and if you have
1114 # an argument with unicode key then in a next component you'll get two
1115 # records in the args hash: one with key without UTF8 flag and another
1116 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1117 # is copied from mason's source to get the same results as we get from
1118 # call_next method, this feature is not documented, so we just leave it
1119 # here to avoid possible side effects.
1121 # This code canonicalizes time inputs in hours into minutes
1122 foreach my $field ( keys %$ARGS ) {
1123 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1125 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1126 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1127 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1128 $ARGS->{$local} *= 60;
1130 delete $ARGS->{$field};
1135 sub MaybeEnableSQLStatementLog {
1137 my $log_sql_statements = RT->Config->Get('StatementLog');
1139 if ($log_sql_statements) {
1140 $RT::Handle->ClearSQLStatementLog;
1141 $RT::Handle->LogSQLStatements(1);
1146 sub LogRecordedSQLStatements {
1149 my $log_sql_statements = RT->Config->Get('StatementLog');
1151 return unless ($log_sql_statements);
1153 my @log = $RT::Handle->SQLStatementLog;
1154 $RT::Handle->ClearSQLStatementLog;
1156 $RT::Handle->AddRequestToHistory({
1157 %{ $args{RequestData} },
1161 for my $stmt (@log) {
1162 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1172 level => $log_sql_statements,
1174 . sprintf( "%.6f", $duration )
1176 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1182 my $_has_validated_web_config = 0;
1183 sub ValidateWebConfig {
1186 # do this once per server instance, not once per request
1187 return if $_has_validated_web_config;
1188 $_has_validated_web_config = 1;
1190 if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) {
1191 $RT::Logger->warn("The actual SERVER_PORT ($ENV{SERVER_PORT}) does NOT match the configured WebPort ($RT::WebPort). Perhaps you should Set(\$WebPort, $ENV{SERVER_PORT}); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1194 if ($ENV{HTTP_HOST}) {
1195 # match "example.com" or "example.com:80"
1196 my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/;
1198 if ($host ne RT->Config->Get('WebDomain')) {
1199 $RT::Logger->warn("The actual HTTP_HOST ($host) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1203 if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) {
1204 $RT::Logger->warn("The actual SERVER_NAME ($ENV{SERVER_NAME}) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$ENV{SERVER_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1208 #i don't understand how this was ever expected to work
1209 # (even without our dum double // hack)??
1210 #if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) {
1211 ( my $WebPath = RT->Config->Get('WebPath') ) =~ s(/+)(/)g;
1212 ( my $script_name = $ENV{SCRIPT_NAME} ) =~ s(/+)(/)g;
1213 my $script_name_prefix = substr($script_name, 0, length($WebPath));
1214 if ( $script_name_prefix ne $WebPath ) {
1215 $RT::Logger->warn("The actual SCRIPT_NAME ($script_name) does NOT match the configured WebPath ($WebPath). Perhaps you should Set(\$WebPath, '$script_name_prefix'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1219 sub ComponentRoots {
1221 my %args = ( Names => 0, @_ );
1223 if (defined $HTML::Mason::Commands::m) {
1224 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1227 [ local => $RT::MasonLocalComponentRoot ],
1228 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1229 [ standard => $RT::MasonComponentRoot ]
1232 @roots = map { $_->[1] } @roots unless $args{Names};
1236 our %is_whitelisted_component = (
1237 # The RSS feed embeds an auth token in the path, but query
1238 # information for the search. Because it's a straight-up read, in
1239 # addition to embedding its own auth, it's fine.
1240 '/NoAuth/rss/dhandler' => 1,
1242 # While these can be used for denial-of-service against RT
1243 # (construct a very inefficient query and trick lots of users into
1244 # running them against RT) it's incredibly useful to be able to link
1245 # to a search result or bookmark a result page.
1246 '/Search/Results.html' => 1,
1247 '/Search/Simple.html' => 1,
1248 '/m/tickets/search' => 1,
1251 # Components which are blacklisted from automatic, argument-based whitelisting.
1252 # These pages are not idempotent when called with just an id.
1253 our %is_blacklisted_component = (
1254 # Takes only id and toggles bookmark state
1255 '/Helpers/Toggle/TicketBookmark' => 1,
1258 sub IsCompCSRFWhitelisted {
1262 return 1 if $is_whitelisted_component{$comp};
1264 my %args = %{ $ARGS };
1266 # If the user specifies a *correct* user and pass then they are
1267 # golden. This acts on the presumption that external forms may
1268 # hardcode a username and password -- if a malicious attacker knew
1269 # both already, CSRF is the least of your problems.
1270 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1271 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1272 my $user_obj = RT::CurrentUser->new();
1273 $user_obj->Load($args{user});
1274 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1280 # Some pages aren't idempotent even with safe args like id; blacklist
1281 # them from the automatic whitelisting below.
1282 return 0 if $is_blacklisted_component{$comp};
1284 # Eliminate arguments that do not indicate an effectful request.
1285 # For example, "id" is acceptable because that is how RT retrieves a
1289 # If they have a valid results= from MaybeRedirectForResults, that's
1291 delete $args{results} if $args{results}
1292 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1294 # The homepage refresh, which uses the Refresh header, doesn't send
1295 # a referer in most browsers; whitelist the one parameter it reloads
1296 # with, HomeRefreshInterval, which is safe
1297 delete $args{HomeRefreshInterval};
1299 # If there are no arguments, then it's likely to be an idempotent
1300 # request, which are not susceptible to CSRF
1306 sub IsRefererCSRFWhitelisted {
1307 my $referer = _NormalizeHost(shift);
1308 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1309 $base_url = $base_url->host_port;
1312 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1313 push @$configs,$config;
1315 my $host_port = $referer->host_port;
1316 if ($config =~ /\*/) {
1317 # Turn a literal * into a domain component or partial component match.
1318 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1319 my $regex = join "[a-zA-Z0-9\-]*",
1320 map { quotemeta($_) }
1321 split /\*/, $config;
1323 return 1 if $host_port =~ /^$regex$/i;
1325 return 1 if $host_port eq $config;
1329 return (0,$referer,$configs);
1332 =head3 _NormalizeHost
1334 Takes a URI and creates a URI object that's been normalized
1335 to handle common problems such as localhost vs 127.0.0.1
1339 sub _NormalizeHost {
1341 $s = "http://$s" unless $s =~ /^http/i;
1342 my $uri= URI->new($s);
1343 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1349 sub IsPossibleCSRF {
1352 # If first request on this session is to a REST endpoint, then
1353 # whitelist the REST endpoints -- and explicitly deny non-REST
1354 # endpoints. We do this because using a REST cookie in a browser
1355 # would open the user to CSRF attacks to the REST endpoints.
1356 my $path = $HTML::Mason::Commands::r->path_info;
1357 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1358 unless defined $HTML::Mason::Commands::session{'REST'};
1360 if ($HTML::Mason::Commands::session{'REST'}) {
1361 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1363 This login session belongs to a REST client, and cannot be used to
1364 access non-REST interfaces of RT for security reasons.
1366 my $details = <<EOT;
1367 Please log out and back in to obtain a session for normal browsing. If
1368 you understand the security implications, disabling RT's CSRF protection
1369 will remove this restriction.
1372 HTML::Mason::Commands::Abort( $why, Details => $details );
1375 return 0 if IsCompCSRFWhitelisted(
1376 $HTML::Mason::Commands::m->request_comp->path,
1380 # if there is no Referer header then assume the worst
1382 "your browser did not supply a Referrer header", # loc
1383 ) if !$ENV{HTTP_REFERER};
1385 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1386 return 0 if $whitelisted;
1388 if ( @$configs > 1 ) {
1390 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1391 $browser->host_port,
1393 join(', ', @$configs) );
1397 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1398 $browser->host_port,
1402 sub ExpandCSRFToken {
1405 my $token = delete $ARGS->{CSRF_Token};
1406 return unless $token;
1408 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1409 return unless $data;
1410 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1412 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1413 return unless $user->ValidateAuthString( $data->{auth}, $token );
1415 %{$ARGS} = %{$data->{args}};
1416 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1418 # We explicitly stored file attachments with the request, but not in
1419 # the session yet, as that would itself be an attack. Put them into
1420 # the session now, so they'll be visible.
1421 if ($data->{attach}) {
1422 my $filename = $data->{attach}{filename};
1423 my $mime = $data->{attach}{mime};
1424 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1431 sub StoreRequestToken {
1434 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1435 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1437 auth => $user->GenerateAuthString( $token ),
1438 path => $HTML::Mason::Commands::r->path_info,
1441 if ($ARGS->{Attach}) {
1442 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1443 my $file_path = delete $ARGS->{'Attach'};
1445 filename => Encode::decode_utf8("$file_path"),
1446 mime => $attachment,
1450 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1451 $HTML::Mason::Commands::session{'i'}++;
1455 sub MaybeShowInterstitialCSRFPage {
1458 return unless RT->Config->Get('RestrictReferrer');
1460 # Deal with the form token provided by the interstitial, which lets
1461 # browsers which never set referer headers still use RT, if
1462 # painfully. This blows values into ARGS
1463 return if ExpandCSRFToken($ARGS);
1465 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1466 return if !$is_csrf;
1468 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1470 my $token = StoreRequestToken($ARGS);
1471 $HTML::Mason::Commands::m->comp(
1473 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1474 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1477 # Calls abort, never gets here
1480 our @POTENTIAL_PAGE_ACTIONS = (
1481 qr'/Ticket/Create.html' => "create a ticket", # loc
1482 qr'/Ticket/' => "update a ticket", # loc
1483 qr'/Admin/' => "modify RT's configuration", # loc
1484 qr'/Approval/' => "update an approval", # loc
1485 qr'/Articles/' => "update an article", # loc
1486 qr'/Dashboards/' => "modify a dashboard", # loc
1487 qr'/m/ticket/' => "update a ticket", # loc
1488 qr'Prefs' => "modify your preferences", # loc
1489 qr'/Search/' => "modify or access a search", # loc
1490 qr'/SelfService/Create' => "create a ticket", # loc
1491 qr'/SelfService/' => "update a ticket", # loc
1494 sub PotentialPageAction {
1496 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1497 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1498 return HTML::Mason::Commands::loc($result)
1499 if $page =~ $pattern;
1504 package HTML::Mason::Commands;
1506 use vars qw/$r $m %session/;
1509 return $HTML::Mason::Commands::m->notes('menu');
1513 return $HTML::Mason::Commands::m->notes('page-menu');
1517 return $HTML::Mason::Commands::m->notes('page-widgets');
1524 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1525 with whatever it's called with. If there is no $session{'CurrentUser'},
1526 it creates a temporary user, so we have something to get a localisation handle
1533 if ( $session{'CurrentUser'}
1534 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1536 return ( $session{'CurrentUser'}->loc(@_) );
1539 RT::CurrentUser->new();
1543 return ( $u->loc(@_) );
1546 # pathetic case -- SystemUser is gone.
1553 =head2 loc_fuzzy STRING
1555 loc_fuzzy is for handling localizations of messages that may already
1556 contain interpolated variables, typically returned from libraries
1557 outside RT's control. It takes the message string and extracts the
1558 variable array automatically by matching against the candidate entries
1559 inside the lexicon file.
1566 if ( $session{'CurrentUser'}
1567 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1569 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1571 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1572 return ( $u->loc_fuzzy($msg) );
1577 # Error - calls Error and aborts
1582 if ( $session{'ErrorDocument'}
1583 && $session{'ErrorDocumentType'} )
1585 $r->content_type( $session{'ErrorDocumentType'} );
1586 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1589 $m->comp( "/Elements/Error", Why => $why, %args );
1594 sub MaybeRedirectForResults {
1596 Path => $HTML::Mason::Commands::m->request_comp->path,
1603 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1604 return unless $has_actions || $args{'Force'};
1606 my %arguments = %{ $args{'Arguments'} };
1608 if ( $has_actions ) {
1609 my $key = Digest::MD5::md5_hex( rand(1024) );
1610 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1612 $arguments{'results'} = $key;
1615 $args{'Path'} =~ s!^/+!!;
1616 my $url = RT->Config->Get('WebURL') . $args{Path};
1618 if ( keys %arguments ) {
1619 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1621 if ( $args{'Anchor'} ) {
1622 $url .= "#". $args{'Anchor'};
1624 return RT::Interface::Web::Redirect($url);
1627 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1629 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1630 redirect to the approvals display page, preserving any arguments.
1632 C<Path>s matching C<Whitelist> are let through.
1634 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1638 sub MaybeRedirectToApproval {
1640 Path => $HTML::Mason::Commands::m->request_comp->path,
1646 return unless $ENV{REQUEST_METHOD} eq 'GET';
1648 my $id = $args{ARGSRef}->{id};
1651 and RT->Config->Get('ForceApprovalsView')
1652 and not $args{Path} =~ /$args{Whitelist}/)
1654 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1657 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1658 MaybeRedirectForResults(
1659 Path => "/Approvals/Display.html",
1661 Anchor => $args{ARGSRef}->{Anchor},
1662 Arguments => $args{ARGSRef},
1668 =head2 CreateTicket ARGS
1670 Create a new ticket, using Mason's %ARGS. returns @results.
1679 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1681 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1682 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1683 Abort('Queue not found');
1686 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1687 Abort('You have no permission to create tickets in that queue.');
1691 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1692 $due = RT::Date->new( $session{'CurrentUser'} );
1693 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1696 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1697 $starts = RT::Date->new( $session{'CurrentUser'} );
1698 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1701 my $sigless = RT::Interface::Web::StripContent(
1702 Content => $ARGS{Content},
1703 ContentType => $ARGS{ContentType},
1704 StripSignature => 1,
1705 CurrentUser => $session{'CurrentUser'},
1708 my $MIMEObj = MakeMIMEEntity(
1709 Subject => $ARGS{'Subject'},
1710 From => $ARGS{'From'},
1713 Type => $ARGS{'ContentType'},
1716 if ( $ARGS{'Attachments'} ) {
1717 my $rv = $MIMEObj->make_multipart;
1718 $RT::Logger->error("Couldn't make multipart message")
1719 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1721 foreach ( values %{ $ARGS{'Attachments'} } ) {
1723 $RT::Logger->error("Couldn't add empty attachemnt");
1726 $MIMEObj->add_part($_);
1730 for my $argument (qw(Encrypt Sign)) {
1731 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1735 Type => $ARGS{'Type'} || 'ticket',
1736 Queue => $ARGS{'Queue'},
1737 Owner => $ARGS{'Owner'},
1740 Requestor => $ARGS{'Requestors'},
1742 AdminCc => $ARGS{'AdminCc'},
1743 InitialPriority => $ARGS{'InitialPriority'},
1744 FinalPriority => $ARGS{'FinalPriority'},
1745 TimeLeft => $ARGS{'TimeLeft'},
1746 TimeEstimated => $ARGS{'TimeEstimated'},
1747 TimeWorked => $ARGS{'TimeWorked'},
1748 Subject => $ARGS{'Subject'},
1749 Status => $ARGS{'Status'},
1750 Due => $due ? $due->ISO : undef,
1751 Starts => $starts ? $starts->ISO : undef,
1756 foreach my $type (qw(Requestor Cc AdminCc)) {
1757 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1758 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1760 $create_args{TransSquelchMailTo} = \@txn_squelch
1763 if ( $ARGS{'AttachTickets'} ) {
1764 require RT::Action::SendEmail;
1765 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1766 ref $ARGS{'AttachTickets'}
1767 ? @{ $ARGS{'AttachTickets'} }
1768 : ( $ARGS{'AttachTickets'} ) );
1771 foreach my $arg ( keys %ARGS ) {
1772 next if $arg =~ /-(?:Magic|Category)$/;
1774 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1775 $create_args{$arg} = $ARGS{$arg};
1778 # Object-RT::Ticket--CustomField-3-Values
1779 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1782 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1783 $cf->SetContextObject( $Queue );
1785 unless ( $cf->id ) {
1786 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1790 if ( $arg =~ /-Upload$/ ) {
1791 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1795 my $type = $cf->Type;
1798 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1799 @values = @{ $ARGS{$arg} };
1800 } elsif ( $type =~ /text/i ) {
1801 @values = ( $ARGS{$arg} );
1803 no warnings 'uninitialized';
1804 @values = split /\r*\n/, $ARGS{$arg};
1806 @values = grep length, map {
1812 grep defined, @values;
1814 $create_args{"CustomField-$cfid"} = \@values;
1818 # turn new link lists into arrays, and pass in the proper arguments
1820 'new-DependsOn' => 'DependsOn',
1821 'DependsOn-new' => 'DependedOnBy',
1822 'new-MemberOf' => 'Parents',
1823 'MemberOf-new' => 'Children',
1824 'new-RefersTo' => 'RefersTo',
1825 'RefersTo-new' => 'ReferredToBy',
1827 foreach my $key ( keys %map ) {
1828 next unless $ARGS{$key};
1829 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1833 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1838 push( @Actions, split( "\n", $ErrMsg ) );
1839 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1840 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1842 return ( $Ticket, @Actions );
1848 =head2 LoadTicket id
1850 Takes a ticket id as its only variable. if it's handed an array, it takes
1853 Returns an RT::Ticket object as the current user.
1860 if ( ref($id) eq "ARRAY" ) {
1865 Abort("No ticket specified");
1868 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1870 unless ( $Ticket->id ) {
1871 Abort("Could not load ticket $id");
1878 =head2 ProcessUpdateMessage
1880 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1882 Don't write message if it only contains current user's signature and
1883 SkipSignatureOnly argument is true. Function anyway adds attachments
1884 and updates time worked field even if skips message. The default value
1889 sub ProcessUpdateMessage {
1894 SkipSignatureOnly => 1,
1898 if ( $args{ARGSRef}->{'UpdateAttachments'}
1899 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1901 delete $args{ARGSRef}->{'UpdateAttachments'};
1904 # Strip the signature
1905 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1906 Content => $args{ARGSRef}->{UpdateContent},
1907 ContentType => $args{ARGSRef}->{UpdateContentType},
1908 StripSignature => $args{SkipSignatureOnly},
1909 CurrentUser => $args{'TicketObj'}->CurrentUser,
1912 # If, after stripping the signature, we have no message, move the
1913 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1914 # ProcessBasics can deal -- then bail out.
1915 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1916 and not length $args{ARGSRef}->{'UpdateContent'} )
1918 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1919 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1924 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1925 $args{ARGSRef}->{'UpdateSubject'} = undef;
1928 my $Message = MakeMIMEEntity(
1929 Subject => $args{ARGSRef}->{'UpdateSubject'},
1930 Body => $args{ARGSRef}->{'UpdateContent'},
1931 Type => $args{ARGSRef}->{'UpdateContentType'},
1934 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1935 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1937 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1938 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1939 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1941 $old_txn = $args{TicketObj}->Transactions->First();
1944 if ( my $msg = $old_txn->Message->First ) {
1945 RT::Interface::Email::SetInReplyTo(
1946 Message => $Message,
1951 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1952 $Message->make_multipart;
1953 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1956 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1957 require RT::Action::SendEmail;
1958 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1959 ref $args{ARGSRef}->{'AttachTickets'}
1960 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1961 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1964 my %txn_customfields;
1966 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1967 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1968 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1972 my %message_args = (
1973 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1974 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1975 MIMEObj => $Message,
1976 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1977 CustomFields => \%txn_customfields,
1980 _ProcessUpdateMessageRecipients(
1981 MessageArgs => \%message_args,
1986 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1987 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1988 push( @results, $Description );
1989 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1990 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1991 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1992 push( @results, $Description );
1993 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1996 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2001 sub _ProcessUpdateMessageRecipients {
2005 MessageArgs => undef,
2009 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2010 my $cc = $args{ARGSRef}->{'UpdateCc'};
2012 my $message_args = $args{MessageArgs};
2014 $message_args->{CcMessageTo} = $cc;
2015 $message_args->{BccMessageTo} = $bcc;
2018 foreach my $type (qw(Cc AdminCc)) {
2019 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2020 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2021 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2022 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2025 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2026 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2027 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2031 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2032 $message_args->{SquelchMailTo} = \@txn_squelch
2035 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2036 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2037 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2039 my $var = ucfirst($1) . 'MessageTo';
2041 if ( $message_args->{$var} ) {
2042 $message_args->{$var} .= ", $value";
2044 $message_args->{$var} = $value;
2050 =head2 MakeMIMEEntity PARAMHASH
2052 Takes a paramhash Subject, Body and AttachmentFieldName.
2054 Also takes Form, Cc and Type as optional paramhash keys.
2056 Returns a MIME::Entity.
2060 sub MakeMIMEEntity {
2062 #TODO document what else this takes.
2068 AttachmentFieldName => undef,
2072 my $Message = MIME::Entity->build(
2073 Type => 'multipart/mixed',
2074 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2075 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2076 grep defined $args{$_}, qw(Subject From Cc)
2079 if ( defined $args{'Body'} && length $args{'Body'} ) {
2081 # Make the update content have no 'weird' newlines in it
2082 $args{'Body'} =~ s/\r\n/\n/gs;
2085 Type => $args{'Type'} || 'text/plain',
2087 Data => $args{'Body'},
2091 if ( $args{'AttachmentFieldName'} ) {
2093 my $cgi_object = $m->cgi_object;
2094 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2095 if ( defined $filehandle && length $filehandle ) {
2097 my ( @content, $buffer );
2098 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2099 push @content, $buffer;
2102 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2104 my $filename = "$filehandle";
2105 $filename =~ s{^.*[\\/]}{};
2108 Type => $uploadinfo->{'Content-Type'},
2109 Filename => $filename,
2112 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2113 $Message->head->set( 'Subject' => $filename );
2116 # Attachment parts really shouldn't get a Message-ID
2117 $Message->head->delete('Message-ID');
2121 $Message->make_singlepart;
2123 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2131 =head2 ParseDateToISO
2133 Takes a date in an arbitrary format.
2134 Returns an ISO date and time in GMT
2138 sub ParseDateToISO {
2141 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2143 Format => 'unknown',
2146 return ( $date_obj->ISO );
2151 sub ProcessACLChanges {
2152 my $ARGSref = shift;
2156 foreach my $arg ( keys %$ARGSref ) {
2157 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2159 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2162 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2163 @rights = @{ $ARGSref->{$arg} };
2165 @rights = $ARGSref->{$arg};
2167 @rights = grep $_, @rights;
2168 next unless @rights;
2170 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2171 $principal->Load($principal_id);
2174 if ( $object_type eq 'RT::System' ) {
2176 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2177 $obj = $object_type->new( $session{'CurrentUser'} );
2178 $obj->Load($object_id);
2179 unless ( $obj->id ) {
2180 $RT::Logger->error("couldn't load $object_type #$object_id");
2184 $RT::Logger->error("object type '$object_type' is incorrect");
2185 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2189 foreach my $right (@rights) {
2190 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2191 push( @results, $msg );
2201 ProcessACLs expects values from a series of checkboxes that describe the full
2202 set of rights a principal should have on an object.
2204 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2205 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2206 listing the rights the principal should have, and ProcessACLs will modify the
2207 current rights to match. Additionally, the previously unused CheckACL input
2208 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2209 rights are removed from a principal and as such no SetRights input is
2215 my $ARGSref = shift;
2216 my (%state, @results);
2218 my $CheckACL = $ARGSref->{'CheckACL'};
2219 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2221 # Check if we want to grant rights to a previously rights-less user
2222 for my $type (qw(user group)) {
2223 my $key = "AddPrincipalForRights-$type";
2225 next unless $ARGSref->{$key};
2228 if ( $type eq 'user' ) {
2229 $principal = RT::User->new( $session{'CurrentUser'} );
2230 $principal->LoadByCol( Name => $ARGSref->{$key} );
2233 $principal = RT::Group->new( $session{'CurrentUser'} );
2234 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2237 unless ($principal->PrincipalId) {
2238 push @results, loc("Couldn't load the specified principal");
2242 my $principal_id = $principal->PrincipalId;
2244 # Turn our addprincipal rights spec into a real one
2245 for my $arg (keys %$ARGSref) {
2246 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2248 my $tuple = "$principal_id-$1";
2249 my $key = "SetRights-$tuple";
2251 # If we have it already, that's odd, but merge them
2252 if (grep { $_ eq $tuple } @check) {
2253 $ARGSref->{$key} = [
2254 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2255 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2258 $ARGSref->{$key} = $ARGSref->{$arg};
2259 push @check, $tuple;
2264 # Build our rights state for each Principal-Object tuple
2265 foreach my $arg ( keys %$ARGSref ) {
2266 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2269 my $value = $ARGSref->{$arg};
2270 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2271 next unless @rights;
2273 $state{$tuple} = { map { $_ => 1 } @rights };
2276 foreach my $tuple (List::MoreUtils::uniq @check) {
2277 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2279 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2281 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2282 $principal->Load($principal_id);
2285 if ( $object_type eq 'RT::System' ) {
2287 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2288 $obj = $object_type->new( $session{'CurrentUser'} );
2289 $obj->Load($object_id);
2290 unless ( $obj->id ) {
2291 $RT::Logger->error("couldn't load $object_type #$object_id");
2295 $RT::Logger->error("object type '$object_type' is incorrect");
2296 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2300 my $acls = RT::ACL->new($session{'CurrentUser'});
2301 $acls->LimitToObject( $obj );
2302 $acls->LimitToPrincipal( Id => $principal_id );
2304 while ( my $ace = $acls->Next ) {
2305 my $right = $ace->RightName;
2307 # Has right and should have right
2308 next if delete $state{$tuple}->{$right};
2310 # Has right and shouldn't have right
2311 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2312 push @results, $msg;
2315 # For everything left, they don't have the right but they should
2316 for my $right (keys %{ $state{$tuple} || {} }) {
2317 delete $state{$tuple}->{$right};
2318 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2319 push @results, $msg;
2322 # Check our state for leftovers
2323 if ( keys %{ $state{$tuple} || {} } ) {
2324 my $missed = join '|', %{$state{$tuple} || {}};
2326 "Uh-oh, it looks like we somehow missed a right in "
2327 ."ProcessACLs. Here's what was leftover: $missed"
2338 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2340 @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.
2342 Returns an array of success/failure messages
2346 sub UpdateRecordObject {
2349 AttributesRef => undef,
2351 AttributePrefix => undef,
2355 my $Object = $args{'Object'};
2356 my @results = $Object->Update(
2357 AttributesRef => $args{'AttributesRef'},
2358 ARGSRef => $args{'ARGSRef'},
2359 AttributePrefix => $args{'AttributePrefix'},
2367 sub ProcessCustomFieldUpdates {
2369 CustomFieldObj => undef,
2374 my $Object = $args{'CustomFieldObj'};
2375 my $ARGSRef = $args{'ARGSRef'};
2377 my @attribs = qw(Name Type Description Queue SortOrder);
2378 my @results = UpdateRecordObject(
2379 AttributesRef => \@attribs,
2384 my $prefix = "CustomField-" . $Object->Id;
2385 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2386 my ( $addval, $addmsg ) = $Object->AddValue(
2387 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2388 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2389 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2391 push( @results, $addmsg );
2395 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2396 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2397 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2399 foreach my $id (@delete_values) {
2400 next unless defined $id;
2401 my ( $err, $msg ) = $Object->DeleteValue($id);
2402 push( @results, $msg );
2405 my $vals = $Object->Values();
2406 while ( my $cfv = $vals->Next() ) {
2407 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2408 if ( $cfv->SortOrder != $so ) {
2409 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2410 push( @results, $msg );
2420 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2422 Returns an array of results messages.
2426 sub ProcessTicketBasics {
2434 my $TicketObj = $args{'TicketObj'};
2435 my $ARGSRef = $args{'ARGSRef'};
2437 my $OrigOwner = $TicketObj->Owner;
2452 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2453 for my $field (qw(Queue Owner)) {
2454 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2455 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2456 my $temp = $class->new(RT->SystemUser);
2457 $temp->Load( $ARGSRef->{$field} );
2459 $ARGSRef->{$field} = $temp->id;
2464 # Status isn't a field that can be set to a null value.
2465 # RT core complains if you try
2466 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2468 my @results = UpdateRecordObject(
2469 AttributesRef => \@attribs,
2470 Object => $TicketObj,
2471 ARGSRef => $ARGSRef,
2474 # We special case owner changing, so we can use ForceOwnerChange
2475 if ( $ARGSRef->{'Owner'}
2476 && $ARGSRef->{'Owner'} !~ /\D/
2477 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2479 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2480 $ChownType = "Force";
2486 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2487 push( @results, $msg );
2495 sub ProcessTicketReminders {
2502 my $Ticket = $args{'TicketObj'};
2503 my $args = $args{'ARGSRef'};
2506 my $reminder_collection = $Ticket->Reminders->Collection;
2508 if ( $args->{'update-reminders'} ) {
2509 while ( my $reminder = $reminder_collection->Next ) {
2510 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2511 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2512 $Ticket->Reminders->Resolve($reminder);
2514 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2515 $Ticket->Reminders->Open($reminder);
2518 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2519 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2522 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2523 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2526 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2527 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2529 Format => 'unknown',
2530 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2532 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2533 $reminder->SetDue( $DateObj->ISO );
2539 if ( $args->{'NewReminder-Subject'} ) {
2540 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2542 Format => 'unknown',
2543 Value => $args->{'NewReminder-Due'}
2545 my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2546 Subject => $args->{'NewReminder-Subject'},
2547 Owner => $args->{'NewReminder-Owner'},
2548 Due => $due_obj->ISO
2550 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2555 sub ProcessTicketCustomFieldUpdates {
2557 $args{'Object'} = delete $args{'TicketObj'};
2558 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2560 # Build up a list of objects that we want to work with
2561 my %custom_fields_to_mod;
2562 foreach my $arg ( keys %$ARGSRef ) {
2563 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2564 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2565 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2566 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2567 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2568 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2572 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2575 sub ProcessObjectCustomFieldUpdates {
2577 my $ARGSRef = $args{'ARGSRef'};
2580 # Build up a list of objects that we want to work with
2581 my %custom_fields_to_mod;
2582 foreach my $arg ( keys %$ARGSRef ) {
2584 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2585 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2587 # For each of those objects, find out what custom fields we want to work with.
2588 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2591 # For each of those objects
2592 foreach my $class ( keys %custom_fields_to_mod ) {
2593 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2594 my $Object = $args{'Object'};
2595 $Object = $class->new( $session{'CurrentUser'} )
2596 unless $Object && ref $Object eq $class;
2598 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2599 unless ( $Object->id ) {
2600 $RT::Logger->warning("Couldn't load object $class #$id");
2604 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2605 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2606 $CustomFieldObj->SetContextObject($Object);
2607 $CustomFieldObj->LoadById($cf);
2608 unless ( $CustomFieldObj->id ) {
2609 $RT::Logger->warning("Couldn't load custom field #$cf");
2613 _ProcessObjectCustomFieldUpdates(
2614 Prefix => "Object-$class-$id-CustomField-$cf-",
2616 CustomField => $CustomFieldObj,
2617 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2625 sub _ProcessObjectCustomFieldUpdates {
2627 my $cf = $args{'CustomField'};
2628 my $cf_type = $cf->Type || '';
2630 # Remove blank Values since the magic field will take care of this. Sometimes
2631 # the browser gives you a blank value which causes CFs to be processed twice
2632 if ( defined $args{'ARGS'}->{'Values'}
2633 && !length $args{'ARGS'}->{'Values'}
2634 && $args{'ARGS'}->{'Values-Magic'} )
2636 delete $args{'ARGS'}->{'Values'};
2640 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2642 # skip category argument
2643 next if $arg eq 'Category';
2646 next if $arg eq 'Value-TimeUnits';
2648 # since http won't pass in a form element with a null value, we need
2650 if ( $arg eq 'Values-Magic' ) {
2652 # We don't care about the magic, if there's really a values element;
2653 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2654 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2656 # "Empty" values does not mean anything for Image and Binary fields
2657 next if $cf_type =~ /^(?:Image|Binary)$/;
2660 $args{'ARGS'}->{'Values'} = undef;
2664 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2665 @values = @{ $args{'ARGS'}->{$arg} };
2666 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2667 @values = ( $args{'ARGS'}->{$arg} );
2669 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2670 if defined $args{'ARGS'}->{$arg};
2672 @values = grep length, map {
2678 grep defined, @values;
2680 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2681 foreach my $value (@values) {
2682 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2686 push( @results, $msg );
2688 } elsif ( $arg eq 'Upload' ) {
2689 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2690 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2691 push( @results, $msg );
2692 } elsif ( $arg eq 'DeleteValues' ) {
2693 foreach my $value (@values) {
2694 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2698 push( @results, $msg );
2700 } elsif ( $arg eq 'DeleteValueIds' ) {
2701 foreach my $value (@values) {
2702 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2706 push( @results, $msg );
2708 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2709 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2712 foreach my $value (@values) {
2713 if ( my $entry = $cf_values->HasEntry($value) ) {
2714 $values_hash{ $entry->id } = 1;
2718 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2722 push( @results, $msg );
2723 $values_hash{$val} = 1 if $val;
2726 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2727 return @results if ( $cf->Type eq 'Date' && ! @values );
2729 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2730 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2732 $cf_values->RedoSearch;
2733 while ( my $cf_value = $cf_values->Next ) {
2734 next if $values_hash{ $cf_value->id };
2736 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2738 ValueId => $cf_value->id
2740 push( @results, $msg );
2742 } elsif ( $arg eq 'Values' ) {
2743 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2745 # keep everything up to the point of difference, delete the rest
2747 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2748 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2757 # now add/replace extra things, if any
2758 foreach my $value (@values) {
2759 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2763 push( @results, $msg );
2768 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2769 $cf->Name, ref $args{'Object'},
2779 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2781 Returns an array of results messages.
2785 sub ProcessTicketWatchers {
2793 my $Ticket = $args{'TicketObj'};
2794 my $ARGSRef = $args{'ARGSRef'};
2798 foreach my $key ( keys %$ARGSRef ) {
2800 # Delete deletable watchers
2801 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2802 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2806 push @results, $msg;
2809 # Delete watchers in the simple style demanded by the bulk manipulator
2810 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2811 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2812 Email => $ARGSRef->{$key},
2815 push @results, $msg;
2818 # Add new wathchers by email address
2819 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2820 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2823 #They're in this order because otherwise $1 gets clobbered :/
2824 my ( $code, $msg ) = $Ticket->AddWatcher(
2825 Type => $ARGSRef->{$key},
2826 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2828 push @results, $msg;
2831 #Add requestors in the simple style demanded by the bulk manipulator
2832 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2833 my ( $code, $msg ) = $Ticket->AddWatcher(
2835 Email => $ARGSRef->{$key}
2837 push @results, $msg;
2840 # Add new watchers by owner
2841 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2842 my $principal_id = $1;
2843 my $form = $ARGSRef->{$key};
2844 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2845 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2847 my ( $code, $msg ) = $Ticket->AddWatcher(
2849 PrincipalId => $principal_id
2851 push @results, $msg;
2861 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2863 Returns an array of results messages.
2867 sub ProcessTicketDates {
2874 my $Ticket = $args{'TicketObj'};
2875 my $ARGSRef = $args{'ARGSRef'};
2880 my @date_fields = qw(
2888 #Run through each field in this list. update the value if apropriate
2889 foreach my $field (@date_fields) {
2890 next unless exists $ARGSRef->{ $field . '_Date' };
2891 next if $ARGSRef->{ $field . '_Date' } eq '';
2895 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2897 Format => 'unknown',
2898 Value => $ARGSRef->{ $field . '_Date' }
2901 my $obj = $field . "Obj";
2902 if ( ( defined $DateObj->Unix )
2903 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2905 my $method = "Set$field";
2906 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2907 push @results, "$msg";
2917 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2919 Returns an array of results messages.
2923 sub ProcessTicketLinks {
2930 my $Ticket = $args{'TicketObj'};
2931 my $ARGSRef = $args{'ARGSRef'};
2933 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2935 #Merge if we need to
2936 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2937 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2938 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2939 push @results, $msg;
2946 sub ProcessRecordLinks {
2953 my $Record = $args{'RecordObj'};
2954 my $ARGSRef = $args{'ARGSRef'};
2958 # Delete links that are gone gone gone.
2959 foreach my $arg ( keys %$ARGSRef ) {
2960 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2965 my ( $val, $msg ) = $Record->DeleteLink(
2971 push @results, $msg;
2977 my @linktypes = qw( DependsOn MemberOf RefersTo );
2979 foreach my $linktype (@linktypes) {
2980 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2981 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2982 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2984 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2986 $luri =~ s/\s+$//; # Strip trailing whitespace
2987 my ( $val, $msg ) = $Record->AddLink(
2991 push @results, $msg;
2994 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2995 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2996 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2998 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3000 my ( $val, $msg ) = $Record->AddLink(
3005 push @results, $msg;
3013 =head2 _UploadedFile ( $arg );
3015 Takes a CGI parameter name; if a file is uploaded under that name,
3016 return a hash reference suitable for AddCustomFieldValue's use:
3017 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3019 Returns C<undef> if no files were uploaded in the C<$arg> field.
3025 my $cgi_object = $m->cgi_object;
3026 my $fh = $cgi_object->upload($arg) or return undef;
3027 my $upload_info = $cgi_object->uploadInfo($fh);
3029 my $filename = "$fh";
3030 $filename =~ s#^.*[\\/]##;
3035 LargeContent => do { local $/; scalar <$fh> },
3036 ContentType => $upload_info->{'Content-Type'},
3040 sub GetColumnMapEntry {
3041 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3043 # deal with the simplest thing first
3044 if ( $args{'Map'}{ $args{'Name'} } ) {
3045 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3049 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
3050 return undef unless $args{'Map'}->{$mainkey};
3051 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3052 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3054 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3059 sub ProcessColumnMapValue {
3061 my %args = ( Arguments => [], Escape => 1, @_ );
3064 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3065 my @tmp = $value->( @{ $args{'Arguments'} } );
3066 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3067 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3068 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3069 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3074 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3078 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3080 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3081 principal collections mapped from the categories given.
3085 sub GetPrincipalsMap {
3090 my $system = RT::Groups->new($session{'CurrentUser'});
3091 $system->LimitToSystemInternalGroups();
3092 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3094 'System' => $system, # loc_left_pair
3099 my $groups = RT::Groups->new($session{'CurrentUser'});
3100 $groups->LimitToUserDefinedGroups();
3101 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3103 # Only show groups who have rights granted on this object
3104 $groups->WithGroupRight(
3107 IncludeSystemRights => 0,
3108 IncludeSubgroupMembers => 0,
3112 'User Groups' => $groups, # loc_left_pair
3117 my $roles = RT::Groups->new($session{'CurrentUser'});
3119 if ($object->isa('RT::System')) {
3120 $roles->LimitToRolesForSystem();
3122 elsif ($object->isa('RT::Queue')) {
3123 $roles->LimitToRolesForQueue($object->Id);
3126 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3129 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3131 'Roles' => $roles, # loc_left_pair
3136 my $Users = RT->PrivilegedUsers->UserMembersObj();
3137 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3139 # Only show users who have rights granted on this object
3140 my $group_members = $Users->WhoHaveGroupRight(
3143 IncludeSystemRights => 0,
3144 IncludeSubgroupMembers => 0,
3147 # Limit to UserEquiv groups
3148 my $groups = $Users->NewAlias('Groups');
3152 ALIAS2 => $group_members,
3155 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3156 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3160 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3163 'Users' => $Users, # loc_left_pair
3171 =head2 _load_container_object ( $type, $id );
3173 Instantiate container object for saving searches.
3177 sub _load_container_object {
3178 my ( $obj_type, $obj_id ) = @_;
3179 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3182 =head2 _parse_saved_search ( $arg );
3184 Given a serialization string for saved search, and returns the
3185 container object and the search id.
3189 sub _parse_saved_search {
3191 return unless $spec;
3192 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3199 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3202 =head2 ScrubHTML content
3204 Removes unsafe and undesired HTML from the passed content
3210 my $Content = shift;
3211 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3213 $Content = '' if !defined($Content);
3214 return $SCRUBBER->scrub($Content);
3219 Returns a new L<HTML::Scrubber> object.
3221 If you need to be more lax about what HTML tags and attributes are allowed,
3222 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3225 package HTML::Mason::Commands;
3226 # Let tables through
3227 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3232 our @SCRUBBER_ALLOWED_TAGS = qw(
3233 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3234 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3237 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3238 # Match http, ftp and relative urls
3239 # XXX: we also scrub format strings with this module then allow simple config options
3240 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
3246 (?:(?:background-)?color: \s*
3247 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3248 \#[a-f0-9]{3,6} | # #fff or #ffffff
3249 [\w\-]+ # green, light-blue, etc.
3251 text-align: \s* \w+ |
3252 font-size: \s* [\w.\-]+ |
3253 font-family: \s* [\w\s"',.\-]+ |
3254 font-weight: \s* [\w\-]+ |
3256 # MS Office styles, which are probably fine. If we don't, then any
3257 # associated styles in the same attribute get stripped.
3258 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3260 +$ # one or more of these allowed properties from here 'till sunset
3262 dir => qr/^(rtl|ltr)$/i,
3263 lang => qr/^\w+(-\w+)?$/,
3266 our %SCRUBBER_RULES = ();
3269 require HTML::Scrubber;
3270 my $scrubber = HTML::Scrubber->new();
3274 %SCRUBBER_ALLOWED_ATTRIBUTES,
3275 '*' => 0, # require attributes be explicitly allowed
3278 $scrubber->deny(qw[*]);
3279 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3280 $scrubber->rules(%SCRUBBER_RULES);
3282 # Scrubbing comments is vital since IE conditional comments can contain
3283 # arbitrary HTML and we'd pass it right on through.
3284 $scrubber->comment(0);
3291 Redispatches to L<RT::Interface::Web/EncodeJSON>
3296 RT::Interface::Web::EncodeJSON(@_);
3299 package RT::Interface::Web;
3300 RT::Base->_ImportOverlays();