1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2011 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::Session;
74 =head2 EscapeUTF8 SCALARREF
76 does a css-busting but minimalist escaping of whatever html you're passing in.
82 return unless defined $$ref;
87 $$ref =~ s/\(/(/g;
88 $$ref =~ s/\)/)/g;
97 =head2 EscapeURI SCALARREF
99 Escapes URI component according to RFC2396
105 return unless defined $$ref;
108 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
113 sub _encode_surrogates {
114 my $uni = $_[0] - 0x10000;
115 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
120 return unless defined $$ref;
122 $$ref = "'" . join('',
124 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
125 $_ <= 255 ? sprintf("\\x%02X", $_) :
126 $_ <= 65535 ? sprintf("\\u%04X", $_) :
127 sprintf("\\u%X\\u%X", _encode_surrogates($_))
128 } unpack('U*', $$ref))
132 # {{{ WebCanonicalizeInfo
134 =head2 WebCanonicalizeInfo();
136 Different web servers set different environmental varibles. This
137 function must return something suitable for REMOTE_USER. By default,
138 just downcase $ENV{'REMOTE_USER'}
142 sub WebCanonicalizeInfo {
143 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
148 # {{{ WebExternalAutoInfo
150 =head2 WebExternalAutoInfo($user);
152 Returns a hash of user attributes, used when WebExternalAuto is set.
156 sub WebExternalAutoInfo {
161 # default to making Privileged users, even if they specify
162 # some other default Attributes
163 if ( !$RT::AutoCreate
164 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
166 $user_info{'Privileged'} = 1;
169 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
171 # Populate fields with information from Unix /etc/passwd
173 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
174 $user_info{'Comments'} = $comments if defined $comments;
175 $user_info{'RealName'} = $realname if defined $realname;
176 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
178 # Populate fields with information from NT domain controller
181 # and return the wad of stuff
190 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
192 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
194 # Roll back any dangling transactions from a previous failed connection
195 $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth;
197 MaybeEnableSQLStatementLog();
199 # avoid reentrancy, as suggested by masonbook
200 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
202 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
203 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
206 PreprocessTimeUpdates($ARGS);
208 MaybeShowInstallModePage();
210 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
212 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
214 # Process session-related callbacks before any auth attempts
215 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
217 MaybeRejectPrivateComponentRequest();
219 MaybeShowNoAuthPage($ARGS);
221 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
223 _ForceLogout() unless _UserLoggedIn();
225 # Process per-page authentication callbacks
226 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
228 unless ( _UserLoggedIn() ) {
231 # Authenticate if the user is trying to login via user/pass query args
232 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
235 my $m = $HTML::Mason::Commands::m;
237 # REST urls get a special 401 response
238 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
239 $HTML::Mason::Commands::r->content_type("text/plain");
240 $m->error_format("text");
241 $m->out("RT/$RT::VERSION 401 Credentials required\n");
242 $m->out("\n$msg\n") if $msg;
245 # Specially handle /index.html so that we get a nicer URL
246 elsif ( $m->request_comp->path eq '/index.html' ) {
247 my $next = SetNextPage(RT->Config->Get('WebURL'));
248 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
252 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
257 MaybeShowInterstitialCSRFPage($ARGS);
259 # now it applies not only to home page, but any dashboard that can be used as a workspace
260 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
261 if ( $ARGS->{'HomeRefreshInterval'} );
263 # Process per-page global callbacks
264 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
266 ShowRequestedPage($ARGS);
267 LogRecordedSQLStatements();
269 # Process per-page final cleanup callbacks
270 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
275 delete $HTML::Mason::Commands::session{'CurrentUser'};
279 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
287 =head2 LoginError ERROR
289 Pushes a login error into the Actions session store and returns the hash key.
295 my $key = Digest::MD5::md5_hex( rand(1024) );
296 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
297 $HTML::Mason::Commands::session{'i'}++;
301 =head2 SetNextPage [PATH]
303 Intuits and stashes the next page in the sesssion hash. If PATH is
304 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
310 my $next = shift || IntuitNextPage();
311 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
313 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
314 $HTML::Mason::Commands::session{'i'}++;
319 =head2 TangentForLogin [HASH]
321 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
322 the next page. Optionally takes a hash which is dumped into query params.
326 sub TangentForLogin {
327 my $hash = SetNextPage();
328 my %query = (@_, next => $hash);
329 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
330 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
334 =head2 TangentForLoginWithError ERROR
336 Localizes the passed error message, stashes it with L<LoginError> and then
337 calls L<TangentForLogin> with the appropriate results key.
341 sub TangentForLoginWithError {
342 my $key = LoginError(HTML::Mason::Commands::loc(@_));
343 TangentForLogin( results => $key );
346 =head2 IntuitNextPage
348 Attempt to figure out the path to which we should return the user after a
349 tangent. The current request URL is used, or failing that, the C<WebURL>
350 configuration variable.
357 # This includes any query parameters. Redirect will take care of making
358 # it an absolute URL.
359 if ($ENV{'REQUEST_URI'}) {
360 $req_uri = $ENV{'REQUEST_URI'};
362 # collapse multiple leading slashes so the first part doesn't look like
363 # a hostname of a schema-less URI
364 $req_uri =~ s{^/+}{/};
367 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
370 my $uri = URI->new($next);
372 # You get undef scheme with a relative uri like "/Search/Build.html"
373 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
374 $next = RT->Config->Get('WebURL');
377 # Make sure we're logging in to the same domain
378 # You can get an undef authority with a relative uri like "index.html"
379 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
380 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
381 $next = RT->Config->Get('WebURL');
387 =head2 MaybeShowInstallModePage
389 This function, called exclusively by RT's autohandler, dispatches
390 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
392 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
396 sub MaybeShowInstallModePage {
397 return unless RT->InstallMode;
399 my $m = $HTML::Mason::Commands::m;
400 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
402 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
403 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
410 =head2 MaybeShowNoAuthPage \%ARGS
412 This function, called exclusively by RT's autohandler, dispatches
413 a request to the page a user requested (but only if it matches the "noauth" regex.
415 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
419 sub MaybeShowNoAuthPage {
422 my $m = $HTML::Mason::Commands::m;
424 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
426 # Don't show the login page to logged in users
427 Redirect(RT->Config->Get('WebURL'))
428 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
430 # If it's a noauth file, don't ask for auth.
431 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
435 =head2 MaybeRejectPrivateComponentRequest
437 This function will reject calls to private components, like those under
438 C</Elements>. If the requested path is a private component then we will
439 abort with a C<403> error.
443 sub MaybeRejectPrivateComponentRequest {
444 my $m = $HTML::Mason::Commands::m;
445 my $path = $m->request_comp->path;
447 # We do not check for dhandler here, because requesting our dhandlers
448 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
454 _elements | # mobile UI
456 autohandler | # requesting this directly is suspicious
457 l (_unsafe)? ) # loc component
458 ( $ | / ) # trailing slash or end of path
460 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
463 warn "rejecting private component $path\n";
470 =head2 ShowRequestedPage \%ARGS
472 This function, called exclusively by RT's autohandler, dispatches
473 a request to the page a user requested (making sure that unpriviled users
474 can only see self-service pages.
478 sub ShowRequestedPage {
481 my $m = $HTML::Mason::Commands::m;
483 # Ensure that the cookie that we send is up-to-date, in case the
484 # session-id has been modified in any way
487 # If the user isn't privileged, they can only see SelfService
488 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
490 # if the user is trying to access a ticket, redirect them
491 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
492 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
495 # otherwise, drop the user at the SelfService default page
496 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
497 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
500 # if user is in SelfService dir let him do anything
502 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
505 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
510 sub AttemptExternalAuth {
513 return unless ( RT->Config->Get('WebExternalAuth') );
515 my $user = $ARGS->{user};
516 my $m = $HTML::Mason::Commands::m;
518 # If RT is configured for external auth, let's go through and get REMOTE_USER
520 # do we actually have a REMOTE_USER equivlent?
521 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
522 my $orig_user = $user;
524 $user = RT::Interface::Web::WebCanonicalizeInfo();
525 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
527 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
528 my $NodeName = Win32::NodeName();
529 $user =~ s/^\Q$NodeName\E\\//i;
532 InstantiateNewSession() unless _UserLoggedIn;
533 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
534 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
536 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
538 # Create users on-the-fly
539 my $UserObj = RT::User->new($RT::SystemUser);
540 my ( $val, $msg ) = $UserObj->Create(
541 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
548 # now get user specific information, to better create our user.
549 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
551 # set the attributes that have been defined.
552 foreach my $attribute ( $UserObj->WritableAttributes ) {
554 Attribute => $attribute,
556 UserInfo => $new_user_info,
557 CallbackName => 'NewUser',
558 CallbackPage => '/autohandler'
560 my $method = "Set$attribute";
561 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
563 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
566 # we failed to successfully create the user. abort abort abort.
567 delete $HTML::Mason::Commands::session{'CurrentUser'};
569 if (RT->Config->Get('WebFallbackToInternalAuth')) {
570 TangentForLoginWithError('Cannot create user: [_1]', $msg);
577 if ( _UserLoggedIn() ) {
578 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
580 delete $HTML::Mason::Commands::session{'CurrentUser'};
583 if ( RT->Config->Get('WebExternalOnly') ) {
584 TangentForLoginWithError('You are not an authorized user');
587 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
588 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
589 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
590 TangentForLoginWithError('You are not an authorized user');
594 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
595 # XXX: we must return AUTH_REQUIRED status or we fallback to
596 # internal auth here too.
597 delete $HTML::Mason::Commands::session{'CurrentUser'}
598 if defined $HTML::Mason::Commands::session{'CurrentUser'};
602 sub AttemptPasswordAuthentication {
604 return unless defined $ARGS->{user} && defined $ARGS->{pass};
606 my $user_obj = RT::CurrentUser->new();
607 $user_obj->Load( $ARGS->{user} );
609 my $m = $HTML::Mason::Commands::m;
611 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
612 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
613 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
614 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
617 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
619 # It's important to nab the next page from the session before we blow
621 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
623 InstantiateNewSession();
624 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
626 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
628 # Really the only time we don't want to redirect here is if we were
629 # passed user and pass as query params in the URL.
633 elsif ($ARGS->{'next'}) {
634 # Invalid hash, but still wants to go somewhere, take them to /
635 Redirect(RT->Config->Get('WebURL'));
638 return (1, HTML::Mason::Commands::loc('Logged in'));
642 =head2 LoadSessionFromCookie
644 Load or setup a session cookie for the current user.
648 sub _SessionCookieName {
649 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
650 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
654 sub LoadSessionFromCookie {
656 my %cookies = CGI::Cookie->fetch;
657 my $cookiename = _SessionCookieName();
658 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
659 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
660 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
661 undef $cookies{$cookiename};
663 if ( int RT->Config->Get('AutoLogoff') ) {
664 my $now = int( time / 60 );
665 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
667 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
668 InstantiateNewSession();
671 # save session on each request when AutoLogoff is turned on
672 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
676 sub InstantiateNewSession {
677 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
678 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
682 sub SendSessionCookie {
683 my $cookie = CGI::Cookie->new(
684 -name => _SessionCookieName(),
685 -value => $HTML::Mason::Commands::session{_session_id},
686 -path => RT->Config->Get('WebPath'),
687 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
688 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
691 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
696 This routine ells the current user's browser to redirect to URL.
697 Additionally, it unties the user's currently active session, helping to avoid
698 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
699 a cached DBI statement handle twice at the same time.
704 my $redir_to = shift;
705 untie $HTML::Mason::Commands::session;
706 my $uri = URI->new($redir_to);
707 my $server_uri = URI->new( RT->Config->Get('WebURL') );
709 # Make relative URIs absolute from the server host and scheme
710 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
711 if (not defined $uri->host) {
712 $uri->host($server_uri->host);
713 $uri->port($server_uri->port);
716 # If the user is coming in via a non-canonical
717 # hostname, don't redirect them to the canonical host,
718 # it will just upset them (and invalidate their credentials)
719 # don't do this if $RT::CanoniaclRedirectURLs is true
720 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
721 && $uri->host eq $server_uri->host
722 && $uri->port eq $server_uri->port )
724 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
725 $uri->scheme('https');
727 $uri->scheme('http');
730 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
731 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
732 $uri->port( $ENV{'SERVER_PORT'} );
735 # not sure why, but on some systems without this call mason doesn't
736 # set status to 302, but 200 instead and people see blank pages
737 $HTML::Mason::Commands::r->status(302);
739 # Perlbal expects a status message, but Mason's default redirect status
740 # doesn't provide one. See also rt.cpan.org #36689.
741 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
743 $HTML::Mason::Commands::m->abort;
746 =head2 StaticFileHeaders
748 Send the browser a few headers to try to get it to (somewhat agressively)
749 cache RT's static Javascript and CSS files.
751 This routine could really use _accurate_ heuristics. (XXX TODO)
755 sub StaticFileHeaders {
756 my $date = RT::Date->new($RT::SystemUser);
759 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
761 # remove any cookie headers -- if it is cached publicly, it
762 # shouldn't include anyone's cookie!
763 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
765 # Expire things in a month.
766 $date->Set( Value => time + 30 * 24 * 60 * 60 );
767 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
769 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
770 # request, but we don't handle it and generate full reply again
771 # Last modified at server start time
772 # $date->Set( Value => $^T );
773 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
776 =head2 ComponentPathIsSafe PATH
778 Takes C<PATH> and returns a boolean indicating that the user-specified partial
779 component path is safe.
781 Currently "safe" means that the path does not start with a dot (C<.>) and does
782 not contain a slash-dot C</.>.
786 sub ComponentPathIsSafe {
789 return $path !~ m{(?:^|/)\.};
794 Takes a C<< Path => path >> and returns a boolean indicating that
795 the path is safely within RT's control or not. The path I<must> be
798 This function does not consult the filesystem at all; it is merely
799 a logical sanity checking of the path. This explicitly does not handle
800 symlinks; if you have symlinks in RT's webroot pointing outside of it,
801 then we assume you know what you are doing.
808 my $path = $args{Path};
810 # Get File::Spec to clean up extra /s, ./, etc
811 my $cleaned_up = File::Spec->canonpath($path);
813 if (!defined($cleaned_up)) {
814 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
818 # Forbid too many ..s. We can't just sum then check because
819 # "../foo/bar/baz" should be illegal even though it has more
820 # downdirs than updirs. So as soon as we get a negative score
821 # (which means "breaking out" of the top level) we reject the path.
823 my @components = split '/', $cleaned_up;
825 for my $component (@components) {
826 if ($component eq '..') {
829 $RT::Logger->info("Rejecting unsafe path: $path");
833 elsif ($component eq '.' || $component eq '') {
834 # these two have no effect on $score
844 =head2 SendStaticFile
846 Takes a File => path and a Type => Content-type
848 If Type isn't provided and File is an image, it will
849 figure out a sane Content-type, otherwise it will
850 send application/octet-stream
852 Will set caching headers using StaticFileHeaders
859 my $file = $args{File};
860 my $type = $args{Type};
861 my $relfile = $args{RelativeFile};
863 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
864 $HTML::Mason::Commands::r->status(400);
865 $HTML::Mason::Commands::m->abort;
868 $self->StaticFileHeaders();
871 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
873 $type =~ s/jpg/jpeg/gi;
875 $type ||= "application/octet-stream";
878 # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
879 # since we don't specify a charset
880 if ( $type =~ m{application/javascript} &&
881 $type !~ m{charset=([\w-]+)$} ) {
882 $type .= "; charset=utf-8";
884 $HTML::Mason::Commands::r->content_type($type);
885 open( my $fh, '<', $file ) or die "couldn't open file: $!";
889 $HTML::Mason::Commands::m->out($_) while (<$fh>);
890 $HTML::Mason::Commands::m->flush_buffer;
897 my $content = $args{Content};
898 return '' unless $content;
900 # Make the content have no 'weird' newlines in it
901 $content =~ s/\r+\n/\n/g;
903 my $return_content = $content;
905 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
906 my $sigonly = $args{StripSignature};
908 # massage content to easily detect if there's any real content
909 $content =~ s/\s+//g; # yes! remove all the spaces
911 # remove html version of spaces and newlines
912 $content =~ s! !!g;
913 $content =~ s!<br/?>!!g;
916 # Filter empty content when type is text/html
917 return '' if $html && $content !~ /\S/;
919 # If we aren't supposed to strip the sig, just bail now.
920 return $return_content unless $sigonly;
923 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
926 # Check for plaintext sig
927 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
929 # Check for html-formatted sig; we don't use EscapeUTF8 here
930 # because we want to precisely match the escaping that FCKEditor
931 # uses. see also 311223f5, which fixed this for 4.0
938 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
941 return $return_content;
949 # if they've passed multiple values, they'll be an array. if they've
950 # passed just one, a scalar whatever they are, mark them as utf8
953 ? Encode::is_utf8($_)
955 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
956 : ( $type eq 'ARRAY' )
957 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
959 : ( $type eq 'HASH' )
960 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
966 sub PreprocessTimeUpdates {
969 # Later in the code we use
970 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
971 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
972 # The call_next method pass through original arguments and if you have
973 # an argument with unicode key then in a next component you'll get two
974 # records in the args hash: one with key without UTF8 flag and another
975 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
976 # is copied from mason's source to get the same results as we get from
977 # call_next method, this feature is not documented, so we just leave it
978 # here to avoid possible side effects.
980 # This code canonicalizes time inputs in hours into minutes
981 foreach my $field ( keys %$ARGS ) {
982 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
984 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
985 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
986 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
987 $ARGS->{$local} *= 60;
989 delete $ARGS->{$field};
994 sub MaybeEnableSQLStatementLog {
996 my $log_sql_statements = RT->Config->Get('StatementLog');
998 if ($log_sql_statements) {
999 $RT::Handle->ClearSQLStatementLog;
1000 $RT::Handle->LogSQLStatements(1);
1005 sub LogRecordedSQLStatements {
1006 my $log_sql_statements = RT->Config->Get('StatementLog');
1008 return unless ($log_sql_statements);
1010 my @log = $RT::Handle->SQLStatementLog;
1011 $RT::Handle->ClearSQLStatementLog;
1012 for my $stmt (@log) {
1013 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1023 level => $log_sql_statements,
1025 . sprintf( "%.6f", $duration )
1027 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
1033 our %is_whitelisted_component = (
1034 # The RSS feed embeds an auth token in the path, but query
1035 # information for the search. Because it's a straight-up read, in
1036 # addition to embedding its own auth, it's fine.
1037 '/NoAuth/rss/dhandler' => 1,
1039 # IE doesn't send referer in window.open()
1040 # besides, as a harmless calendar select page, it's fine
1041 '/Helpers/CalPopup.html' => 1,
1043 # While both of these can be used for denial-of-service against RT
1044 # (construct a very inefficient query and trick lots of users into
1045 # running them against RT) it's incredibly useful to be able to link
1046 # to a search result or bookmark a result page.
1047 '/Search/Results.html' => 1,
1048 '/Search/Simple.html' => 1,
1051 sub IsCompCSRFWhitelisted {
1055 return 1 if $is_whitelisted_component{$comp};
1057 my %args = %{ $ARGS };
1059 # If the user specifies a *correct* user and pass then they are
1060 # golden. This acts on the presumption that external forms may
1061 # hardcode a username and password -- if a malicious attacker knew
1062 # both already, CSRF is the least of your problems.
1063 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1064 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1065 my $user_obj = RT::CurrentUser->new();
1066 $user_obj->Load($args{user});
1067 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1073 # Eliminate arguments that do not indicate an effectful request.
1074 # For example, "id" is acceptable because that is how RT retrieves a
1078 # If they have a valid results= from MaybeRedirectForResults, that's
1080 delete $args{results} if $args{results}
1081 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1083 # The homepage refresh, which uses the Refresh header, doesn't send
1084 # a referer in most browsers; whitelist the one parameter it reloads
1085 # with, HomeRefreshInterval, which is safe
1086 delete $args{HomeRefreshInterval};
1088 # If there are no arguments, then it's likely to be an idempotent
1089 # request, which are not susceptible to CSRF
1095 sub IsRefererCSRFWhitelisted {
1096 my $referer = _NormalizeHost(shift);
1097 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1098 $base_url = $base_url->host_port;
1101 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1102 push @$configs,$config;
1103 return 1 if $referer->host_port eq $config;
1106 return (0,$referer,$configs);
1109 =head3 _NormalizeHost
1111 Takes a URI and creates a URI object that's been normalized
1112 to handle common problems such as localhost vs 127.0.0.1
1116 sub _NormalizeHost {
1118 my $uri= URI->new(shift);
1119 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1125 sub IsPossibleCSRF {
1128 # If first request on this session is to a REST endpoint, then
1129 # whitelist the REST endpoints -- and explicitly deny non-REST
1130 # endpoints. We do this because using a REST cookie in a browser
1131 # would open the user to CSRF attacks to the REST endpoints.
1132 my $comp = $HTML::Mason::Commands::m->request_comp->path;
1133 $HTML::Mason::Commands::session{'REST'} = $comp =~ m{^/REST/\d+\.\d+/}
1134 unless defined $HTML::Mason::Commands::session{'REST'};
1136 if ($HTML::Mason::Commands::session{'REST'}) {
1137 return 0 if $comp =~ m{^/REST/\d+\.\d+/};
1139 This login session belongs to a REST client, and cannot be used to
1140 access non-REST interfaces of RT for security reasons.
1142 my $details = <<EOT;
1143 Please log out and back in to obtain a session for normal browsing. If
1144 you understand the security implications, disabling RT's CSRF protection
1145 will remove this restriction.
1148 HTML::Mason::Commands::Abort( $why, Details => $details );
1151 return 0 if IsCompCSRFWhitelisted( $comp, $ARGS );
1153 # if there is no Referer header then assume the worst
1155 "your browser did not supply a Referrer header", # loc
1156 ) if !$ENV{HTTP_REFERER};
1158 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1159 return 0 if $whitelisted;
1161 if ( @$configs > 1 ) {
1163 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1164 $browser->host_port,
1166 join(', ', @$configs) );
1170 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1171 $browser->host_port,
1175 sub ExpandCSRFToken {
1178 my $token = delete $ARGS->{CSRF_Token};
1179 return unless $token;
1181 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1182 return unless $data;
1183 return unless $data->{uri} eq $HTML::Mason::Commands::r->uri;
1185 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1186 return unless $user->ValidateAuthString( $data->{auth}, $token );
1188 %{$ARGS} = %{$data->{args}};
1190 # We explicitly stored file attachments with the request, but not in
1191 # the session yet, as that would itself be an attack. Put them into
1192 # the session now, so they'll be visible.
1193 if ($data->{attach}) {
1194 my $filename = $data->{attach}{filename};
1195 my $mime = $data->{attach}{mime};
1196 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1203 sub StoreRequestToken {
1206 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1207 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1209 auth => $user->GenerateAuthString( $token ),
1210 uri => $HTML::Mason::Commands::r->uri,
1213 if ($ARGS->{Attach}) {
1214 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1215 my $file_path = delete $ARGS->{'Attach'};
1217 filename => Encode::decode_utf8("$file_path"),
1218 mime => $attachment,
1222 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1223 $HTML::Mason::Commands::session{'i'}++;
1227 sub MaybeShowInterstitialCSRFPage {
1230 return unless RT->Config->Get('RestrictReferrer');
1232 # Deal with the form token provided by the interstitial, which lets
1233 # browsers which never set referer headers still use RT, if
1234 # painfully. This blows values into ARGS
1235 return if ExpandCSRFToken($ARGS);
1237 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1238 return if !$is_csrf;
1240 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1242 my $token = StoreRequestToken($ARGS);
1243 $HTML::Mason::Commands::m->comp(
1245 OriginalURL => $HTML::Mason::Commands::r->uri,
1246 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1249 # Calls abort, never gets here
1252 package HTML::Mason::Commands;
1254 use vars qw/$r $m %session/;
1260 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1261 with whatever it's called with. If there is no $session{'CurrentUser'},
1262 it creates a temporary user, so we have something to get a localisation handle
1269 if ( $session{'CurrentUser'}
1270 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1272 return ( $session{'CurrentUser'}->loc(@_) );
1275 RT::CurrentUser->new();
1279 return ( $u->loc(@_) );
1282 # pathetic case -- SystemUser is gone.
1291 =head2 loc_fuzzy STRING
1293 loc_fuzzy is for handling localizations of messages that may already
1294 contain interpolated variables, typically returned from libraries
1295 outside RT's control. It takes the message string and extracts the
1296 variable array automatically by matching against the candidate entries
1297 inside the lexicon file.
1304 if ( $session{'CurrentUser'}
1305 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1307 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1309 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1310 return ( $u->loc_fuzzy($msg) );
1317 # Error - calls Error and aborts
1322 if ( $session{'ErrorDocument'}
1323 && $session{'ErrorDocumentType'} )
1325 $r->content_type( $session{'ErrorDocumentType'} );
1326 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1329 $m->comp( "/Elements/Error", Why => $why, %args );
1336 # {{{ sub CreateTicket
1338 =head2 CreateTicket ARGS
1340 Create a new ticket, using Mason's %ARGS. returns @results.
1349 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1351 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1352 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1353 Abort('Queue not found');
1356 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1357 Abort('You have no permission to create tickets in that queue.');
1361 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1362 $due = new RT::Date( $session{'CurrentUser'} );
1363 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1366 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1367 $starts = new RT::Date( $session{'CurrentUser'} );
1368 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1371 my $sigless = RT::Interface::Web::StripContent(
1372 Content => $ARGS{Content},
1373 ContentType => $ARGS{ContentType},
1374 StripSignature => 1,
1375 CurrentUser => $session{'CurrentUser'},
1378 my $MIMEObj = MakeMIMEEntity(
1379 Subject => $ARGS{'Subject'},
1380 From => $ARGS{'From'},
1383 Type => $ARGS{'ContentType'},
1386 if ( $ARGS{'Attachments'} ) {
1387 my $rv = $MIMEObj->make_multipart;
1388 $RT::Logger->error("Couldn't make multipart message")
1389 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1391 foreach ( values %{ $ARGS{'Attachments'} } ) {
1393 $RT::Logger->error("Couldn't add empty attachemnt");
1396 $MIMEObj->add_part($_);
1400 foreach my $argument (qw(Encrypt Sign)) {
1401 $MIMEObj->head->add(
1402 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1403 ) if defined $ARGS{$argument};
1407 Type => $ARGS{'Type'} || 'ticket',
1408 Queue => $ARGS{'Queue'},
1409 Owner => $ARGS{'Owner'},
1412 Requestor => $ARGS{'Requestors'},
1414 AdminCc => $ARGS{'AdminCc'},
1415 InitialPriority => $ARGS{'InitialPriority'},
1416 FinalPriority => $ARGS{'FinalPriority'},
1417 TimeLeft => $ARGS{'TimeLeft'},
1418 TimeEstimated => $ARGS{'TimeEstimated'},
1419 TimeWorked => $ARGS{'TimeWorked'},
1420 Subject => $ARGS{'Subject'},
1421 Status => $ARGS{'Status'},
1422 Due => $due ? $due->ISO : undef,
1423 Starts => $starts ? $starts->ISO : undef,
1428 foreach my $type (qw(Requestor Cc AdminCc)) {
1429 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1430 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1434 if (@temp_squelch) {
1435 require RT::Action::SendEmail;
1436 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1439 if ( $ARGS{'AttachTickets'} ) {
1440 require RT::Action::SendEmail;
1441 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1442 ref $ARGS{'AttachTickets'}
1443 ? @{ $ARGS{'AttachTickets'} }
1444 : ( $ARGS{'AttachTickets'} ) );
1447 foreach my $arg ( keys %ARGS ) {
1448 next if $arg =~ /-(?:Magic|Category)$/;
1450 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1451 $create_args{$arg} = $ARGS{$arg};
1454 # Object-RT::Ticket--CustomField-3-Values
1455 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1458 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1459 $cf->SetContextObject( $Queue );
1461 unless ( $cf->id ) {
1462 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1466 if ( $arg =~ /-Upload$/ ) {
1467 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1471 my $type = $cf->Type;
1474 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1475 @values = @{ $ARGS{$arg} };
1476 } elsif ( $type =~ /text/i ) {
1477 @values = ( $ARGS{$arg} );
1479 no warnings 'uninitialized';
1480 @values = split /\r*\n/, $ARGS{$arg};
1482 @values = grep length, map {
1488 grep defined, @values;
1490 $create_args{"CustomField-$cfid"} = \@values;
1494 # turn new link lists into arrays, and pass in the proper arguments
1496 'new-DependsOn' => 'DependsOn',
1497 'DependsOn-new' => 'DependedOnBy',
1498 'new-MemberOf' => 'Parents',
1499 'MemberOf-new' => 'Children',
1500 'new-RefersTo' => 'RefersTo',
1501 'RefersTo-new' => 'ReferredToBy',
1503 foreach my $key ( keys %map ) {
1504 next unless $ARGS{$key};
1505 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1509 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1514 push( @Actions, split( "\n", $ErrMsg ) );
1515 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1516 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1518 return ( $Ticket, @Actions );
1524 # {{{ sub LoadTicket - loads a ticket
1526 =head2 LoadTicket id
1528 Takes a ticket id as its only variable. if it's handed an array, it takes
1531 Returns an RT::Ticket object as the current user.
1538 if ( ref($id) eq "ARRAY" ) {
1543 Abort("No ticket specified");
1546 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1548 unless ( $Ticket->id ) {
1549 Abort("Could not load ticket $id");
1556 # {{{ sub ProcessUpdateMessage
1558 =head2 ProcessUpdateMessage
1560 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1562 Don't write message if it only contains current user's signature and
1563 SkipSignatureOnly argument is true. Function anyway adds attachments
1564 and updates time worked field even if skips message. The default value
1569 sub ProcessUpdateMessage {
1574 SkipSignatureOnly => 1,
1578 if ( $args{ARGSRef}->{'UpdateAttachments'}
1579 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1581 delete $args{ARGSRef}->{'UpdateAttachments'};
1584 # Strip the signature
1585 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1586 Content => $args{ARGSRef}->{UpdateContent},
1587 ContentType => $args{ARGSRef}->{UpdateContentType},
1588 StripSignature => $args{SkipSignatureOnly},
1589 CurrentUser => $args{'TicketObj'}->CurrentUser,
1592 # If, after stripping the signature, we have no message, move the
1593 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1594 # ProcessBasics can deal -- then bail out.
1595 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1596 and not length $args{ARGSRef}->{'UpdateContent'} )
1598 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1599 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1604 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1605 $args{ARGSRef}->{'UpdateSubject'} = undef;
1608 my $Message = MakeMIMEEntity(
1609 Subject => $args{ARGSRef}->{'UpdateSubject'},
1610 Body => $args{ARGSRef}->{'UpdateContent'},
1611 Type => $args{ARGSRef}->{'UpdateContentType'},
1614 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1615 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1617 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1618 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1619 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1621 $old_txn = $args{TicketObj}->Transactions->First();
1624 if ( my $msg = $old_txn->Message->First ) {
1625 RT::Interface::Email::SetInReplyTo(
1626 Message => $Message,
1631 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1632 $Message->make_multipart;
1633 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1636 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1637 require RT::Action::SendEmail;
1638 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1639 ref $args{ARGSRef}->{'AttachTickets'}
1640 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1641 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1644 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1645 my $cc = $args{ARGSRef}->{'UpdateCc'};
1647 my %txn_customfields;
1649 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1650 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1651 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1655 my %message_args = (
1657 BccMessageTo => $bcc,
1658 Sign => $args{ARGSRef}->{'Sign'},
1659 Encrypt => $args{ARGSRef}->{'Encrypt'},
1660 MIMEObj => $Message,
1661 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1662 CustomFields => \%txn_customfields,
1666 foreach my $type (qw(Cc AdminCc)) {
1667 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1668 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1669 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1670 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1673 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1674 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1675 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1678 if (@temp_squelch) {
1679 require RT::Action::SendEmail;
1680 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1683 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1684 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1685 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1687 my $var = ucfirst($1) . 'MessageTo';
1689 if ( $message_args{$var} ) {
1690 $message_args{$var} .= ", $value";
1692 $message_args{$var} = $value;
1698 # Do the update via the appropriate Ticket method
1699 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1700 my ( $Transaction, $Description, $Object ) =
1701 $args{TicketObj}->Comment(%message_args);
1702 push( @results, $Description );
1703 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1704 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1705 my ( $Transaction, $Description, $Object ) =
1706 $args{TicketObj}->Correspond(%message_args);
1707 push( @results, $Description );
1708 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1711 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1718 # {{{ sub MakeMIMEEntity
1720 =head2 MakeMIMEEntity PARAMHASH
1722 Takes a paramhash Subject, Body and AttachmentFieldName.
1724 Also takes Form, Cc and Type as optional paramhash keys.
1726 Returns a MIME::Entity.
1730 sub MakeMIMEEntity {
1732 #TODO document what else this takes.
1738 AttachmentFieldName => undef,
1742 my $Message = MIME::Entity->build(
1743 Type => 'multipart/mixed',
1744 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1745 grep defined $args{$_}, qw(Subject From Cc)
1748 if ( defined $args{'Body'} && length $args{'Body'} ) {
1750 # Make the update content have no 'weird' newlines in it
1751 $args{'Body'} =~ s/\r\n/\n/gs;
1754 Type => $args{'Type'} || 'text/plain',
1756 Data => $args{'Body'},
1760 if ( $args{'AttachmentFieldName'} ) {
1762 my $cgi_object = $m->cgi_object;
1764 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1766 my ( @content, $buffer );
1767 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1768 push @content, $buffer;
1771 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1773 # Prefer the cached name first over CGI.pm stringification.
1774 my $filename = $RT::Mason::CGI::Filename;
1775 $filename = "$filehandle" unless defined $filename;
1776 $filename = Encode::encode_utf8( $filename );
1777 $filename =~ s{^.*[\\/]}{};
1780 Type => $uploadinfo->{'Content-Type'},
1781 Filename => $filename,
1784 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1785 $Message->head->set( 'Subject' => $filename );
1790 $Message->make_singlepart;
1792 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1800 # {{{ sub ParseDateToISO
1802 =head2 ParseDateToISO
1804 Takes a date in an arbitrary format.
1805 Returns an ISO date and time in GMT
1809 sub ParseDateToISO {
1812 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1814 Format => 'unknown',
1817 return ( $date_obj->ISO );
1822 # {{{ sub ProcessACLChanges
1824 sub ProcessACLChanges {
1825 my $ARGSref = shift;
1829 foreach my $arg ( keys %$ARGSref ) {
1830 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1832 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1835 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1836 @rights = @{ $ARGSref->{$arg} };
1838 @rights = $ARGSref->{$arg};
1840 @rights = grep $_, @rights;
1841 next unless @rights;
1843 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1844 $principal->Load($principal_id);
1847 if ( $object_type eq 'RT::System' ) {
1849 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1850 $obj = $object_type->new( $session{'CurrentUser'} );
1851 $obj->Load($object_id);
1852 unless ( $obj->id ) {
1853 $RT::Logger->error("couldn't load $object_type #$object_id");
1857 $RT::Logger->error("object type '$object_type' is incorrect");
1858 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1862 foreach my $right (@rights) {
1863 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1864 push( @results, $msg );
1873 # {{{ sub UpdateRecordObj
1875 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1877 @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.
1879 Returns an array of success/failure messages
1883 sub UpdateRecordObject {
1886 AttributesRef => undef,
1888 AttributePrefix => undef,
1892 my $Object = $args{'Object'};
1893 my @results = $Object->Update(
1894 AttributesRef => $args{'AttributesRef'},
1895 ARGSRef => $args{'ARGSRef'},
1896 AttributePrefix => $args{'AttributePrefix'},
1904 # {{{ Sub ProcessCustomFieldUpdates
1906 sub ProcessCustomFieldUpdates {
1908 CustomFieldObj => undef,
1913 my $Object = $args{'CustomFieldObj'};
1914 my $ARGSRef = $args{'ARGSRef'};
1916 my @attribs = qw(Name Type Description Queue SortOrder);
1917 my @results = UpdateRecordObject(
1918 AttributesRef => \@attribs,
1923 my $prefix = "CustomField-" . $Object->Id;
1924 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1925 my ( $addval, $addmsg ) = $Object->AddValue(
1926 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1927 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1928 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1930 push( @results, $addmsg );
1934 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1935 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1936 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1938 foreach my $id (@delete_values) {
1939 next unless defined $id;
1940 my ( $err, $msg ) = $Object->DeleteValue($id);
1941 push( @results, $msg );
1944 my $vals = $Object->Values();
1945 while ( my $cfv = $vals->Next() ) {
1946 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1947 if ( $cfv->SortOrder != $so ) {
1948 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1949 push( @results, $msg );
1959 # {{{ sub ProcessTicketBasics
1961 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1963 Returns an array of results messages.
1967 sub ProcessTicketBasics {
1975 my $TicketObj = $args{'TicketObj'};
1976 my $ARGSRef = $args{'ARGSRef'};
1978 # {{{ Set basic fields
1991 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1992 my $tempqueue = RT::Queue->new($RT::SystemUser);
1993 $tempqueue->Load( $ARGSRef->{'Queue'} );
1994 if ( $tempqueue->id ) {
1995 $ARGSRef->{'Queue'} = $tempqueue->id;
1999 # Status isn't a field that can be set to a null value.
2000 # RT core complains if you try
2001 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2003 my @results = UpdateRecordObject(
2004 AttributesRef => \@attribs,
2005 Object => $TicketObj,
2006 ARGSRef => $ARGSRef,
2009 # We special case owner changing, so we can use ForceOwnerChange
2010 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2012 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2013 $ChownType = "Force";
2015 $ChownType = "Give";
2018 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2019 push( @results, $msg );
2029 sub ProcessTicketCustomFieldUpdates {
2031 $args{'Object'} = delete $args{'TicketObj'};
2032 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2034 # Build up a list of objects that we want to work with
2035 my %custom_fields_to_mod;
2036 foreach my $arg ( keys %$ARGSRef ) {
2037 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2038 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2039 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2040 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2041 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2042 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2046 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2049 sub ProcessObjectCustomFieldUpdates {
2051 my $ARGSRef = $args{'ARGSRef'};
2054 # Build up a list of objects that we want to work with
2055 my %custom_fields_to_mod;
2056 foreach my $arg ( keys %$ARGSRef ) {
2058 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2059 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2061 # For each of those objects, find out what custom fields we want to work with.
2062 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2065 # For each of those objects
2066 foreach my $class ( keys %custom_fields_to_mod ) {
2067 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2068 my $Object = $args{'Object'};
2069 $Object = $class->new( $session{'CurrentUser'} )
2070 unless $Object && ref $Object eq $class;
2072 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2073 unless ( $Object->id ) {
2074 $RT::Logger->warning("Couldn't load object $class #$id");
2078 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2079 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2080 $CustomFieldObj->SetContextObject($Object);
2081 $CustomFieldObj->LoadById($cf);
2082 unless ( $CustomFieldObj->id ) {
2083 $RT::Logger->warning("Couldn't load custom field #$cf");
2087 _ProcessObjectCustomFieldUpdates(
2088 Prefix => "Object-$class-$id-CustomField-$cf-",
2090 CustomField => $CustomFieldObj,
2091 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2099 sub _ProcessObjectCustomFieldUpdates {
2101 my $cf = $args{'CustomField'};
2102 my $cf_type = $cf->Type;
2104 # Remove blank Values since the magic field will take care of this. Sometimes
2105 # the browser gives you a blank value which causes CFs to be processed twice
2106 if ( defined $args{'ARGS'}->{'Values'}
2107 && !length $args{'ARGS'}->{'Values'}
2108 && $args{'ARGS'}->{'Values-Magic'} )
2110 delete $args{'ARGS'}->{'Values'};
2114 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2116 # skip category argument
2117 next if $arg eq 'Category';
2120 next if $arg eq 'Value-TimeUnits';
2122 # since http won't pass in a form element with a null value, we need
2124 if ( $arg eq 'Values-Magic' ) {
2126 # We don't care about the magic, if there's really a values element;
2127 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2128 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2130 # "Empty" values does not mean anything for Image and Binary fields
2131 next if $cf_type =~ /^(?:Image|Binary)$/;
2134 $args{'ARGS'}->{'Values'} = undef;
2138 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2139 @values = @{ $args{'ARGS'}->{$arg} };
2140 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2141 @values = ( $args{'ARGS'}->{$arg} );
2143 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2144 if defined $args{'ARGS'}->{$arg};
2146 @values = grep length, map {
2152 grep defined, @values;
2154 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2155 foreach my $value (@values) {
2156 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2160 push( @results, $msg );
2162 } elsif ( $arg eq 'Upload' ) {
2163 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2164 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2165 push( @results, $msg );
2166 } elsif ( $arg eq 'DeleteValues' ) {
2167 foreach my $value (@values) {
2168 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2172 push( @results, $msg );
2174 } elsif ( $arg eq 'DeleteValueIds' ) {
2175 foreach my $value (@values) {
2176 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2180 push( @results, $msg );
2182 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2183 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2186 foreach my $value (@values) {
2187 if ( my $entry = $cf_values->HasEntry($value) ) {
2188 $values_hash{ $entry->id } = 1;
2192 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2196 push( @results, $msg );
2197 $values_hash{$val} = 1 if $val;
2200 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2201 return @results if ( $cf->Type eq 'Date' && ! @values );
2203 $cf_values->RedoSearch;
2204 while ( my $cf_value = $cf_values->Next ) {
2205 next if $values_hash{ $cf_value->id };
2207 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2209 ValueId => $cf_value->id
2211 push( @results, $msg );
2213 } elsif ( $arg eq 'Values' ) {
2214 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2216 # keep everything up to the point of difference, delete the rest
2218 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2219 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2228 # now add/replace extra things, if any
2229 foreach my $value (@values) {
2230 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2234 push( @results, $msg );
2239 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2240 $cf->Name, ref $args{'Object'},
2249 # {{{ sub ProcessTicketWatchers
2251 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2253 Returns an array of results messages.
2257 sub ProcessTicketWatchers {
2265 my $Ticket = $args{'TicketObj'};
2266 my $ARGSRef = $args{'ARGSRef'};
2270 foreach my $key ( keys %$ARGSRef ) {
2272 # Delete deletable watchers
2273 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2274 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2278 push @results, $msg;
2281 # Delete watchers in the simple style demanded by the bulk manipulator
2282 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2283 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2284 Email => $ARGSRef->{$key},
2287 push @results, $msg;
2290 # Add new wathchers by email address
2291 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2292 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2295 #They're in this order because otherwise $1 gets clobbered :/
2296 my ( $code, $msg ) = $Ticket->AddWatcher(
2297 Type => $ARGSRef->{$key},
2298 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2300 push @results, $msg;
2303 #Add requestors in the simple style demanded by the bulk manipulator
2304 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2305 my ( $code, $msg ) = $Ticket->AddWatcher(
2307 Email => $ARGSRef->{$key}
2309 push @results, $msg;
2312 # Add new watchers by owner
2313 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2314 my $principal_id = $1;
2315 my $form = $ARGSRef->{$key};
2316 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2317 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2319 my ( $code, $msg ) = $Ticket->AddWatcher(
2321 PrincipalId => $principal_id
2323 push @results, $msg;
2333 # {{{ sub ProcessTicketDates
2335 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2337 Returns an array of results messages.
2341 sub ProcessTicketDates {
2348 my $Ticket = $args{'TicketObj'};
2349 my $ARGSRef = $args{'ARGSRef'};
2353 # {{{ Set date fields
2354 my @date_fields = qw(
2362 #Run through each field in this list. update the value if apropriate
2363 foreach my $field (@date_fields) {
2364 next unless exists $ARGSRef->{ $field . '_Date' };
2365 next if $ARGSRef->{ $field . '_Date' } eq '';
2369 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2371 Format => 'unknown',
2372 Value => $ARGSRef->{ $field . '_Date' }
2375 my $obj = $field . "Obj";
2376 if ( ( defined $DateObj->Unix )
2377 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2379 my $method = "Set$field";
2380 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2381 push @results, "$msg";
2391 # {{{ sub ProcessTicketLinks
2393 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2395 Returns an array of results messages.
2399 sub ProcessTicketLinks {
2406 my $Ticket = $args{'TicketObj'};
2407 my $ARGSRef = $args{'ARGSRef'};
2409 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2411 #Merge if we need to
2412 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2413 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2414 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2415 push @results, $msg;
2423 sub ProcessRecordLinks {
2430 my $Record = $args{'RecordObj'};
2431 my $ARGSRef = $args{'ARGSRef'};
2435 # Delete links that are gone gone gone.
2436 foreach my $arg ( keys %$ARGSRef ) {
2437 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2442 my ( $val, $msg ) = $Record->DeleteLink(
2448 push @results, $msg;
2454 my @linktypes = qw( DependsOn MemberOf RefersTo );
2456 foreach my $linktype (@linktypes) {
2457 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2458 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2459 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2461 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2463 $luri =~ s/\s+$//; # Strip trailing whitespace
2464 my ( $val, $msg ) = $Record->AddLink(
2468 push @results, $msg;
2471 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2472 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2473 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2475 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2477 my ( $val, $msg ) = $Record->AddLink(
2482 push @results, $msg;
2490 =head2 _UploadedFile ( $arg );
2492 Takes a CGI parameter name; if a file is uploaded under that name,
2493 return a hash reference suitable for AddCustomFieldValue's use:
2494 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2496 Returns C<undef> if no files were uploaded in the C<$arg> field.
2502 my $cgi_object = $m->cgi_object;
2503 my $fh = $cgi_object->upload($arg) or return undef;
2504 my $upload_info = $cgi_object->uploadInfo($fh);
2506 my $filename = "$fh";
2507 $filename =~ s#^.*[\\/]##;
2512 LargeContent => do { local $/; scalar <$fh> },
2513 ContentType => $upload_info->{'Content-Type'},
2517 sub GetColumnMapEntry {
2518 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2520 # deal with the simplest thing first
2521 if ( $args{'Map'}{ $args{'Name'} } ) {
2522 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2526 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2527 return undef unless $args{'Map'}->{$mainkey};
2528 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2529 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2531 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2536 sub ProcessColumnMapValue {
2538 my %args = ( Arguments => [], Escape => 1, @_ );
2541 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2542 my @tmp = $value->( @{ $args{'Arguments'} } );
2543 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2544 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2545 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2546 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2551 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2555 =head2 _load_container_object ( $type, $id );
2557 Instantiate container object for saving searches.
2561 sub _load_container_object {
2562 my ( $obj_type, $obj_id ) = @_;
2563 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2566 =head2 _parse_saved_search ( $arg );
2568 Given a serialization string for saved search, and returns the
2569 container object and the search id.
2573 sub _parse_saved_search {
2575 return unless $spec;
2576 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2583 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2586 =head2 ScrubHTML content
2588 Removes unsafe and undesired HTML from the passed content
2594 my $Content = shift;
2595 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2597 $Content = '' if !defined($Content);
2598 return $SCRUBBER->scrub($Content);
2603 Returns a new L<HTML::Scrubber> object.
2605 If you need to be more lax about what HTML tags and attributes are allowed,
2606 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2609 package HTML::Mason::Commands;
2610 # Let tables through
2611 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2616 our @SCRUBBER_ALLOWED_TAGS = qw(
2617 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2618 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2621 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2622 # Match http, ftp and relative urls
2623 # XXX: we also scrub format strings with this module then allow simple config options
2624 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2630 (?:(?:background-)?color: \s*
2631 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
2632 \#[a-f0-9]{3,6} | # #fff or #ffffff
2633 [\w\-]+ # green, light-blue, etc.
2635 text-align: \s* \w+ |
2636 font-size: \s* [\w.\-]+ |
2637 font-family: \s* [\w\s"',.\-]+ |
2638 font-weight: \s* [\w\-]+ |
2640 # MS Office styles, which are probably fine. If we don't, then any
2641 # associated styles in the same attribute get stripped.
2642 mso-[\w\-]+?: \s* [\w\s"',.\-]+
2644 +$ # one or more of these allowed properties from here 'till sunset
2648 our %SCRUBBER_RULES = ();
2651 require HTML::Scrubber;
2652 my $scrubber = HTML::Scrubber->new();
2656 %SCRUBBER_ALLOWED_ATTRIBUTES,
2657 '*' => 0, # require attributes be explicitly allowed
2660 $scrubber->deny(qw[*]);
2661 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2662 $scrubber->rules(%SCRUBBER_RULES);
2664 # Scrubbing comments is vital since IE conditional comments can contain
2665 # arbitrary HTML and we'd pass it right on through.
2666 $scrubber->comment(0);
2671 package RT::Interface::Web;
2672 RT::Base->_ImportOverlays();