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 #i don't understand how this was ever expected to work
1114 # (even without our dum double // hack)??
1115 #if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) {
1116 ( my $WebPath = RT->Config->Get('WebPath') ) =~ s(/+)(/)g;
1117 ( my $script_name = $ENV{SCRIPT_NAME} ) =~ s(/+)(/)g;
1118 my $script_name_prefix = substr($script_name, 0, length($WebPath));
1119 if ( $script_name_prefix ne $WebPath ) {
1120 $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.");
1124 sub ComponentRoots {
1126 my %args = ( Names => 0, @_ );
1128 if (defined $HTML::Mason::Commands::m) {
1129 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1132 [ local => $RT::MasonLocalComponentRoot ],
1133 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1134 [ standard => $RT::MasonComponentRoot ]
1137 @roots = map { $_->[1] } @roots unless $args{Names};
1141 package HTML::Mason::Commands;
1143 use vars qw/$r $m %session/;
1146 return $HTML::Mason::Commands::m->notes('menu');
1150 return $HTML::Mason::Commands::m->notes('page-menu');
1154 return $HTML::Mason::Commands::m->notes('page-widgets');
1161 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1162 with whatever it's called with. If there is no $session{'CurrentUser'},
1163 it creates a temporary user, so we have something to get a localisation handle
1170 if ( $session{'CurrentUser'}
1171 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1173 return ( $session{'CurrentUser'}->loc(@_) );
1176 RT::CurrentUser->new();
1180 return ( $u->loc(@_) );
1183 # pathetic case -- SystemUser is gone.
1190 =head2 loc_fuzzy STRING
1192 loc_fuzzy is for handling localizations of messages that may already
1193 contain interpolated variables, typically returned from libraries
1194 outside RT's control. It takes the message string and extracts the
1195 variable array automatically by matching against the candidate entries
1196 inside the lexicon file.
1203 if ( $session{'CurrentUser'}
1204 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1206 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1208 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1209 return ( $u->loc_fuzzy($msg) );
1214 # Error - calls Error and aborts
1219 if ( $session{'ErrorDocument'}
1220 && $session{'ErrorDocumentType'} )
1222 $r->content_type( $session{'ErrorDocumentType'} );
1223 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1226 $m->comp( "/Elements/Error", Why => $why, %args );
1231 sub MaybeRedirectForResults {
1233 Path => $HTML::Mason::Commands::m->request_comp->path,
1240 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1241 return unless $has_actions || $args{'Force'};
1243 my %arguments = %{ $args{'Arguments'} };
1245 if ( $has_actions ) {
1246 my $key = Digest::MD5::md5_hex( rand(1024) );
1247 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1249 $arguments{'results'} = $key;
1252 $args{'Path'} =~ s!^/+!!;
1253 my $url = RT->Config->Get('WebURL') . $args{Path};
1255 if ( keys %arguments ) {
1256 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1258 if ( $args{'Anchor'} ) {
1259 $url .= "#". $args{'Anchor'};
1261 return RT::Interface::Web::Redirect($url);
1264 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1266 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1267 redirect to the approvals display page, preserving any arguments.
1269 C<Path>s matching C<Whitelist> are let through.
1271 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1275 sub MaybeRedirectToApproval {
1277 Path => $HTML::Mason::Commands::m->request_comp->path,
1283 return unless $ENV{REQUEST_METHOD} eq 'GET';
1285 my $id = $args{ARGSRef}->{id};
1288 and RT->Config->Get('ForceApprovalsView')
1289 and not $args{Path} =~ /$args{Whitelist}/)
1291 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1294 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1295 MaybeRedirectForResults(
1296 Path => "/Approvals/Display.html",
1298 Anchor => $args{ARGSRef}->{Anchor},
1299 Arguments => $args{ARGSRef},
1305 =head2 CreateTicket ARGS
1307 Create a new ticket, using Mason's %ARGS. returns @results.
1316 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1318 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1319 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1320 Abort('Queue not found');
1323 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1324 Abort('You have no permission to create tickets in that queue.');
1328 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1329 $due = RT::Date->new( $session{'CurrentUser'} );
1330 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1333 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1334 $starts = RT::Date->new( $session{'CurrentUser'} );
1335 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1338 my $sigless = RT::Interface::Web::StripContent(
1339 Content => $ARGS{Content},
1340 ContentType => $ARGS{ContentType},
1341 StripSignature => 1,
1342 CurrentUser => $session{'CurrentUser'},
1345 my $MIMEObj = MakeMIMEEntity(
1346 Subject => $ARGS{'Subject'},
1347 From => $ARGS{'From'},
1350 Type => $ARGS{'ContentType'},
1353 if ( $ARGS{'Attachments'} ) {
1354 my $rv = $MIMEObj->make_multipart;
1355 $RT::Logger->error("Couldn't make multipart message")
1356 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1358 foreach ( values %{ $ARGS{'Attachments'} } ) {
1360 $RT::Logger->error("Couldn't add empty attachemnt");
1363 $MIMEObj->add_part($_);
1367 foreach my $argument (qw(Encrypt Sign)) {
1368 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 )
1369 if defined $ARGS{$argument};
1373 Type => $ARGS{'Type'} || 'ticket',
1374 Queue => $ARGS{'Queue'},
1375 Owner => $ARGS{'Owner'},
1378 Requestor => $ARGS{'Requestors'},
1380 AdminCc => $ARGS{'AdminCc'},
1381 InitialPriority => $ARGS{'InitialPriority'},
1382 FinalPriority => $ARGS{'FinalPriority'},
1383 TimeLeft => $ARGS{'TimeLeft'},
1384 TimeEstimated => $ARGS{'TimeEstimated'},
1385 TimeWorked => $ARGS{'TimeWorked'},
1386 Subject => $ARGS{'Subject'},
1387 Status => $ARGS{'Status'},
1388 Due => $due ? $due->ISO : undef,
1389 Starts => $starts ? $starts->ISO : undef,
1394 foreach my $type (qw(Requestor Cc AdminCc)) {
1395 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1396 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1398 $create_args{TransSquelchMailTo} = \@txn_squelch
1401 if ( $ARGS{'AttachTickets'} ) {
1402 require RT::Action::SendEmail;
1403 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1404 ref $ARGS{'AttachTickets'}
1405 ? @{ $ARGS{'AttachTickets'} }
1406 : ( $ARGS{'AttachTickets'} ) );
1409 foreach my $arg ( keys %ARGS ) {
1410 next if $arg =~ /-(?:Magic|Category)$/;
1412 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1413 $create_args{$arg} = $ARGS{$arg};
1416 # Object-RT::Ticket--CustomField-3-Values
1417 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1420 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1422 unless ( $cf->id ) {
1423 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1427 if ( $arg =~ /-Upload$/ ) {
1428 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1432 my $type = $cf->Type;
1435 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1436 @values = @{ $ARGS{$arg} };
1437 } elsif ( $type =~ /text/i ) {
1438 @values = ( $ARGS{$arg} );
1440 no warnings 'uninitialized';
1441 @values = split /\r*\n/, $ARGS{$arg};
1443 @values = grep length, map {
1449 grep defined, @values;
1451 $create_args{"CustomField-$cfid"} = \@values;
1455 # turn new link lists into arrays, and pass in the proper arguments
1457 'new-DependsOn' => 'DependsOn',
1458 'DependsOn-new' => 'DependedOnBy',
1459 'new-MemberOf' => 'Parents',
1460 'MemberOf-new' => 'Children',
1461 'new-RefersTo' => 'RefersTo',
1462 'RefersTo-new' => 'ReferredToBy',
1464 foreach my $key ( keys %map ) {
1465 next unless $ARGS{$key};
1466 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1470 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1475 push( @Actions, split( "\n", $ErrMsg ) );
1476 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1477 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1479 return ( $Ticket, @Actions );
1485 =head2 LoadTicket id
1487 Takes a ticket id as its only variable. if it's handed an array, it takes
1490 Returns an RT::Ticket object as the current user.
1497 if ( ref($id) eq "ARRAY" ) {
1502 Abort("No ticket specified");
1505 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1507 unless ( $Ticket->id ) {
1508 Abort("Could not load ticket $id");
1515 =head2 ProcessUpdateMessage
1517 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1519 Don't write message if it only contains current user's signature and
1520 SkipSignatureOnly argument is true. Function anyway adds attachments
1521 and updates time worked field even if skips message. The default value
1526 sub ProcessUpdateMessage {
1531 SkipSignatureOnly => 1,
1535 if ( $args{ARGSRef}->{'UpdateAttachments'}
1536 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1538 delete $args{ARGSRef}->{'UpdateAttachments'};
1541 # Strip the signature
1542 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1543 Content => $args{ARGSRef}->{UpdateContent},
1544 ContentType => $args{ARGSRef}->{UpdateContentType},
1545 StripSignature => $args{SkipSignatureOnly},
1546 CurrentUser => $args{'TicketObj'}->CurrentUser,
1549 # If, after stripping the signature, we have no message, move the
1550 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1551 # ProcessBasics can deal -- then bail out.
1552 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1553 and not length $args{ARGSRef}->{'UpdateContent'} )
1555 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1556 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1561 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1562 $args{ARGSRef}->{'UpdateSubject'} = undef;
1565 my $Message = MakeMIMEEntity(
1566 Subject => $args{ARGSRef}->{'UpdateSubject'},
1567 Body => $args{ARGSRef}->{'UpdateContent'},
1568 Type => $args{ARGSRef}->{'UpdateContentType'},
1571 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1572 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1574 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1575 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1576 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1578 $old_txn = $args{TicketObj}->Transactions->First();
1581 if ( my $msg = $old_txn->Message->First ) {
1582 RT::Interface::Email::SetInReplyTo(
1583 Message => $Message,
1588 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1589 $Message->make_multipart;
1590 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1593 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1594 require RT::Action::SendEmail;
1595 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1596 ref $args{ARGSRef}->{'AttachTickets'}
1597 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1598 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1601 my %txn_customfields;
1603 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1604 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1605 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1609 my %message_args = (
1610 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
1611 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
1612 MIMEObj => $Message,
1613 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1614 CustomFields => \%txn_customfields,
1617 _ProcessUpdateMessageRecipients(
1618 MessageArgs => \%message_args,
1623 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1624 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1625 push( @results, $Description );
1626 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1627 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1628 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1629 push( @results, $Description );
1630 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1633 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1638 sub _ProcessUpdateMessageRecipients {
1642 MessageArgs => undef,
1646 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1647 my $cc = $args{ARGSRef}->{'UpdateCc'};
1649 my $message_args = $args{MessageArgs};
1651 $message_args->{CcMessageTo} = $cc;
1652 $message_args->{BccMessageTo} = $bcc;
1655 foreach my $type (qw(Cc AdminCc)) {
1656 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1657 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
1658 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1659 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1662 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1663 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
1664 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1668 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
1669 $message_args->{SquelchMailTo} = \@txn_squelch
1672 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1673 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1674 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1676 my $var = ucfirst($1) . 'MessageTo';
1678 if ( $message_args->{$var} ) {
1679 $message_args->{$var} .= ", $value";
1681 $message_args->{$var} = $value;
1687 =head2 MakeMIMEEntity PARAMHASH
1689 Takes a paramhash Subject, Body and AttachmentFieldName.
1691 Also takes Form, Cc and Type as optional paramhash keys.
1693 Returns a MIME::Entity.
1697 sub MakeMIMEEntity {
1699 #TODO document what else this takes.
1705 AttachmentFieldName => undef,
1709 my $Message = MIME::Entity->build(
1710 Type => 'multipart/mixed',
1711 "Message-Id" => RT::Interface::Email::GenMessageId,
1712 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1713 grep defined $args{$_}, qw(Subject From Cc)
1716 if ( defined $args{'Body'} && length $args{'Body'} ) {
1718 # Make the update content have no 'weird' newlines in it
1719 $args{'Body'} =~ s/\r\n/\n/gs;
1722 Type => $args{'Type'} || 'text/plain',
1724 Data => $args{'Body'},
1728 if ( $args{'AttachmentFieldName'} ) {
1730 my $cgi_object = $m->cgi_object;
1731 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
1732 if ( defined $filehandle && length $filehandle ) {
1734 my ( @content, $buffer );
1735 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1736 push @content, $buffer;
1739 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1741 my $filename = "$filehandle";
1742 $filename =~ s{^.*[\\/]}{};
1745 Type => $uploadinfo->{'Content-Type'},
1746 Filename => $filename,
1749 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1750 $Message->head->set( 'Subject' => $filename );
1753 # Attachment parts really shouldn't get a Message-ID
1754 $Message->head->delete('Message-ID');
1758 $Message->make_singlepart;
1760 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1768 =head2 ParseDateToISO
1770 Takes a date in an arbitrary format.
1771 Returns an ISO date and time in GMT
1775 sub ParseDateToISO {
1778 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1780 Format => 'unknown',
1783 return ( $date_obj->ISO );
1788 sub ProcessACLChanges {
1789 my $ARGSref = shift;
1793 foreach my $arg ( keys %$ARGSref ) {
1794 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1796 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1799 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1800 @rights = @{ $ARGSref->{$arg} };
1802 @rights = $ARGSref->{$arg};
1804 @rights = grep $_, @rights;
1805 next unless @rights;
1807 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1808 $principal->Load($principal_id);
1811 if ( $object_type eq 'RT::System' ) {
1813 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1814 $obj = $object_type->new( $session{'CurrentUser'} );
1815 $obj->Load($object_id);
1816 unless ( $obj->id ) {
1817 $RT::Logger->error("couldn't load $object_type #$object_id");
1821 $RT::Logger->error("object type '$object_type' is incorrect");
1822 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1826 foreach my $right (@rights) {
1827 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1828 push( @results, $msg );
1838 ProcessACLs expects values from a series of checkboxes that describe the full
1839 set of rights a principal should have on an object.
1841 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
1842 instead of with the prefixes Grant/RevokeRight. Each input should be an array
1843 listing the rights the principal should have, and ProcessACLs will modify the
1844 current rights to match. Additionally, the previously unused CheckACL input
1845 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
1846 rights are removed from a principal and as such no SetRights input is
1852 my $ARGSref = shift;
1853 my (%state, @results);
1855 my $CheckACL = $ARGSref->{'CheckACL'};
1856 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
1858 # Check if we want to grant rights to a previously rights-less user
1859 for my $type (qw(user group)) {
1860 my $key = "AddPrincipalForRights-$type";
1862 next unless $ARGSref->{$key};
1865 if ( $type eq 'user' ) {
1866 $principal = RT::User->new( $session{'CurrentUser'} );
1867 $principal->LoadByCol( Name => $ARGSref->{$key} );
1870 $principal = RT::Group->new( $session{'CurrentUser'} );
1871 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
1874 unless ($principal->PrincipalId) {
1875 push @results, loc("Couldn't load the specified principal");
1879 my $principal_id = $principal->PrincipalId;
1881 # Turn our addprincipal rights spec into a real one
1882 for my $arg (keys %$ARGSref) {
1883 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
1885 my $tuple = "$principal_id-$1";
1886 my $key = "SetRights-$tuple";
1888 # If we have it already, that's odd, but merge them
1889 if (grep { $_ eq $tuple } @check) {
1890 $ARGSref->{$key} = [
1891 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
1892 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
1895 $ARGSref->{$key} = $ARGSref->{$arg};
1896 push @check, $tuple;
1901 # Build our rights state for each Principal-Object tuple
1902 foreach my $arg ( keys %$ARGSref ) {
1903 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
1906 my $value = $ARGSref->{$arg};
1907 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
1908 next unless @rights;
1910 $state{$tuple} = { map { $_ => 1 } @rights };
1913 foreach my $tuple (List::MoreUtils::uniq @check) {
1914 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
1916 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
1918 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1919 $principal->Load($principal_id);
1922 if ( $object_type eq 'RT::System' ) {
1924 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1925 $obj = $object_type->new( $session{'CurrentUser'} );
1926 $obj->Load($object_id);
1927 unless ( $obj->id ) {
1928 $RT::Logger->error("couldn't load $object_type #$object_id");
1932 $RT::Logger->error("object type '$object_type' is incorrect");
1933 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1937 my $acls = RT::ACL->new($session{'CurrentUser'});
1938 $acls->LimitToObject( $obj );
1939 $acls->LimitToPrincipal( Id => $principal_id );
1941 while ( my $ace = $acls->Next ) {
1942 my $right = $ace->RightName;
1944 # Has right and should have right
1945 next if delete $state{$tuple}->{$right};
1947 # Has right and shouldn't have right
1948 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
1949 push @results, $msg;
1952 # For everything left, they don't have the right but they should
1953 for my $right (keys %{ $state{$tuple} || {} }) {
1954 delete $state{$tuple}->{$right};
1955 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
1956 push @results, $msg;
1959 # Check our state for leftovers
1960 if ( keys %{ $state{$tuple} || {} } ) {
1961 my $missed = join '|', %{$state{$tuple} || {}};
1963 "Uh-oh, it looks like we somehow missed a right in "
1964 ."ProcessACLs. Here's what was leftover: $missed"
1975 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1977 @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.
1979 Returns an array of success/failure messages
1983 sub UpdateRecordObject {
1986 AttributesRef => undef,
1988 AttributePrefix => undef,
1992 my $Object = $args{'Object'};
1993 my @results = $Object->Update(
1994 AttributesRef => $args{'AttributesRef'},
1995 ARGSRef => $args{'ARGSRef'},
1996 AttributePrefix => $args{'AttributePrefix'},
2004 sub ProcessCustomFieldUpdates {
2006 CustomFieldObj => undef,
2011 my $Object = $args{'CustomFieldObj'};
2012 my $ARGSRef = $args{'ARGSRef'};
2014 my @attribs = qw(Name Type Description Queue SortOrder);
2015 my @results = UpdateRecordObject(
2016 AttributesRef => \@attribs,
2021 my $prefix = "CustomField-" . $Object->Id;
2022 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2023 my ( $addval, $addmsg ) = $Object->AddValue(
2024 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2025 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2026 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2028 push( @results, $addmsg );
2032 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2033 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2034 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2036 foreach my $id (@delete_values) {
2037 next unless defined $id;
2038 my ( $err, $msg ) = $Object->DeleteValue($id);
2039 push( @results, $msg );
2042 my $vals = $Object->Values();
2043 while ( my $cfv = $vals->Next() ) {
2044 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2045 if ( $cfv->SortOrder != $so ) {
2046 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2047 push( @results, $msg );
2057 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2059 Returns an array of results messages.
2063 sub ProcessTicketBasics {
2071 my $TicketObj = $args{'TicketObj'};
2072 my $ARGSRef = $args{'ARGSRef'};
2074 my $OrigOwner = $TicketObj->Owner;
2089 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2090 for my $field (qw(Queue Owner)) {
2091 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2092 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2093 my $temp = $class->new(RT->SystemUser);
2094 $temp->Load( $ARGSRef->{$field} );
2096 $ARGSRef->{$field} = $temp->id;
2101 # Status isn't a field that can be set to a null value.
2102 # RT core complains if you try
2103 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2105 my @results = UpdateRecordObject(
2106 AttributesRef => \@attribs,
2107 Object => $TicketObj,
2108 ARGSRef => $ARGSRef,
2111 # We special case owner changing, so we can use ForceOwnerChange
2112 if ( $ARGSRef->{'Owner'}
2113 && $ARGSRef->{'Owner'} !~ /\D/
2114 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2116 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2117 $ChownType = "Force";
2123 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2124 push( @results, $msg );
2132 sub ProcessTicketReminders {
2139 my $Ticket = $args{'TicketObj'};
2140 my $args = $args{'ARGSRef'};
2143 my $reminder_collection = $Ticket->Reminders->Collection;
2145 if ( $args->{'update-reminders'} ) {
2146 while ( my $reminder = $reminder_collection->Next ) {
2147 if ( $reminder->Status ne 'resolved' && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2148 $Ticket->Reminders->Resolve($reminder);
2150 elsif ( $reminder->Status eq 'resolved' && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2151 $Ticket->Reminders->Open($reminder);
2154 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2155 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2158 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2159 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2162 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2163 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2165 Format => 'unknown',
2166 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2168 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2169 $reminder->SetDue( $DateObj->ISO );
2175 if ( $args->{'NewReminder-Subject'} ) {
2176 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2178 Format => 'unknown',
2179 Value => $args->{'NewReminder-Due'}
2181 my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add(
2182 Subject => $args->{'NewReminder-Subject'},
2183 Owner => $args->{'NewReminder-Owner'},
2184 Due => $due_obj->ISO
2186 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2191 sub ProcessTicketCustomFieldUpdates {
2193 $args{'Object'} = delete $args{'TicketObj'};
2194 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2196 # Build up a list of objects that we want to work with
2197 my %custom_fields_to_mod;
2198 foreach my $arg ( keys %$ARGSRef ) {
2199 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2200 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2201 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2202 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2203 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2204 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2208 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2211 sub ProcessObjectCustomFieldUpdates {
2213 my $ARGSRef = $args{'ARGSRef'};
2216 # Build up a list of objects that we want to work with
2217 my %custom_fields_to_mod;
2218 foreach my $arg ( keys %$ARGSRef ) {
2220 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2221 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2223 # For each of those objects, find out what custom fields we want to work with.
2224 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2227 # For each of those objects
2228 foreach my $class ( keys %custom_fields_to_mod ) {
2229 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2230 my $Object = $args{'Object'};
2231 $Object = $class->new( $session{'CurrentUser'} )
2232 unless $Object && ref $Object eq $class;
2234 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2235 unless ( $Object->id ) {
2236 $RT::Logger->warning("Couldn't load object $class #$id");
2240 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2241 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2242 $CustomFieldObj->LoadById($cf);
2243 unless ( $CustomFieldObj->id ) {
2244 $RT::Logger->warning("Couldn't load custom field #$cf");
2248 _ProcessObjectCustomFieldUpdates(
2249 Prefix => "Object-$class-$id-CustomField-$cf-",
2251 CustomField => $CustomFieldObj,
2252 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2260 sub _ProcessObjectCustomFieldUpdates {
2262 my $cf = $args{'CustomField'};
2263 my $cf_type = $cf->Type || '';
2265 # Remove blank Values since the magic field will take care of this. Sometimes
2266 # the browser gives you a blank value which causes CFs to be processed twice
2267 if ( defined $args{'ARGS'}->{'Values'}
2268 && !length $args{'ARGS'}->{'Values'}
2269 && $args{'ARGS'}->{'Values-Magic'} )
2271 delete $args{'ARGS'}->{'Values'};
2275 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2277 # skip category argument
2278 next if $arg eq 'Category';
2281 next if $arg eq 'Value-TimeUnits';
2283 # since http won't pass in a form element with a null value, we need
2285 if ( $arg eq 'Values-Magic' ) {
2287 # We don't care about the magic, if there's really a values element;
2288 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2289 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2291 # "Empty" values does not mean anything for Image and Binary fields
2292 next if $cf_type =~ /^(?:Image|Binary)$/;
2295 $args{'ARGS'}->{'Values'} = undef;
2299 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2300 @values = @{ $args{'ARGS'}->{$arg} };
2301 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2302 @values = ( $args{'ARGS'}->{$arg} );
2304 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2305 if defined $args{'ARGS'}->{$arg};
2307 @values = grep length, map {
2313 grep defined, @values;
2315 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2316 foreach my $value (@values) {
2317 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2321 push( @results, $msg );
2323 } elsif ( $arg eq 'Upload' ) {
2324 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2325 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2326 push( @results, $msg );
2327 } elsif ( $arg eq 'DeleteValues' ) {
2328 foreach my $value (@values) {
2329 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2333 push( @results, $msg );
2335 } elsif ( $arg eq 'DeleteValueIds' ) {
2336 foreach my $value (@values) {
2337 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2341 push( @results, $msg );
2343 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2344 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2347 foreach my $value (@values) {
2348 if ( my $entry = $cf_values->HasEntry($value) ) {
2349 $values_hash{ $entry->id } = 1;
2353 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2357 push( @results, $msg );
2358 $values_hash{$val} = 1 if $val;
2361 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2362 return @results if ( $cf->Type eq 'Date' && ! @values );
2364 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2365 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2367 $cf_values->RedoSearch;
2368 while ( my $cf_value = $cf_values->Next ) {
2369 next if $values_hash{ $cf_value->id };
2371 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2373 ValueId => $cf_value->id
2375 push( @results, $msg );
2377 } elsif ( $arg eq 'Values' ) {
2378 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2380 # keep everything up to the point of difference, delete the rest
2382 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2383 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2392 # now add/replace extra things, if any
2393 foreach my $value (@values) {
2394 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2398 push( @results, $msg );
2403 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2404 $cf->Name, ref $args{'Object'},
2414 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2416 Returns an array of results messages.
2420 sub ProcessTicketWatchers {
2428 my $Ticket = $args{'TicketObj'};
2429 my $ARGSRef = $args{'ARGSRef'};
2433 foreach my $key ( keys %$ARGSRef ) {
2435 # Delete deletable watchers
2436 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2437 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2441 push @results, $msg;
2444 # Delete watchers in the simple style demanded by the bulk manipulator
2445 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2446 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2447 Email => $ARGSRef->{$key},
2450 push @results, $msg;
2453 # Add new wathchers by email address
2454 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2455 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2458 #They're in this order because otherwise $1 gets clobbered :/
2459 my ( $code, $msg ) = $Ticket->AddWatcher(
2460 Type => $ARGSRef->{$key},
2461 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2463 push @results, $msg;
2466 #Add requestors in the simple style demanded by the bulk manipulator
2467 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2468 my ( $code, $msg ) = $Ticket->AddWatcher(
2470 Email => $ARGSRef->{$key}
2472 push @results, $msg;
2475 # Add new watchers by owner
2476 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2477 my $principal_id = $1;
2478 my $form = $ARGSRef->{$key};
2479 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2480 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2482 my ( $code, $msg ) = $Ticket->AddWatcher(
2484 PrincipalId => $principal_id
2486 push @results, $msg;
2496 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2498 Returns an array of results messages.
2502 sub ProcessTicketDates {
2509 my $Ticket = $args{'TicketObj'};
2510 my $ARGSRef = $args{'ARGSRef'};
2515 my @date_fields = qw(
2523 #Run through each field in this list. update the value if apropriate
2524 foreach my $field (@date_fields) {
2525 next unless exists $ARGSRef->{ $field . '_Date' };
2526 next if $ARGSRef->{ $field . '_Date' } eq '';
2530 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2532 Format => 'unknown',
2533 Value => $ARGSRef->{ $field . '_Date' }
2536 my $obj = $field . "Obj";
2537 if ( ( defined $DateObj->Unix )
2538 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2540 my $method = "Set$field";
2541 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2542 push @results, "$msg";
2552 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2554 Returns an array of results messages.
2558 sub ProcessTicketLinks {
2565 my $Ticket = $args{'TicketObj'};
2566 my $ARGSRef = $args{'ARGSRef'};
2568 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2570 #Merge if we need to
2571 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2572 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2573 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2574 push @results, $msg;
2581 sub ProcessRecordLinks {
2588 my $Record = $args{'RecordObj'};
2589 my $ARGSRef = $args{'ARGSRef'};
2593 # Delete links that are gone gone gone.
2594 foreach my $arg ( keys %$ARGSRef ) {
2595 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2600 my ( $val, $msg ) = $Record->DeleteLink(
2606 push @results, $msg;
2612 my @linktypes = qw( DependsOn MemberOf RefersTo );
2614 foreach my $linktype (@linktypes) {
2615 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2616 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2617 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2619 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2621 $luri =~ s/\s+$//; # Strip trailing whitespace
2622 my ( $val, $msg ) = $Record->AddLink(
2626 push @results, $msg;
2629 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2630 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2631 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2633 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2635 my ( $val, $msg ) = $Record->AddLink(
2640 push @results, $msg;
2648 =head2 _UploadedFile ( $arg );
2650 Takes a CGI parameter name; if a file is uploaded under that name,
2651 return a hash reference suitable for AddCustomFieldValue's use:
2652 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2654 Returns C<undef> if no files were uploaded in the C<$arg> field.
2660 my $cgi_object = $m->cgi_object;
2661 my $fh = $cgi_object->upload($arg) or return undef;
2662 my $upload_info = $cgi_object->uploadInfo($fh);
2664 my $filename = "$fh";
2665 $filename =~ s#^.*[\\/]##;
2670 LargeContent => do { local $/; scalar <$fh> },
2671 ContentType => $upload_info->{'Content-Type'},
2675 sub GetColumnMapEntry {
2676 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2678 # deal with the simplest thing first
2679 if ( $args{'Map'}{ $args{'Name'} } ) {
2680 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2684 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2685 return undef unless $args{'Map'}->{$mainkey};
2686 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2687 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2689 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2694 sub ProcessColumnMapValue {
2696 my %args = ( Arguments => [], Escape => 1, @_ );
2699 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2700 my @tmp = $value->( @{ $args{'Arguments'} } );
2701 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2702 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2703 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2704 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2709 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2713 =head2 GetPrincipalsMap OBJECT, CATEGORIES
2715 Returns an array suitable for passing to /Admin/Elements/EditRights with the
2716 principal collections mapped from the categories given.
2720 sub GetPrincipalsMap {
2725 my $system = RT::Groups->new($session{'CurrentUser'});
2726 $system->LimitToSystemInternalGroups();
2727 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2729 'System' => $system, # loc_left_pair
2734 my $groups = RT::Groups->new($session{'CurrentUser'});
2735 $groups->LimitToUserDefinedGroups();
2736 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2738 # Only show groups who have rights granted on this object
2739 $groups->WithGroupRight(
2742 IncludeSystemRights => 0,
2743 IncludeSubgroupMembers => 0,
2747 'User Groups' => $groups, # loc_left_pair
2752 my $roles = RT::Groups->new($session{'CurrentUser'});
2754 if ($object->isa('RT::System')) {
2755 $roles->LimitToRolesForSystem();
2757 elsif ($object->isa('RT::Queue')) {
2758 $roles->LimitToRolesForQueue($object->Id);
2761 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
2764 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
2766 'Roles' => $roles, # loc_left_pair
2771 my $Users = RT->PrivilegedUsers->UserMembersObj();
2772 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
2774 # Only show users who have rights granted on this object
2775 my $group_members = $Users->WhoHaveGroupRight(
2778 IncludeSystemRights => 0,
2779 IncludeSubgroupMembers => 0,
2782 # Limit to UserEquiv groups
2783 my $groups = $Users->NewAlias('Groups');
2787 ALIAS2 => $group_members,
2790 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
2791 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
2795 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
2798 'Users' => $Users, # loc_left_pair
2806 =head2 _load_container_object ( $type, $id );
2808 Instantiate container object for saving searches.
2812 sub _load_container_object {
2813 my ( $obj_type, $obj_id ) = @_;
2814 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2817 =head2 _parse_saved_search ( $arg );
2819 Given a serialization string for saved search, and returns the
2820 container object and the search id.
2824 sub _parse_saved_search {
2826 return unless $spec;
2827 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2834 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2837 =head2 ScrubHTML content
2839 Removes unsafe and undesired HTML from the passed content
2845 my $Content = shift;
2846 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2848 $Content = '' if !defined($Content);
2849 return $SCRUBBER->scrub($Content);
2854 Returns a new L<HTML::Scrubber> object. Override this if you insist on
2855 letting more HTML through.
2860 require HTML::Scrubber;
2861 my $scrubber = HTML::Scrubber->new();
2868 # Match http, ftp and relative urls
2869 # XXX: we also scrub format strings with this module then allow simple config options
2870 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2876 (?:(?:background-)?color: \s*
2877 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
2878 \#[a-f0-9]{3,6} | # #fff or #ffffff
2879 [\w\-]+ # green, light-blue, etc.
2881 text-align: \s* \w+ |
2882 font-size: \s* [\w.\-]+ |
2883 font-family: \s* [\w\s"',.\-]+ |
2884 font-weight: \s* [\w\-]+ |
2886 # MS Office styles, which are probably fine. If we don't, then any
2887 # associated styles in the same attribute get stripped.
2888 mso-[\w\-]+?: \s* [\w\s"',.\-]+
2890 +$ # one or more of these allowed properties from here 'till sunset
2894 $scrubber->deny(qw[*]);
2896 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]
2898 $scrubber->comment(0);
2905 Redispatches to L<RT::Interface::Web/EncodeJSON>
2910 RT::Interface::Web::EncodeJSON(@_);
2913 package RT::Interface::Web;
2914 RT::Base->_ImportOverlays();