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 =head2 WebCanonicalizeInfo();
163 Different web servers set different environmental varibles. This
164 function must return something suitable for REMOTE_USER. By default,
165 just downcase $ENV{'REMOTE_USER'}
169 sub WebCanonicalizeInfo {
170 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
175 =head2 WebExternalAutoInfo($user);
177 Returns a hash of user attributes, used when WebExternalAuto is set.
181 sub WebExternalAutoInfo {
186 # default to making Privileged users, even if they specify
187 # some other default Attributes
188 if ( !$RT::AutoCreate
189 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
191 $user_info{'Privileged'} = 1;
194 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
196 # Populate fields with information from Unix /etc/passwd
198 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
199 $user_info{'Comments'} = $comments if defined $comments;
200 $user_info{'RealName'} = $realname if defined $realname;
201 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
203 # Populate fields with information from NT domain controller
206 # and return the wad of stuff
214 if (RT->Config->Get('DevelMode')) {
215 require Module::Refresh;
216 Module::Refresh->refresh;
219 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
221 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
223 # Roll back any dangling transactions from a previous failed connection
224 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
226 MaybeEnableSQLStatementLog();
228 # avoid reentrancy, as suggested by masonbook
229 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
231 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
232 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
237 PreprocessTimeUpdates($ARGS);
239 MaybeShowInstallModePage();
241 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
243 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
245 # Process session-related callbacks before any auth attempts
246 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
248 MaybeRejectPrivateComponentRequest();
250 MaybeShowNoAuthPage($ARGS);
252 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
254 _ForceLogout() unless _UserLoggedIn();
256 # Process per-page authentication callbacks
257 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
259 unless ( _UserLoggedIn() ) {
262 # Authenticate if the user is trying to login via user/pass query args
263 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
266 my $m = $HTML::Mason::Commands::m;
268 # REST urls get a special 401 response
269 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
270 $HTML::Mason::Commands::r->content_type("text/plain");
271 $m->error_format("text");
272 $m->out("RT/$RT::VERSION 401 Credentials required\n");
273 $m->out("\n$msg\n") if $msg;
276 # Specially handle /index.html so that we get a nicer URL
277 elsif ( $m->request_comp->path eq '/index.html' ) {
278 my $next = SetNextPage(RT->Config->Get('WebURL'));
279 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
283 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
288 # now it applies not only to home page, but any dashboard that can be used as a workspace
289 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
290 if ( $ARGS->{'HomeRefreshInterval'} );
292 # Process per-page global callbacks
293 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
295 ShowRequestedPage($ARGS);
296 LogRecordedSQLStatements(RequestData => {
297 Path => $HTML::Mason::Commands::m->request_comp->path,
300 # Process per-page final cleanup callbacks
301 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
303 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
304 unless $HTML::Mason::Commands::r->content_type
305 =~ qr<^(text|application)/(x-)?(css|javascript)>;
310 delete $HTML::Mason::Commands::session{'CurrentUser'};
314 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
322 =head2 LoginError ERROR
324 Pushes a login error into the Actions session store and returns the hash key.
330 my $key = Digest::MD5::md5_hex( rand(1024) );
331 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
332 $HTML::Mason::Commands::session{'i'}++;
336 =head2 SetNextPage [PATH]
338 Intuits and stashes the next page in the sesssion hash. If PATH is
339 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
345 my $next = shift || IntuitNextPage();
346 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
348 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
349 $HTML::Mason::Commands::session{'i'}++;
356 =head2 TangentForLogin [HASH]
358 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
359 the next page. Optionally takes a hash which is dumped into query params.
363 sub TangentForLogin {
364 my $hash = SetNextPage();
365 my %query = (@_, next => $hash);
366 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
367 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
371 =head2 TangentForLoginWithError ERROR
373 Localizes the passed error message, stashes it with L<LoginError> and then
374 calls L<TangentForLogin> with the appropriate results key.
378 sub TangentForLoginWithError {
379 my $key = LoginError(HTML::Mason::Commands::loc(@_));
380 TangentForLogin( results => $key );
383 =head2 IntuitNextPage
385 Attempt to figure out the path to which we should return the user after a
386 tangent. The current request URL is used, or failing that, the C<WebURL>
387 configuration variable.
394 # This includes any query parameters. Redirect will take care of making
395 # it an absolute URL.
396 if ($ENV{'REQUEST_URI'}) {
397 $req_uri = $ENV{'REQUEST_URI'};
399 # collapse multiple leading slashes so the first part doesn't look like
400 # a hostname of a schema-less URI
401 $req_uri =~ s{^/+}{/};
404 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
407 my $uri = URI->new($next);
409 # You get undef scheme with a relative uri like "/Search/Build.html"
410 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
411 $next = RT->Config->Get('WebURL');
414 # Make sure we're logging in to the same domain
415 # You can get an undef authority with a relative uri like "index.html"
416 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
417 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
418 $next = RT->Config->Get('WebURL');
424 =head2 MaybeShowInstallModePage
426 This function, called exclusively by RT's autohandler, dispatches
427 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
429 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
433 sub MaybeShowInstallModePage {
434 return unless RT->InstallMode;
436 my $m = $HTML::Mason::Commands::m;
437 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
439 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
440 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
447 =head2 MaybeShowNoAuthPage \%ARGS
449 This function, called exclusively by RT's autohandler, dispatches
450 a request to the page a user requested (but only if it matches the "noauth" regex.
452 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
456 sub MaybeShowNoAuthPage {
459 my $m = $HTML::Mason::Commands::m;
461 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
463 # Don't show the login page to logged in users
464 Redirect(RT->Config->Get('WebURL'))
465 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
467 # If it's a noauth file, don't ask for auth.
469 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
473 =head2 MaybeRejectPrivateComponentRequest
475 This function will reject calls to private components, like those under
476 C</Elements>. If the requested path is a private component then we will
477 abort with a C<403> error.
481 sub MaybeRejectPrivateComponentRequest {
482 my $m = $HTML::Mason::Commands::m;
483 my $path = $m->request_comp->path;
485 # We do not check for dhandler here, because requesting our dhandlers
486 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
492 _elements | # mobile UI
494 autohandler | # requesting this directly is suspicious
496 ( $ | / ) # trailing slash or end of path
498 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
501 warn "rejecting private component $path\n";
509 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
510 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
511 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
516 =head2 ShowRequestedPage \%ARGS
518 This function, called exclusively by RT's autohandler, dispatches
519 a request to the page a user requested (making sure that unpriviled users
520 can only see self-service pages.
524 sub ShowRequestedPage {
527 my $m = $HTML::Mason::Commands::m;
529 # precache all system level rights for the current user
530 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
536 # If the user isn't privileged, they can only see SelfService
537 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
539 # if the user is trying to access a ticket, redirect them
540 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
541 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
544 # otherwise, drop the user at the SelfService default page
545 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
546 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
549 # if user is in SelfService dir let him do anything
551 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
554 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
559 sub AttemptExternalAuth {
562 return unless ( RT->Config->Get('WebExternalAuth') );
564 my $user = $ARGS->{user};
565 my $m = $HTML::Mason::Commands::m;
567 # If RT is configured for external auth, let's go through and get REMOTE_USER
569 # do we actually have a REMOTE_USER equivlent?
570 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
571 my $orig_user = $user;
573 $user = RT::Interface::Web::WebCanonicalizeInfo();
574 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
576 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
577 my $NodeName = Win32::NodeName();
578 $user =~ s/^\Q$NodeName\E\\//i;
581 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
582 InstantiateNewSession() unless _UserLoggedIn;
583 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
584 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
586 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
588 # Create users on-the-fly
589 my $UserObj = RT::User->new(RT->SystemUser);
590 my ( $val, $msg ) = $UserObj->Create(
591 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
598 # now get user specific information, to better create our user.
599 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
601 # set the attributes that have been defined.
602 foreach my $attribute ( $UserObj->WritableAttributes ) {
604 Attribute => $attribute,
606 UserInfo => $new_user_info,
607 CallbackName => 'NewUser',
608 CallbackPage => '/autohandler'
610 my $method = "Set$attribute";
611 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
613 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
616 # we failed to successfully create the user. abort abort abort.
617 delete $HTML::Mason::Commands::session{'CurrentUser'};
619 if (RT->Config->Get('WebFallbackToInternalAuth')) {
620 TangentForLoginWithError('Cannot create user: [_1]', $msg);
627 if ( _UserLoggedIn() ) {
628 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
629 # It is possible that we did a redirect to the login page,
630 # if the external auth allows lack of auth through with no
631 # REMOTE_USER set, instead of forcing a "permission
632 # denied" message. Honor the $next.
633 Redirect($next) if $next;
634 # Unlike AttemptPasswordAuthentication below, we do not
635 # force a redirect to / if $next is not set -- otherwise,
636 # straight-up external auth would always redirect to /
637 # when you first hit it.
639 delete $HTML::Mason::Commands::session{'CurrentUser'};
642 if ( RT->Config->Get('WebExternalOnly') ) {
643 TangentForLoginWithError('You are not an authorized user');
646 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
647 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
648 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
649 TangentForLoginWithError('You are not an authorized user');
653 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
654 # XXX: we must return AUTH_REQUIRED status or we fallback to
655 # internal auth here too.
656 delete $HTML::Mason::Commands::session{'CurrentUser'}
657 if defined $HTML::Mason::Commands::session{'CurrentUser'};
661 sub AttemptPasswordAuthentication {
663 return unless defined $ARGS->{user} && defined $ARGS->{pass};
665 my $user_obj = RT::CurrentUser->new();
666 $user_obj->Load( $ARGS->{user} );
668 my $m = $HTML::Mason::Commands::m;
670 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
671 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
672 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
673 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
676 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
678 # It's important to nab the next page from the session before we blow
680 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
682 InstantiateNewSession();
683 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
686 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
688 # Really the only time we don't want to redirect here is if we were
689 # passed user and pass as query params in the URL.
693 elsif ($ARGS->{'next'}) {
694 # Invalid hash, but still wants to go somewhere, take them to /
695 Redirect(RT->Config->Get('WebURL'));
698 return (1, HTML::Mason::Commands::loc('Logged in'));
702 =head2 LoadSessionFromCookie
704 Load or setup a session cookie for the current user.
708 sub _SessionCookieName {
709 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
710 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
714 sub LoadSessionFromCookie {
716 my %cookies = CGI::Cookie->fetch;
717 my $cookiename = _SessionCookieName();
718 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
719 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
720 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
721 undef $cookies{$cookiename};
723 if ( int RT->Config->Get('AutoLogoff') ) {
724 my $now = int( time / 60 );
725 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
727 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
728 InstantiateNewSession();
731 # save session on each request when AutoLogoff is turned on
732 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
736 sub InstantiateNewSession {
737 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
738 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
741 sub SendSessionCookie {
742 my $cookie = CGI::Cookie->new(
743 -name => _SessionCookieName(),
744 -value => $HTML::Mason::Commands::session{_session_id},
745 -path => RT->Config->Get('WebPath'),
746 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
747 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
750 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
755 This routine ells the current user's browser to redirect to URL.
756 Additionally, it unties the user's currently active session, helping to avoid
757 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
758 a cached DBI statement handle twice at the same time.
763 my $redir_to = shift;
764 untie $HTML::Mason::Commands::session;
765 my $uri = URI->new($redir_to);
766 my $server_uri = URI->new( RT->Config->Get('WebURL') );
768 # Make relative URIs absolute from the server host and scheme
769 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
770 if (not defined $uri->host) {
771 $uri->host($server_uri->host);
772 $uri->port($server_uri->port);
775 # If the user is coming in via a non-canonical
776 # hostname, don't redirect them to the canonical host,
777 # it will just upset them (and invalidate their credentials)
778 # don't do this if $RT::CanonicalizeRedirectURLs is true
779 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
780 && $uri->host eq $server_uri->host
781 && $uri->port eq $server_uri->port )
783 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
784 $uri->scheme('https');
786 $uri->scheme('http');
789 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
790 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
791 $uri->port( $ENV{'SERVER_PORT'} );
794 # not sure why, but on some systems without this call mason doesn't
795 # set status to 302, but 200 instead and people see blank pages
796 $HTML::Mason::Commands::r->status(302);
798 # Perlbal expects a status message, but Mason's default redirect status
799 # doesn't provide one. See also rt.cpan.org #36689.
800 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
802 $HTML::Mason::Commands::m->abort;
805 =head2 StaticFileHeaders
807 Send the browser a few headers to try to get it to (somewhat agressively)
808 cache RT's static Javascript and CSS files.
810 This routine could really use _accurate_ heuristics. (XXX TODO)
814 sub StaticFileHeaders {
815 my $date = RT::Date->new(RT->SystemUser);
818 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
820 # Expire things in a month.
821 $date->Set( Value => time + 30 * 24 * 60 * 60 );
822 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
824 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
825 # request, but we don't handle it and generate full reply again
826 # Last modified at server start time
827 # $date->Set( Value => $^T );
828 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
833 Takes a C<< Path => path >> and returns a boolean indicating that
834 the path is safely within RT's control or not. The path I<must> be
837 This function does not consult the filesystem at all; it is merely
838 a logical sanity checking of the path. This explicitly does not handle
839 symlinks; if you have symlinks in RT's webroot pointing outside of it,
840 then we assume you know what you are doing.
847 my $path = $args{Path};
849 # Get File::Spec to clean up extra /s, ./, etc
850 my $cleaned_up = File::Spec->canonpath($path);
852 if (!defined($cleaned_up)) {
853 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
857 # Forbid too many ..s. We can't just sum then check because
858 # "../foo/bar/baz" should be illegal even though it has more
859 # downdirs than updirs. So as soon as we get a negative score
860 # (which means "breaking out" of the top level) we reject the path.
862 my @components = split '/', $cleaned_up;
864 for my $component (@components) {
865 if ($component eq '..') {
868 $RT::Logger->info("Rejecting unsafe path: $path");
872 elsif ($component eq '.' || $component eq '') {
873 # these two have no effect on $score
883 =head2 SendStaticFile
885 Takes a File => path and a Type => Content-type
887 If Type isn't provided and File is an image, it will
888 figure out a sane Content-type, otherwise it will
889 send application/octet-stream
891 Will set caching headers using StaticFileHeaders
898 my $file = $args{File};
899 my $type = $args{Type};
900 my $relfile = $args{RelativeFile};
902 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
903 $HTML::Mason::Commands::r->status(400);
904 $HTML::Mason::Commands::m->abort;
907 $self->StaticFileHeaders();
910 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
912 $type =~ s/jpg/jpeg/gi;
914 $type ||= "application/octet-stream";
916 $HTML::Mason::Commands::r->content_type($type);
917 open( my $fh, '<', $file ) or die "couldn't open file: $!";
921 $HTML::Mason::Commands::m->out($_) while (<$fh>);
922 $HTML::Mason::Commands::m->flush_buffer;
933 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)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
944 my $content = $args{Content};
945 return '' unless $content;
947 # Make the content have no 'weird' newlines in it
948 $content =~ s/\r+\n/\n/g;
950 my $return_content = $content;
952 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
953 my $sigonly = $args{StripSignature};
955 # massage content to easily detect if there's any real content
956 $content =~ s/\s+//g; # yes! remove all the spaces
958 # remove html version of spaces and newlines
959 $content =~ s! !!g;
960 $content =~ s!<br/?>!!g;
963 # Filter empty content when type is text/html
964 return '' if $html && $content !~ /\S/;
966 # If we aren't supposed to strip the sig, just bail now.
967 return $return_content unless $sigonly;
970 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
973 # Check for plaintext sig
974 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
976 # Check for html-formatted sig; we don't use EscapeUTF8 here
977 # because we want to precisely match the escapting that FCKEditor
982 $sig =~ s/"/"/g;
984 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
987 return $return_content;
995 # if they've passed multiple values, they'll be an array. if they've
996 # passed just one, a scalar whatever they are, mark them as utf8
999 ? Encode::is_utf8($_)
1001 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1002 : ( $type eq 'ARRAY' )
1003 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1005 : ( $type eq 'HASH' )
1006 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1012 sub PreprocessTimeUpdates {
1015 # Later in the code we use
1016 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1017 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1018 # The call_next method pass through original arguments and if you have
1019 # an argument with unicode key then in a next component you'll get two
1020 # records in the args hash: one with key without UTF8 flag and another
1021 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1022 # is copied from mason's source to get the same results as we get from
1023 # call_next method, this feature is not documented, so we just leave it
1024 # here to avoid possible side effects.
1026 # This code canonicalizes time inputs in hours into minutes
1027 foreach my $field ( keys %$ARGS ) {
1028 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1030 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1031 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1032 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1033 $ARGS->{$local} *= 60;
1035 delete $ARGS->{$field};
1040 sub MaybeEnableSQLStatementLog {
1042 my $log_sql_statements = RT->Config->Get('StatementLog');
1044 if ($log_sql_statements) {
1045 $RT::Handle->ClearSQLStatementLog;
1046 $RT::Handle->LogSQLStatements(1);
1051 sub LogRecordedSQLStatements {
1054 my $log_sql_statements = RT->Config->Get('StatementLog');
1056 return unless ($log_sql_statements);
1058 my @log = $RT::Handle->SQLStatementLog;
1059 $RT::Handle->ClearSQLStatementLog;
1061 $RT::Handle->AddRequestToHistory({
1062 %{ $args{RequestData} },
1066 for my $stmt (@log) {
1067 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1077 level => $log_sql_statements,
1079 . sprintf( "%.6f", $duration )
1081 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1087 my $_has_validated_web_config = 0;
1088 sub ValidateWebConfig {
1091 # do this once per server instance, not once per request
1092 return if $_has_validated_web_config;
1093 $_has_validated_web_config = 1;
1095 if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) {
1096 $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.");
1099 if ($ENV{HTTP_HOST}) {
1100 # match "example.com" or "example.com:80"
1101 my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/;
1103 if ($host ne RT->Config->Get('WebDomain')) {
1104 $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.");
1108 if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) {
1109 $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.");
1113 if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) {
1114 $RT::Logger->warn("The actual SCRIPT_NAME ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken.");
1118 sub ComponentRoots {
1120 my %args = ( Names => 0, @_ );
1122 if (defined $HTML::Mason::Commands::m) {
1123 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1126 [ local => $RT::MasonLocalComponentRoot ],
1127 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1128 [ standard => $RT::MasonComponentRoot ]
1131 @roots = map { $_->[1] } @roots unless $args{Names};
1135 package HTML::Mason::Commands;
1137 use vars qw/$r $m %session/;
1140 return $HTML::Mason::Commands::m->notes('menu');
1144 return $HTML::Mason::Commands::m->notes('page-menu');
1148 return $HTML::Mason::Commands::m->notes('page-widgets');
1155 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1156 with whatever it's called with. If there is no $session{'CurrentUser'},
1157 it creates a temporary user, so we have something to get a localisation handle
1164 if ( $session{'CurrentUser'}
1165 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1167 return ( $session{'CurrentUser'}->loc(@_) );
1170 RT::CurrentUser->new();
1174 return ( $u->loc(@_) );
1177 # pathetic case -- SystemUser is gone.
1184 =head2 loc_fuzzy STRING
1186 loc_fuzzy is for handling localizations of messages that may already
1187 contain interpolated variables, typically returned from libraries
1188 outside RT's control. It takes the message string and extracts the
1189 variable array automatically by matching against the candidate entries
1190 inside the lexicon file.
1197 if ( $session{'CurrentUser'}
1198 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1200 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1202 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1203 return ( $u->loc_fuzzy($msg) );
1208 # Error - calls Error and aborts
1213 if ( $session{'ErrorDocument'}
1214 && $session{'ErrorDocumentType'} )
1216 $r->content_type( $session{'ErrorDocumentType'} );
1217 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1220 $m->comp( "/Elements/Error", Why => $why, %args );
1225 sub MaybeRedirectForResults {
1227 Path => $HTML::Mason::Commands::m->request_comp->path,
1234 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1235 return unless $has_actions || $args{'Force'};
1237 my %arguments = %{ $args{'Arguments'} };
1239 if ( $has_actions ) {
1240 my $key = Digest::MD5::md5_hex( rand(1024) );
1241 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1243 $arguments{'results'} = $key;
1246 $args{'Path'} =~ s!^/+!!;
1247 my $url = RT->Config->Get('WebURL') . $args{Path};
1249 if ( keys %arguments ) {
1250 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1252 if ( $args{'Anchor'} ) {
1253 $url .= "#". $args{'Anchor'};
1255 return RT::Interface::Web::Redirect($url);
1258 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1260 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1261 redirect to the approvals display page, preserving any arguments.
1263 C<Path>s matching C<Whitelist> are let through.
1265 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1269 sub MaybeRedirectToApproval {
1271 Path => $HTML::Mason::Commands::m->request_comp->path,
1277 return unless $ENV{REQUEST_METHOD} eq 'GET';
1279 my $id = $args{ARGSRef}->{id};
1282 and RT->Config->Get('ForceApprovalsView')
1283 and not $args{Path} =~ /$args{Whitelist}/)
1285 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1288 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1289 MaybeRedirectForResults(
1290 Path => "/Approvals/Display.html",
1292 Anchor => $args{ARGSRef}->{Anchor},
1293 Arguments => $args{ARGSRef},
1299 =head2 CreateTicket ARGS
1301 Create a new ticket, using Mason's %ARGS. returns @results.
1310 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1312 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1313 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1314 Abort('Queue not found');
1317 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1318 Abort('You have no permission to create tickets in that queue.');
1322 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1323 $due = RT::Date->new( $session{'CurrentUser'} );
1324 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1327 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1328 $starts = RT::Date->new( $session{'CurrentUser'} );
1329 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1332 my $sigless = RT::Interface::Web::StripContent(
1333 Content => $ARGS{Content},
1334 ContentType => $ARGS{ContentType},
1335 StripSignature => 1,
1336 CurrentUser => $session{'CurrentUser'},
1339 my $MIMEObj = MakeMIMEEntity(
1340 Subject => $ARGS{'Subject'},
1341 From => $ARGS{'From'},
1344 Type => $ARGS{'ContentType'},
1347 if ( $ARGS{'Attachments'} ) {
1348 my $rv = $MIMEObj->make_multipart;
1349 $RT::Logger->error("Couldn't make multipart message")
1350 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1352 foreach ( values %{ $ARGS{'Attachments'} } ) {
1354 $RT::Logger->error("Couldn't add empty attachemnt");
1357 $MIMEObj->add_part($_);
1361 foreach my $argument (qw(Encrypt Sign)) {
1362 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 )
1363 if defined $ARGS{$argument};
1367 Type => $ARGS{'Type'} || 'ticket',
1368 Queue => $ARGS{'Queue'},
1369 Owner => $ARGS{'Owner'},
1372 Requestor => $ARGS{'Requestors'},
1374 AdminCc => $ARGS{'AdminCc'},
1375 InitialPriority => $ARGS{'InitialPriority'},
1376 FinalPriority => $ARGS{'FinalPriority'},
1377 TimeLeft => $ARGS{'TimeLeft'},
1378 TimeEstimated => $ARGS{'TimeEstimated'},
1379 TimeWorked => $ARGS{'TimeWorked'},
1380 Subject => $ARGS{'Subject'},
1381 Status => $ARGS{'Status'},
1382 Due => $due ? $due->ISO : undef,
1383 Starts => $starts ? $starts->ISO : undef,
1388 foreach my $type (qw(Requestor Cc AdminCc)) {
1389 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1390 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1392 $create_args{TransSquelchMailTo} = \@txn_squelch
1395 if ( $ARGS{'AttachTickets'} ) {
1396 require RT::Action::SendEmail;
1397 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1398 ref $ARGS{'AttachTickets'}
1399 ? @{ $ARGS{'AttachTickets'} }
1400 : ( $ARGS{'AttachTickets'} ) );
1403 foreach my $arg ( keys %ARGS ) {
1404 next if $arg =~ /-(?:Magic|Category)$/;
1406 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1407 $create_args{$arg} = $ARGS{$arg};
1410 # Object-RT::Ticket--CustomField-3-Values
1411 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1414 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1416 unless ( $cf->id ) {
1417 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1421 if ( $arg =~ /-Upload$/ ) {
1422 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1426 my $type = $cf->Type;
1429 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1430 @values = @{ $ARGS{$arg} };
1431 } elsif ( $type =~ /text/i ) {
1432 @values = ( $ARGS{$arg} );
1434 no warnings 'uninitialized';
1435 @values = split /\r*\n/, $ARGS{$arg};
1437 @values = grep length, map {
1443 grep defined, @values;
1445 $create_args{"CustomField-$cfid"} = \@values;
1449 # turn new link lists into arrays, and pass in the proper arguments
1451 'new-DependsOn' => 'DependsOn',
1452 'DependsOn-new' => 'DependedOnBy',
1453 'new-MemberOf' => 'Parents',
1454 'MemberOf-new' => 'Children',
1455 'new-RefersTo' => 'RefersTo',
1456 'RefersTo-new' => 'ReferredToBy',
1458 foreach my $key ( keys %map ) {
1459 next unless $ARGS{$key};
1460 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1464 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1469 push( @Actions, split( "\n", $ErrMsg ) );
1470 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1471 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1473 return ( $Ticket, @Actions );
1479 =head2 LoadTicket id
1481 Takes a ticket id as its only variable. if it's handed an array, it takes
1484 Returns an RT::Ticket object as the current user.
1491 if ( ref($id) eq "ARRAY" ) {
1496 Abort("No ticket specified");
1499 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1501 unless ( $Ticket->id ) {
1502 Abort("Could not load ticket $id");
1509 =head2 ProcessUpdateMessage
1511 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1513 Don't write message if it only contains current user's signature and
1514 SkipSignatureOnly argument is true. Function anyway adds attachments
1515 and updates time worked field even if skips message. The default value
1520 sub ProcessUpdateMessage {
1525 SkipSignatureOnly => 1,
1529 if ( $args{ARGSRef}->{'UpdateAttachments'}
1530 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1532 delete $args{ARGSRef}->{'UpdateAttachments'};
1535 # Strip the signature
1536 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1537 Content => $args{ARGSRef}->{UpdateContent},
1538 ContentType => $args{ARGSRef}->{UpdateContentType},
1539 StripSignature => $args{SkipSignatureOnly},
1540 CurrentUser => $args{'TicketObj'}->CurrentUser,
1543 # If, after stripping the signature, we have no message, move the
1544 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1545 # ProcessBasics can deal -- then bail out.
1546 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1547 and not length $args{ARGSRef}->{'UpdateContent'} )
1549 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1550 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1555 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1556 $args{ARGSRef}->{'UpdateSubject'} = undef;
1559 my $Message = MakeMIMEEntity(
1560 Subject => $args{ARGSRef}->{'UpdateSubject'},
1561 Body => $args{ARGSRef}->{'UpdateContent'},
1562 Type => $args{ARGSRef}->{'UpdateContentType'},
1565 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1566 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1568 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1569 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1570 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1572 $old_txn = $args{TicketObj}->Transactions->First();
1575 if ( my $msg = $old_txn->Message->First ) {
1576 RT::Interface::Email::SetInReplyTo(
1577 Message => $Message,
1582 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1583 $Message->make_multipart;
1584 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1587 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1588 require RT::Action::SendEmail;
1589 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1590 ref $args{ARGSRef}->{'AttachTickets'}
1591 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1592 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1595 my %txn_customfields;
1597 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1598 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1599 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1603 my %message_args = (
1604 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1605 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1606 MIMEObj => $Message,
1607 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1608 CustomFields => \%txn_customfields,
1611 _ProcessUpdateMessageRecipients(
1612 MessageArgs => \%message_args,
1617 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1618 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1619 push( @results, $Description );
1620 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1621 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1622 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1623 push( @results, $Description );
1624 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1627 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1632 sub _ProcessUpdateMessageRecipients {
1636 MessageArgs => undef,
1640 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1641 my $cc = $args{ARGSRef}->{'UpdateCc'};
1643 my $message_args = $args{MessageArgs};
1645 $message_args->{CcMessageTo} = $cc;
1646 $message_args->{BccMessageTo} = $bcc;
1649 foreach my $type (qw(Cc AdminCc)) {
1650 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1651 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1652 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1653 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1656 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1657 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
1658 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1662 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
1663 $message_args->{SquelchMailTo} = \@txn_squelch
1666 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1667 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1668 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1670 my $var = ucfirst($1) . 'MessageTo';
1672 if ( $message_args->{$var} ) {
1673 $message_args->{$var} .= ", $value";
1675 $message_args->{$var} = $value;
1681 =head2 MakeMIMEEntity PARAMHASH
1683 Takes a paramhash Subject, Body and AttachmentFieldName.
1685 Also takes Form, Cc and Type as optional paramhash keys.
1687 Returns a MIME::Entity.
1691 sub MakeMIMEEntity {
1693 #TODO document what else this takes.
1699 AttachmentFieldName => undef,
1703 my $Message = MIME::Entity->build(
1704 Type => 'multipart/mixed',
1705 "Message-Id" => RT::Interface::Email::GenMessageId,
1706 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1707 grep defined $args{$_}, qw(Subject From Cc)
1710 if ( defined $args{'Body'} && length $args{'Body'} ) {
1712 # Make the update content have no 'weird' newlines in it
1713 $args{'Body'} =~ s/\r\n/\n/gs;
1716 Type => $args{'Type'} || 'text/plain',
1718 Data => $args{'Body'},
1722 if ( $args{'AttachmentFieldName'} ) {
1724 my $cgi_object = $m->cgi_object;
1725 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
1726 if ( defined $filehandle && length $filehandle ) {
1728 my ( @content, $buffer );
1729 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1730 push @content, $buffer;
1733 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1735 my $filename = "$filehandle";
1736 $filename =~ s{^.*[\\/]}{};
1739 Type => $uploadinfo->{'Content-Type'},
1740 Filename => $filename,
1743 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1744 $Message->head->set( 'Subject' => $filename );
1747 # Attachment parts really shouldn't get a Message-ID
1748 $Message->head->delete('Message-ID');
1752 $Message->make_singlepart;
1754 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1762 =head2 ParseDateToISO
1764 Takes a date in an arbitrary format.
1765 Returns an ISO date and time in GMT
1769 sub ParseDateToISO {
1772 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1774 Format => 'unknown',
1777 return ( $date_obj->ISO );
1782 sub ProcessACLChanges {
1783 my $ARGSref = shift;
1787 foreach my $arg ( keys %$ARGSref ) {
1788 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1790 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1793 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1794 @rights = @{ $ARGSref->{$arg} };
1796 @rights = $ARGSref->{$arg};
1798 @rights = grep $_, @rights;
1799 next unless @rights;
1801 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1802 $principal->Load($principal_id);
1805 if ( $object_type eq 'RT::System' ) {
1807 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1808 $obj = $object_type->new( $session{'CurrentUser'} );
1809 $obj->Load($object_id);
1810 unless ( $obj->id ) {
1811 $RT::Logger->error("couldn't load $object_type #$object_id");
1815 $RT::Logger->error("object type '$object_type' is incorrect");
1816 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1820 foreach my $right (@rights) {
1821 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1822 push( @results, $msg );
1832 ProcessACLs expects values from a series of checkboxes that describe the full
1833 set of rights a principal should have on an object.
1835 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
1836 instead of with the prefixes Grant/RevokeRight. Each input should be an array
1837 listing the rights the principal should have, and ProcessACLs will modify the
1838 current rights to match. Additionally, the previously unused CheckACL input
1839 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
1840 rights are removed from a principal and as such no SetRights input is
1846 my $ARGSref = shift;
1847 my (%state, @results);
1849 my $CheckACL = $ARGSref->{'CheckACL'};
1850 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
1852 # Check if we want to grant rights to a previously rights-less user
1853 for my $type (qw(user group)) {
1854 my $key = "AddPrincipalForRights-$type";
1856 next unless $ARGSref->{$key};
1859 if ( $type eq 'user' ) {
1860 $principal = RT::User->new( $session{'CurrentUser'} );
1861 $principal->LoadByCol( Name => $ARGSref->{$key} );
1864 $principal = RT::Group->new( $session{'CurrentUser'} );
1865 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
1868 unless ($principal->PrincipalId) {
1869 push @results, loc("Couldn't load the specified principal");
1873 my $principal_id = $principal->PrincipalId;
1875 # Turn our addprincipal rights spec into a real one
1876 for my $arg (keys %$ARGSref) {
1877 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
1879 my $tuple = "$principal_id-$1";
1880 my $key = "SetRights-$tuple";
1882 # If we have it already, that's odd, but merge them
1883 if (grep { $_ eq $tuple } @check) {
1884 $ARGSref->{$key} = [
1885 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
1886 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
1889 $ARGSref->{$key} = $ARGSref->{$arg};
1890 push @check, $tuple;
1895 # Build our rights state for each Principal-Object tuple
1896 foreach my $arg ( keys %$ARGSref ) {
1897 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
1900 my $value = $ARGSref->{$arg};
1901 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
1902 next unless @rights;
1904 $state{$tuple} = { map { $_ => 1 } @rights };
1907 foreach my $tuple (List::MoreUtils::uniq @check) {
1908 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
1910 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
1912 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1913 $principal->Load($principal_id);
1916 if ( $object_type eq 'RT::System' ) {
1918 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1919 $obj = $object_type->new( $session{'CurrentUser'} );
1920 $obj->Load($object_id);
1921 unless ( $obj->id ) {
1922 $RT::Logger->error("couldn't load $object_type #$object_id");
1926 $RT::Logger->error("object type '$object_type' is incorrect");
1927 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1931 my $acls = RT::ACL->new($session{'CurrentUser'});
1932 $acls->LimitToObject( $obj );
1933 $acls->LimitToPrincipal( Id => $principal_id );
1935 while ( my $ace = $acls->Next ) {
1936 my $right = $ace->RightName;
1938 # Has right and should have right
1939 next if delete $state{$tuple}->{$right};
1941 # Has right and shouldn't have right
1942 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
1943 push @results, $msg;
1946 # For everything left, they don't have the right but they should
1947 for my $right (keys %{ $state{$tuple} || {} }) {
1948 delete $state{$tuple}->{$right};
1949 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
1950 push @results, $msg;
1953 # Check our state for leftovers
1954 if ( keys %{ $state{$tuple} || {} } ) {
1955 my $missed = join '|', %{$state{$tuple} || {}};
1957 "Uh-oh, it looks like we somehow missed a right in "
1958 ."ProcessACLs. Here's what was leftover: $missed"
1969 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1971 @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.
1973 Returns an array of success/failure messages
1977 sub UpdateRecordObject {
1980 AttributesRef => undef,
1982 AttributePrefix => undef,
1986 my $Object = $args{'Object'};
1987 my @results = $Object->Update(
1988 AttributesRef => $args{'AttributesRef'},
1989 ARGSRef => $args{'ARGSRef'},
1990 AttributePrefix => $args{'AttributePrefix'},
1998 sub ProcessCustomFieldUpdates {
2000 CustomFieldObj => undef,
2005 my $Object = $args{'CustomFieldObj'};
2006 my $ARGSRef = $args{'ARGSRef'};
2008 my @attribs = qw(Name Type Description Queue SortOrder);
2009 my @results = UpdateRecordObject(
2010 AttributesRef => \@attribs,
2015 my $prefix = "CustomField-" . $Object->Id;
2016 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2017 my ( $addval, $addmsg ) = $Object->AddValue(
2018 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2019 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2020 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2022 push( @results, $addmsg );
2026 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2027 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2028 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2030 foreach my $id (@delete_values) {
2031 next unless defined $id;
2032 my ( $err, $msg ) = $Object->DeleteValue($id);
2033 push( @results, $msg );
2036 my $vals = $Object->Values();
2037 while ( my $cfv = $vals->Next() ) {
2038 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2039 if ( $cfv->SortOrder != $so ) {
2040 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2041 push( @results, $msg );
2051 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2053 Returns an array of results messages.
2057 sub ProcessTicketBasics {
2065 my $TicketObj = $args{'TicketObj'};
2066 my $ARGSRef = $args{'ARGSRef'};
2068 my $OrigOwner = $TicketObj->Owner;
2083 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2084 for my $field (qw(Queue Owner)) {
2085 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2086 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2087 my $temp = $class->new(RT->SystemUser);
2088 $temp->Load( $ARGSRef->{$field} );
2090 $ARGSRef->{$field} = $temp->id;
2095 # Status isn't a field that can be set to a null value.
2096 # RT core complains if you try
2097 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2099 my @results = UpdateRecordObject(
2100 AttributesRef => \@attribs,
2101 Object => $TicketObj,
2102 ARGSRef => $ARGSRef,
2105 # We special case owner changing, so we can use ForceOwnerChange
2106 if ( $ARGSRef->{'Owner'}
2107 && $ARGSRef->{'Owner'} !~ /\D/
2108 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2110 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2111 $ChownType = "Force";
2117 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2118 push( @results, $msg );
2126 sub ProcessTicketReminders {
2133 my $Ticket = $args{'TicketObj'};
2134 my $args = $args{'ARGSRef'};
2137 my $reminder_collection = $Ticket->Reminders->Collection;
2139 if ( $args->{'update-reminders'} ) {
2140 while ( my $reminder = $reminder_collection->Next ) {
2141 if ( $reminder->Status ne 'resolved' && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2142 $Ticket->Reminders->Resolve($reminder);
2144 elsif ( $reminder->Status eq 'resolved' && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2145 $Ticket->Reminders->Open($reminder);
2148 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2149 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2152 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2153 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2156 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2157 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2159 Format => 'unknown',
2160 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2162 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2163 $reminder->SetDue( $DateObj->ISO );
2169 if ( $args->{'NewReminder-Subject'} ) {
2170 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2172 Format => 'unknown',
2173 Value => $args->{'NewReminder-Due'}
2175 my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2176 Subject => $args->{'NewReminder-Subject'},
2177 Owner => $args->{'NewReminder-Owner'},
2178 Due => $due_obj->ISO
2180 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2185 sub ProcessTicketCustomFieldUpdates {
2187 $args{'Object'} = delete $args{'TicketObj'};
2188 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2190 # Build up a list of objects that we want to work with
2191 my %custom_fields_to_mod;
2192 foreach my $arg ( keys %$ARGSRef ) {
2193 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2194 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2195 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2196 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2197 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2198 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2202 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2205 sub ProcessObjectCustomFieldUpdates {
2207 my $ARGSRef = $args{'ARGSRef'};
2210 # Build up a list of objects that we want to work with
2211 my %custom_fields_to_mod;
2212 foreach my $arg ( keys %$ARGSRef ) {
2214 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2215 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2217 # For each of those objects, find out what custom fields we want to work with.
2218 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2221 # For each of those objects
2222 foreach my $class ( keys %custom_fields_to_mod ) {
2223 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2224 my $Object = $args{'Object'};
2225 $Object = $class->new( $session{'CurrentUser'} )
2226 unless $Object && ref $Object eq $class;
2228 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2229 unless ( $Object->id ) {
2230 $RT::Logger->warning("Couldn't load object $class #$id");
2234 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2235 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2236 $CustomFieldObj->LoadById($cf);
2237 unless ( $CustomFieldObj->id ) {
2238 $RT::Logger->warning("Couldn't load custom field #$cf");
2242 _ProcessObjectCustomFieldUpdates(
2243 Prefix => "Object-$class-$id-CustomField-$cf-",
2245 CustomField => $CustomFieldObj,
2246 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2254 sub _ProcessObjectCustomFieldUpdates {
2256 my $cf = $args{'CustomField'};
2257 my $cf_type = $cf->Type || '';
2259 # Remove blank Values since the magic field will take care of this. Sometimes
2260 # the browser gives you a blank value which causes CFs to be processed twice
2261 if ( defined $args{'ARGS'}->{'Values'}
2262 && !length $args{'ARGS'}->{'Values'}
2263 && $args{'ARGS'}->{'Values-Magic'} )
2265 delete $args{'ARGS'}->{'Values'};
2269 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2271 # skip category argument
2272 next if $arg eq 'Category';
2275 next if $arg eq 'Value-TimeUnits';
2277 # since http won't pass in a form element with a null value, we need
2279 if ( $arg eq 'Values-Magic' ) {
2281 # We don't care about the magic, if there's really a values element;
2282 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2283 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2285 # "Empty" values does not mean anything for Image and Binary fields
2286 next if $cf_type =~ /^(?:Image|Binary)$/;
2289 $args{'ARGS'}->{'Values'} = undef;
2293 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2294 @values = @{ $args{'ARGS'}->{$arg} };
2295 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2296 @values = ( $args{'ARGS'}->{$arg} );
2298 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2299 if defined $args{'ARGS'}->{$arg};
2301 @values = grep length, map {
2307 grep defined, @values;
2309 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2310 foreach my $value (@values) {
2311 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2315 push( @results, $msg );
2317 } elsif ( $arg eq 'Upload' ) {
2318 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2319 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2320 push( @results, $msg );
2321 } elsif ( $arg eq 'DeleteValues' ) {
2322 foreach my $value (@values) {
2323 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2327 push( @results, $msg );
2329 } elsif ( $arg eq 'DeleteValueIds' ) {
2330 foreach my $value (@values) {
2331 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2335 push( @results, $msg );
2337 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2338 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2341 foreach my $value (@values) {
2342 if ( my $entry = $cf_values->HasEntry($value) ) {
2343 $values_hash{ $entry->id } = 1;
2347 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2351 push( @results, $msg );
2352 $values_hash{$val} = 1 if $val;
2355 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2356 return @results if ( $cf->Type eq 'Date' && ! @values );
2358 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2359 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2361 $cf_values->RedoSearch;
2362 while ( my $cf_value = $cf_values->Next ) {
2363 next if $values_hash{ $cf_value->id };
2365 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2367 ValueId => $cf_value->id
2369 push( @results, $msg );
2371 } elsif ( $arg eq 'Values' ) {
2372 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2374 # keep everything up to the point of difference, delete the rest
2376 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2377 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2386 # now add/replace extra things, if any
2387 foreach my $value (@values) {
2388 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2392 push( @results, $msg );
2397 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2398 $cf->Name, ref $args{'Object'},
2408 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2410 Returns an array of results messages.
2414 sub ProcessTicketWatchers {
2422 my $Ticket = $args{'TicketObj'};
2423 my $ARGSRef = $args{'ARGSRef'};
2427 foreach my $key ( keys %$ARGSRef ) {
2429 # Delete deletable watchers
2430 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2431 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2435 push @results, $msg;
2438 # Delete watchers in the simple style demanded by the bulk manipulator
2439 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2440 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2441 Email => $ARGSRef->{$key},
2444 push @results, $msg;
2447 # Add new wathchers by email address
2448 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2449 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2452 #They're in this order because otherwise $1 gets clobbered :/
2453 my ( $code, $msg ) = $Ticket->AddWatcher(
2454 Type => $ARGSRef->{$key},
2455 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2457 push @results, $msg;
2460 #Add requestors in the simple style demanded by the bulk manipulator
2461 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2462 my ( $code, $msg ) = $Ticket->AddWatcher(
2464 Email => $ARGSRef->{$key}
2466 push @results, $msg;
2469 # Add new watchers by owner
2470 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2471 my $principal_id = $1;
2472 my $form = $ARGSRef->{$key};
2473 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2474 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2476 my ( $code, $msg ) = $Ticket->AddWatcher(
2478 PrincipalId => $principal_id
2480 push @results, $msg;
2490 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2492 Returns an array of results messages.
2496 sub ProcessTicketDates {
2503 my $Ticket = $args{'TicketObj'};
2504 my $ARGSRef = $args{'ARGSRef'};
2509 my @date_fields = qw(
2517 #Run through each field in this list. update the value if apropriate
2518 foreach my $field (@date_fields) {
2519 next unless exists $ARGSRef->{ $field . '_Date' };
2520 next if $ARGSRef->{ $field . '_Date' } eq '';
2524 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2526 Format => 'unknown',
2527 Value => $ARGSRef->{ $field . '_Date' }
2530 my $obj = $field . "Obj";
2531 if ( ( defined $DateObj->Unix )
2532 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2534 my $method = "Set$field";
2535 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2536 push @results, "$msg";
2546 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2548 Returns an array of results messages.
2552 sub ProcessTicketLinks {
2559 my $Ticket = $args{'TicketObj'};
2560 my $ARGSRef = $args{'ARGSRef'};
2562 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2564 #Merge if we need to
2565 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2566 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2567 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2568 push @results, $msg;
2575 sub ProcessRecordLinks {
2582 my $Record = $args{'RecordObj'};
2583 my $ARGSRef = $args{'ARGSRef'};
2587 # Delete links that are gone gone gone.
2588 foreach my $arg ( keys %$ARGSRef ) {
2589 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2594 my ( $val, $msg ) = $Record->DeleteLink(
2600 push @results, $msg;
2606 my @linktypes = qw( DependsOn MemberOf RefersTo );
2608 foreach my $linktype (@linktypes) {
2609 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2610 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2611 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2613 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2615 $luri =~ s/\s+$//; # Strip trailing whitespace
2616 my ( $val, $msg ) = $Record->AddLink(
2620 push @results, $msg;
2623 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2624 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2625 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2627 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2629 my ( $val, $msg ) = $Record->AddLink(
2634 push @results, $msg;
2642 =head2 _UploadedFile ( $arg );
2644 Takes a CGI parameter name; if a file is uploaded under that name,
2645 return a hash reference suitable for AddCustomFieldValue's use:
2646 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2648 Returns C<undef> if no files were uploaded in the C<$arg> field.
2654 my $cgi_object = $m->cgi_object;
2655 my $fh = $cgi_object->upload($arg) or return undef;
2656 my $upload_info = $cgi_object->uploadInfo($fh);
2658 my $filename = "$fh";
2659 $filename =~ s#^.*[\\/]##;
2664 LargeContent => do { local $/; scalar <$fh> },
2665 ContentType => $upload_info->{'Content-Type'},
2669 sub GetColumnMapEntry {
2670 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2672 # deal with the simplest thing first
2673 if ( $args{'Map'}{ $args{'Name'} } ) {
2674 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2678 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2679 return undef unless $args{'Map'}->{$mainkey};
2680 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2681 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2683 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2688 sub ProcessColumnMapValue {
2690 my %args = ( Arguments => [], Escape => 1, @_ );
2693 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2694 my @tmp = $value->( @{ $args{'Arguments'} } );
2695 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2696 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2697 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2698 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2703 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2707 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2709 Returns an array suitable for passing to /Admin/Elements/EditRights with the
2710 principal collections mapped from the categories given.
2714 sub GetPrincipalsMap {
2719 my $system = RT::Groups->new($session{'CurrentUser'});
2720 $system->LimitToSystemInternalGroups();
2721 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2723 'System' => $system, # loc_left_pair
2728 my $groups = RT::Groups->new($session{'CurrentUser'});
2729 $groups->LimitToUserDefinedGroups();
2730 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2732 # Only show groups who have rights granted on this object
2733 $groups->WithGroupRight(
2736 IncludeSystemRights => 0,
2737 IncludeSubgroupMembers => 0,
2741 'User Groups' => $groups, # loc_left_pair
2746 my $roles = RT::Groups->new($session{'CurrentUser'});
2748 if ($object->isa('RT::System')) {
2749 $roles->LimitToRolesForSystem();
2751 elsif ($object->isa('RT::Queue')) {
2752 $roles->LimitToRolesForQueue($object->Id);
2755 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
2758 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2760 'Roles' => $roles, # loc_left_pair
2765 my $Users = RT->PrivilegedUsers->UserMembersObj();
2766 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2768 # Only show users who have rights granted on this object
2769 my $group_members = $Users->WhoHaveGroupRight(
2772 IncludeSystemRights => 0,
2773 IncludeSubgroupMembers => 0,
2776 # Limit to UserEquiv groups
2777 my $groups = $Users->NewAlias('Groups');
2781 ALIAS2 => $group_members,
2784 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
2785 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
2789 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
2792 'Users' => $Users, # loc_left_pair
2800 =head2 _load_container_object ( $type, $id );
2802 Instantiate container object for saving searches.
2806 sub _load_container_object {
2807 my ( $obj_type, $obj_id ) = @_;
2808 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2811 =head2 _parse_saved_search ( $arg );
2813 Given a serialization string for saved search, and returns the
2814 container object and the search id.
2818 sub _parse_saved_search {
2820 return unless $spec;
2821 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2828 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2831 =head2 ScrubHTML content
2833 Removes unsafe and undesired HTML from the passed content
2839 my $Content = shift;
2840 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2842 $Content = '' if !defined($Content);
2843 return $SCRUBBER->scrub($Content);
2848 Returns a new L<HTML::Scrubber> object. Override this if you insist on
2849 letting more HTML through.
2854 require HTML::Scrubber;
2855 my $scrubber = HTML::Scrubber->new();
2862 # Match http, ftp and relative urls
2863 # XXX: we also scrub format strings with this module then allow simple config options
2864 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2870 (?:(?:background-)?color: \s*
2871 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
2872 \#[a-f0-9]{3,6} | # #fff or #ffffff
2873 [\w\-]+ # green, light-blue, etc.
2875 text-align: \s* \w+ |
2876 font-size: \s* [\w.\-]+ |
2877 font-family: \s* [\w\s"',.\-]+ |
2878 font-weight: \s* [\w\-]+ |
2880 # MS Office styles, which are probably fine. If we don't, then any
2881 # associated styles in the same attribute get stripped.
2882 mso-[\w\-]+?: \s* [\w\s"',.\-]+
2884 +$ # one or more of these allowed properties from here 'till sunset
2888 $scrubber->deny(qw[*]);
2890 qw[A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE]
2892 $scrubber->comment(0);
2899 Redispatches to L<RT::Interface::Web/EncodeJSON>
2904 RT::Interface::Web::EncodeJSON(@_);
2907 package RT::Interface::Web;
2908 RT::Base->_ImportOverlays();