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,
1040 sub IsCompCSRFWhitelisted {
1044 return 1 if $is_whitelisted_component{$comp};
1046 my %args = %{ $ARGS };
1048 # If the user specifies a *correct* user and pass then they are
1049 # golden. This acts on the presumption that external forms may
1050 # hardcode a username and password -- if a malicious attacker knew
1051 # both already, CSRF is the least of your problems.
1052 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1053 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1054 my $user_obj = RT::CurrentUser->new();
1055 $user_obj->Load($args{user});
1056 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1062 # Eliminate arguments that do not indicate an effectful request.
1063 # For example, "id" is acceptable because that is how RT retrieves a
1067 # If they have a valid results= from MaybeRedirectForResults, that's
1069 delete $args{results} if $args{results}
1070 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1072 # The homepage refresh, which uses the Refresh header, doesn't send
1073 # a referer in most browsers; whitelist the one parameter it reloads
1074 # with, HomeRefreshInterval, which is safe
1075 delete $args{HomeRefreshInterval};
1077 # If there are no arguments, then it's likely to be an idempotent
1078 # request, which are not susceptible to CSRF
1084 sub IsRefererCSRFWhitelisted {
1085 my $referer = _NormalizeHost(shift);
1086 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1087 $base_url = $base_url->host_port;
1090 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1091 push @$configs,$config;
1092 return 1 if $referer->host_port eq $config;
1095 return (0,$referer,$configs);
1098 =head3 _NormalizeHost
1100 Takes a URI and creates a URI object that's been normalized
1101 to handle common problems such as localhost vs 127.0.0.1
1105 sub _NormalizeHost {
1107 my $uri= URI->new(shift);
1108 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1114 sub IsPossibleCSRF {
1117 # If first request on this session is to a REST endpoint, then
1118 # whitelist the REST endpoints -- and explicitly deny non-REST
1119 # endpoints. We do this because using a REST cookie in a browser
1120 # would open the user to CSRF attacks to the REST endpoints.
1121 my $comp = $HTML::Mason::Commands::m->request_comp->path;
1122 $HTML::Mason::Commands::session{'REST'} = $comp =~ m{^/REST/\d+\.\d+/}
1123 unless defined $HTML::Mason::Commands::session{'REST'};
1125 if ($HTML::Mason::Commands::session{'REST'}) {
1126 return 0 if $comp =~ m{^/REST/\d+\.\d+/};
1128 This login session belongs to a REST client, and cannot be used to
1129 access non-REST interfaces of RT for security reasons.
1131 my $details = <<EOT;
1132 Please log out and back in to obtain a session for normal browsing. If
1133 you understand the security implications, disabling RT's CSRF protection
1134 will remove this restriction.
1137 HTML::Mason::Commands::Abort( $why, Details => $details );
1140 return 0 if IsCompCSRFWhitelisted( $comp, $ARGS );
1142 # if there is no Referer header then assume the worst
1144 "your browser did not supply a Referrer header", # loc
1145 ) if !$ENV{HTTP_REFERER};
1147 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1148 return 0 if $whitelisted;
1150 if ( @$configs > 1 ) {
1152 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1153 $browser->host_port,
1155 join(', ', @$configs) );
1159 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1160 $browser->host_port,
1164 sub ExpandCSRFToken {
1167 my $token = delete $ARGS->{CSRF_Token};
1168 return unless $token;
1170 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1171 return unless $data;
1172 return unless $data->{uri} eq $HTML::Mason::Commands::r->uri;
1174 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1175 return unless $user->ValidateAuthString( $data->{auth}, $token );
1177 %{$ARGS} = %{$data->{args}};
1179 # We explicitly stored file attachments with the request, but not in
1180 # the session yet, as that would itself be an attack. Put them into
1181 # the session now, so they'll be visible.
1182 if ($data->{attach}) {
1183 my $filename = $data->{attach}{filename};
1184 my $mime = $data->{attach}{mime};
1185 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1192 sub StoreRequestToken {
1195 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1196 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1198 auth => $user->GenerateAuthString( $token ),
1199 uri => $HTML::Mason::Commands::r->uri,
1202 if ($ARGS->{Attach}) {
1203 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1204 my $file_path = delete $ARGS->{'Attach'};
1206 filename => Encode::decode_utf8("$file_path"),
1207 mime => $attachment,
1211 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1212 $HTML::Mason::Commands::session{'i'}++;
1216 sub MaybeShowInterstitialCSRFPage {
1219 return unless RT->Config->Get('RestrictReferrer');
1221 # Deal with the form token provided by the interstitial, which lets
1222 # browsers which never set referer headers still use RT, if
1223 # painfully. This blows values into ARGS
1224 return if ExpandCSRFToken($ARGS);
1226 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1227 return if !$is_csrf;
1229 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1231 my $token = StoreRequestToken($ARGS);
1232 $HTML::Mason::Commands::m->comp(
1234 OriginalURL => $HTML::Mason::Commands::r->uri,
1235 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1238 # Calls abort, never gets here
1241 package HTML::Mason::Commands;
1243 use vars qw/$r $m %session/;
1249 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1250 with whatever it's called with. If there is no $session{'CurrentUser'},
1251 it creates a temporary user, so we have something to get a localisation handle
1258 if ( $session{'CurrentUser'}
1259 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1261 return ( $session{'CurrentUser'}->loc(@_) );
1264 RT::CurrentUser->new();
1268 return ( $u->loc(@_) );
1271 # pathetic case -- SystemUser is gone.
1280 =head2 loc_fuzzy STRING
1282 loc_fuzzy is for handling localizations of messages that may already
1283 contain interpolated variables, typically returned from libraries
1284 outside RT's control. It takes the message string and extracts the
1285 variable array automatically by matching against the candidate entries
1286 inside the lexicon file.
1293 if ( $session{'CurrentUser'}
1294 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1296 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1298 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1299 return ( $u->loc_fuzzy($msg) );
1306 # Error - calls Error and aborts
1311 if ( $session{'ErrorDocument'}
1312 && $session{'ErrorDocumentType'} )
1314 $r->content_type( $session{'ErrorDocumentType'} );
1315 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1318 $m->comp( "/Elements/Error", Why => $why, %args );
1325 # {{{ sub CreateTicket
1327 =head2 CreateTicket ARGS
1329 Create a new ticket, using Mason's %ARGS. returns @results.
1338 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1340 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1341 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1342 Abort('Queue not found');
1345 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1346 Abort('You have no permission to create tickets in that queue.');
1350 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1351 $due = new RT::Date( $session{'CurrentUser'} );
1352 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1355 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1356 $starts = new RT::Date( $session{'CurrentUser'} );
1357 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1360 my $sigless = RT::Interface::Web::StripContent(
1361 Content => $ARGS{Content},
1362 ContentType => $ARGS{ContentType},
1363 StripSignature => 1,
1364 CurrentUser => $session{'CurrentUser'},
1367 my $MIMEObj = MakeMIMEEntity(
1368 Subject => $ARGS{'Subject'},
1369 From => $ARGS{'From'},
1372 Type => $ARGS{'ContentType'},
1375 if ( $ARGS{'Attachments'} ) {
1376 my $rv = $MIMEObj->make_multipart;
1377 $RT::Logger->error("Couldn't make multipart message")
1378 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1380 foreach ( values %{ $ARGS{'Attachments'} } ) {
1382 $RT::Logger->error("Couldn't add empty attachemnt");
1385 $MIMEObj->add_part($_);
1389 foreach my $argument (qw(Encrypt Sign)) {
1390 $MIMEObj->head->add(
1391 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1392 ) if defined $ARGS{$argument};
1396 Type => $ARGS{'Type'} || 'ticket',
1397 Queue => $ARGS{'Queue'},
1398 Owner => $ARGS{'Owner'},
1401 Requestor => $ARGS{'Requestors'},
1403 AdminCc => $ARGS{'AdminCc'},
1404 InitialPriority => $ARGS{'InitialPriority'},
1405 FinalPriority => $ARGS{'FinalPriority'},
1406 TimeLeft => $ARGS{'TimeLeft'},
1407 TimeEstimated => $ARGS{'TimeEstimated'},
1408 TimeWorked => $ARGS{'TimeWorked'},
1409 Subject => $ARGS{'Subject'},
1410 Status => $ARGS{'Status'},
1411 Due => $due ? $due->ISO : undef,
1412 Starts => $starts ? $starts->ISO : undef,
1417 foreach my $type (qw(Requestor Cc AdminCc)) {
1418 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1419 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1423 if (@temp_squelch) {
1424 require RT::Action::SendEmail;
1425 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1428 if ( $ARGS{'AttachTickets'} ) {
1429 require RT::Action::SendEmail;
1430 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1431 ref $ARGS{'AttachTickets'}
1432 ? @{ $ARGS{'AttachTickets'} }
1433 : ( $ARGS{'AttachTickets'} ) );
1436 foreach my $arg ( keys %ARGS ) {
1437 next if $arg =~ /-(?:Magic|Category)$/;
1439 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1440 $create_args{$arg} = $ARGS{$arg};
1443 # Object-RT::Ticket--CustomField-3-Values
1444 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1447 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1448 $cf->SetContextObject( $Queue );
1450 unless ( $cf->id ) {
1451 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1455 if ( $arg =~ /-Upload$/ ) {
1456 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1460 my $type = $cf->Type;
1463 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1464 @values = @{ $ARGS{$arg} };
1465 } elsif ( $type =~ /text/i ) {
1466 @values = ( $ARGS{$arg} );
1468 no warnings 'uninitialized';
1469 @values = split /\r*\n/, $ARGS{$arg};
1471 @values = grep length, map {
1477 grep defined, @values;
1479 $create_args{"CustomField-$cfid"} = \@values;
1483 # turn new link lists into arrays, and pass in the proper arguments
1485 'new-DependsOn' => 'DependsOn',
1486 'DependsOn-new' => 'DependedOnBy',
1487 'new-MemberOf' => 'Parents',
1488 'MemberOf-new' => 'Children',
1489 'new-RefersTo' => 'RefersTo',
1490 'RefersTo-new' => 'ReferredToBy',
1492 foreach my $key ( keys %map ) {
1493 next unless $ARGS{$key};
1494 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1498 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1503 push( @Actions, split( "\n", $ErrMsg ) );
1504 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1505 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1507 return ( $Ticket, @Actions );
1513 # {{{ sub LoadTicket - loads a ticket
1515 =head2 LoadTicket id
1517 Takes a ticket id as its only variable. if it's handed an array, it takes
1520 Returns an RT::Ticket object as the current user.
1527 if ( ref($id) eq "ARRAY" ) {
1532 Abort("No ticket specified");
1535 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1537 unless ( $Ticket->id ) {
1538 Abort("Could not load ticket $id");
1545 # {{{ sub ProcessUpdateMessage
1547 =head2 ProcessUpdateMessage
1549 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1551 Don't write message if it only contains current user's signature and
1552 SkipSignatureOnly argument is true. Function anyway adds attachments
1553 and updates time worked field even if skips message. The default value
1558 sub ProcessUpdateMessage {
1563 SkipSignatureOnly => 1,
1567 if ( $args{ARGSRef}->{'UpdateAttachments'}
1568 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1570 delete $args{ARGSRef}->{'UpdateAttachments'};
1573 # Strip the signature
1574 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1575 Content => $args{ARGSRef}->{UpdateContent},
1576 ContentType => $args{ARGSRef}->{UpdateContentType},
1577 StripSignature => $args{SkipSignatureOnly},
1578 CurrentUser => $args{'TicketObj'}->CurrentUser,
1581 # If, after stripping the signature, we have no message, move the
1582 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1583 # ProcessBasics can deal -- then bail out.
1584 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1585 and not length $args{ARGSRef}->{'UpdateContent'} )
1587 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1588 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1593 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1594 $args{ARGSRef}->{'UpdateSubject'} = undef;
1597 my $Message = MakeMIMEEntity(
1598 Subject => $args{ARGSRef}->{'UpdateSubject'},
1599 Body => $args{ARGSRef}->{'UpdateContent'},
1600 Type => $args{ARGSRef}->{'UpdateContentType'},
1603 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1604 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1606 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1607 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1608 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1610 $old_txn = $args{TicketObj}->Transactions->First();
1613 if ( my $msg = $old_txn->Message->First ) {
1614 RT::Interface::Email::SetInReplyTo(
1615 Message => $Message,
1620 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1621 $Message->make_multipart;
1622 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1625 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1626 require RT::Action::SendEmail;
1627 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1628 ref $args{ARGSRef}->{'AttachTickets'}
1629 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1630 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1633 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1634 my $cc = $args{ARGSRef}->{'UpdateCc'};
1636 my %txn_customfields;
1638 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1639 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1640 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1644 my %message_args = (
1646 BccMessageTo => $bcc,
1647 Sign => $args{ARGSRef}->{'Sign'},
1648 Encrypt => $args{ARGSRef}->{'Encrypt'},
1649 MIMEObj => $Message,
1650 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1651 CustomFields => \%txn_customfields,
1655 foreach my $type (qw(Cc AdminCc)) {
1656 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1657 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1658 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1659 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1662 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1663 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1664 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1667 if (@temp_squelch) {
1668 require RT::Action::SendEmail;
1669 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_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 # Do the update via the appropriate Ticket method
1688 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1689 my ( $Transaction, $Description, $Object ) =
1690 $args{TicketObj}->Comment(%message_args);
1691 push( @results, $Description );
1692 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1693 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1694 my ( $Transaction, $Description, $Object ) =
1695 $args{TicketObj}->Correspond(%message_args);
1696 push( @results, $Description );
1697 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1700 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1707 # {{{ sub MakeMIMEEntity
1709 =head2 MakeMIMEEntity PARAMHASH
1711 Takes a paramhash Subject, Body and AttachmentFieldName.
1713 Also takes Form, Cc and Type as optional paramhash keys.
1715 Returns a MIME::Entity.
1719 sub MakeMIMEEntity {
1721 #TODO document what else this takes.
1727 AttachmentFieldName => undef,
1731 my $Message = MIME::Entity->build(
1732 Type => 'multipart/mixed',
1733 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1734 grep defined $args{$_}, qw(Subject From Cc)
1737 if ( defined $args{'Body'} && length $args{'Body'} ) {
1739 # Make the update content have no 'weird' newlines in it
1740 $args{'Body'} =~ s/\r\n/\n/gs;
1743 Type => $args{'Type'} || 'text/plain',
1745 Data => $args{'Body'},
1749 if ( $args{'AttachmentFieldName'} ) {
1751 my $cgi_object = $m->cgi_object;
1753 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1755 my ( @content, $buffer );
1756 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1757 push @content, $buffer;
1760 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1762 # Prefer the cached name first over CGI.pm stringification.
1763 my $filename = $RT::Mason::CGI::Filename;
1764 $filename = "$filehandle" unless defined $filename;
1765 $filename = Encode::encode_utf8( $filename );
1766 $filename =~ s{^.*[\\/]}{};
1769 Type => $uploadinfo->{'Content-Type'},
1770 Filename => $filename,
1773 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1774 $Message->head->set( 'Subject' => $filename );
1779 $Message->make_singlepart;
1781 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1789 # {{{ sub ParseDateToISO
1791 =head2 ParseDateToISO
1793 Takes a date in an arbitrary format.
1794 Returns an ISO date and time in GMT
1798 sub ParseDateToISO {
1801 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1803 Format => 'unknown',
1806 return ( $date_obj->ISO );
1811 # {{{ sub ProcessACLChanges
1813 sub ProcessACLChanges {
1814 my $ARGSref = shift;
1818 foreach my $arg ( keys %$ARGSref ) {
1819 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1821 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1824 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1825 @rights = @{ $ARGSref->{$arg} };
1827 @rights = $ARGSref->{$arg};
1829 @rights = grep $_, @rights;
1830 next unless @rights;
1832 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1833 $principal->Load($principal_id);
1836 if ( $object_type eq 'RT::System' ) {
1838 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1839 $obj = $object_type->new( $session{'CurrentUser'} );
1840 $obj->Load($object_id);
1841 unless ( $obj->id ) {
1842 $RT::Logger->error("couldn't load $object_type #$object_id");
1846 $RT::Logger->error("object type '$object_type' is incorrect");
1847 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1851 foreach my $right (@rights) {
1852 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1853 push( @results, $msg );
1862 # {{{ sub UpdateRecordObj
1864 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1866 @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.
1868 Returns an array of success/failure messages
1872 sub UpdateRecordObject {
1875 AttributesRef => undef,
1877 AttributePrefix => undef,
1881 my $Object = $args{'Object'};
1882 my @results = $Object->Update(
1883 AttributesRef => $args{'AttributesRef'},
1884 ARGSRef => $args{'ARGSRef'},
1885 AttributePrefix => $args{'AttributePrefix'},
1893 # {{{ Sub ProcessCustomFieldUpdates
1895 sub ProcessCustomFieldUpdates {
1897 CustomFieldObj => undef,
1902 my $Object = $args{'CustomFieldObj'};
1903 my $ARGSRef = $args{'ARGSRef'};
1905 my @attribs = qw(Name Type Description Queue SortOrder);
1906 my @results = UpdateRecordObject(
1907 AttributesRef => \@attribs,
1912 my $prefix = "CustomField-" . $Object->Id;
1913 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1914 my ( $addval, $addmsg ) = $Object->AddValue(
1915 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1916 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1917 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1919 push( @results, $addmsg );
1923 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1924 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1925 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1927 foreach my $id (@delete_values) {
1928 next unless defined $id;
1929 my ( $err, $msg ) = $Object->DeleteValue($id);
1930 push( @results, $msg );
1933 my $vals = $Object->Values();
1934 while ( my $cfv = $vals->Next() ) {
1935 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1936 if ( $cfv->SortOrder != $so ) {
1937 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1938 push( @results, $msg );
1948 # {{{ sub ProcessTicketBasics
1950 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1952 Returns an array of results messages.
1956 sub ProcessTicketBasics {
1964 my $TicketObj = $args{'TicketObj'};
1965 my $ARGSRef = $args{'ARGSRef'};
1967 # {{{ Set basic fields
1980 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1981 my $tempqueue = RT::Queue->new($RT::SystemUser);
1982 $tempqueue->Load( $ARGSRef->{'Queue'} );
1983 if ( $tempqueue->id ) {
1984 $ARGSRef->{'Queue'} = $tempqueue->id;
1988 # Status isn't a field that can be set to a null value.
1989 # RT core complains if you try
1990 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1992 my @results = UpdateRecordObject(
1993 AttributesRef => \@attribs,
1994 Object => $TicketObj,
1995 ARGSRef => $ARGSRef,
1998 # We special case owner changing, so we can use ForceOwnerChange
1999 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2001 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2002 $ChownType = "Force";
2004 $ChownType = "Give";
2007 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2008 push( @results, $msg );
2018 sub ProcessTicketCustomFieldUpdates {
2020 $args{'Object'} = delete $args{'TicketObj'};
2021 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2023 # Build up a list of objects that we want to work with
2024 my %custom_fields_to_mod;
2025 foreach my $arg ( keys %$ARGSRef ) {
2026 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2027 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2028 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2029 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2030 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2031 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2035 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2038 sub ProcessObjectCustomFieldUpdates {
2040 my $ARGSRef = $args{'ARGSRef'};
2043 # Build up a list of objects that we want to work with
2044 my %custom_fields_to_mod;
2045 foreach my $arg ( keys %$ARGSRef ) {
2047 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2048 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2050 # For each of those objects, find out what custom fields we want to work with.
2051 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2054 # For each of those objects
2055 foreach my $class ( keys %custom_fields_to_mod ) {
2056 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2057 my $Object = $args{'Object'};
2058 $Object = $class->new( $session{'CurrentUser'} )
2059 unless $Object && ref $Object eq $class;
2061 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2062 unless ( $Object->id ) {
2063 $RT::Logger->warning("Couldn't load object $class #$id");
2067 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2068 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2069 $CustomFieldObj->SetContextObject($Object);
2070 $CustomFieldObj->LoadById($cf);
2071 unless ( $CustomFieldObj->id ) {
2072 $RT::Logger->warning("Couldn't load custom field #$cf");
2076 _ProcessObjectCustomFieldUpdates(
2077 Prefix => "Object-$class-$id-CustomField-$cf-",
2079 CustomField => $CustomFieldObj,
2080 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2088 sub _ProcessObjectCustomFieldUpdates {
2090 my $cf = $args{'CustomField'};
2091 my $cf_type = $cf->Type;
2093 # Remove blank Values since the magic field will take care of this. Sometimes
2094 # the browser gives you a blank value which causes CFs to be processed twice
2095 if ( defined $args{'ARGS'}->{'Values'}
2096 && !length $args{'ARGS'}->{'Values'}
2097 && $args{'ARGS'}->{'Values-Magic'} )
2099 delete $args{'ARGS'}->{'Values'};
2103 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2105 # skip category argument
2106 next if $arg eq 'Category';
2109 next if $arg eq 'Value-TimeUnits';
2111 # since http won't pass in a form element with a null value, we need
2113 if ( $arg eq 'Values-Magic' ) {
2115 # We don't care about the magic, if there's really a values element;
2116 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2117 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2119 # "Empty" values does not mean anything for Image and Binary fields
2120 next if $cf_type =~ /^(?:Image|Binary)$/;
2123 $args{'ARGS'}->{'Values'} = undef;
2127 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2128 @values = @{ $args{'ARGS'}->{$arg} };
2129 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2130 @values = ( $args{'ARGS'}->{$arg} );
2132 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2133 if defined $args{'ARGS'}->{$arg};
2135 @values = grep length, map {
2141 grep defined, @values;
2143 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2144 foreach my $value (@values) {
2145 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2149 push( @results, $msg );
2151 } elsif ( $arg eq 'Upload' ) {
2152 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2153 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2154 push( @results, $msg );
2155 } elsif ( $arg eq 'DeleteValues' ) {
2156 foreach my $value (@values) {
2157 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2161 push( @results, $msg );
2163 } elsif ( $arg eq 'DeleteValueIds' ) {
2164 foreach my $value (@values) {
2165 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2169 push( @results, $msg );
2171 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2172 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2175 foreach my $value (@values) {
2176 if ( my $entry = $cf_values->HasEntry($value) ) {
2177 $values_hash{ $entry->id } = 1;
2181 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2185 push( @results, $msg );
2186 $values_hash{$val} = 1 if $val;
2189 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2190 return @results if ( $cf->Type eq 'Date' && ! @values );
2192 $cf_values->RedoSearch;
2193 while ( my $cf_value = $cf_values->Next ) {
2194 next if $values_hash{ $cf_value->id };
2196 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2198 ValueId => $cf_value->id
2200 push( @results, $msg );
2202 } elsif ( $arg eq 'Values' ) {
2203 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2205 # keep everything up to the point of difference, delete the rest
2207 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2208 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2217 # now add/replace extra things, if any
2218 foreach my $value (@values) {
2219 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2223 push( @results, $msg );
2228 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2229 $cf->Name, ref $args{'Object'},
2238 # {{{ sub ProcessTicketWatchers
2240 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2242 Returns an array of results messages.
2246 sub ProcessTicketWatchers {
2254 my $Ticket = $args{'TicketObj'};
2255 my $ARGSRef = $args{'ARGSRef'};
2259 foreach my $key ( keys %$ARGSRef ) {
2261 # Delete deletable watchers
2262 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2263 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2267 push @results, $msg;
2270 # Delete watchers in the simple style demanded by the bulk manipulator
2271 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2272 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2273 Email => $ARGSRef->{$key},
2276 push @results, $msg;
2279 # Add new wathchers by email address
2280 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2281 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2284 #They're in this order because otherwise $1 gets clobbered :/
2285 my ( $code, $msg ) = $Ticket->AddWatcher(
2286 Type => $ARGSRef->{$key},
2287 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2289 push @results, $msg;
2292 #Add requestors in the simple style demanded by the bulk manipulator
2293 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2294 my ( $code, $msg ) = $Ticket->AddWatcher(
2296 Email => $ARGSRef->{$key}
2298 push @results, $msg;
2301 # Add new watchers by owner
2302 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2303 my $principal_id = $1;
2304 my $form = $ARGSRef->{$key};
2305 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2306 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2308 my ( $code, $msg ) = $Ticket->AddWatcher(
2310 PrincipalId => $principal_id
2312 push @results, $msg;
2322 # {{{ sub ProcessTicketDates
2324 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2326 Returns an array of results messages.
2330 sub ProcessTicketDates {
2337 my $Ticket = $args{'TicketObj'};
2338 my $ARGSRef = $args{'ARGSRef'};
2342 # {{{ Set date fields
2343 my @date_fields = qw(
2351 #Run through each field in this list. update the value if apropriate
2352 foreach my $field (@date_fields) {
2353 next unless exists $ARGSRef->{ $field . '_Date' };
2354 next if $ARGSRef->{ $field . '_Date' } eq '';
2358 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2360 Format => 'unknown',
2361 Value => $ARGSRef->{ $field . '_Date' }
2364 my $obj = $field . "Obj";
2365 if ( ( defined $DateObj->Unix )
2366 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2368 my $method = "Set$field";
2369 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2370 push @results, "$msg";
2380 # {{{ sub ProcessTicketLinks
2382 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2384 Returns an array of results messages.
2388 sub ProcessTicketLinks {
2395 my $Ticket = $args{'TicketObj'};
2396 my $ARGSRef = $args{'ARGSRef'};
2398 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2400 #Merge if we need to
2401 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2402 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2403 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2404 push @results, $msg;
2412 sub ProcessRecordLinks {
2419 my $Record = $args{'RecordObj'};
2420 my $ARGSRef = $args{'ARGSRef'};
2424 # Delete links that are gone gone gone.
2425 foreach my $arg ( keys %$ARGSRef ) {
2426 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2431 my ( $val, $msg ) = $Record->DeleteLink(
2437 push @results, $msg;
2443 my @linktypes = qw( DependsOn MemberOf RefersTo );
2445 foreach my $linktype (@linktypes) {
2446 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2447 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2448 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2450 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2452 $luri =~ s/\s+$//; # Strip trailing whitespace
2453 my ( $val, $msg ) = $Record->AddLink(
2457 push @results, $msg;
2460 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2461 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2462 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2464 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2466 my ( $val, $msg ) = $Record->AddLink(
2471 push @results, $msg;
2479 =head2 _UploadedFile ( $arg );
2481 Takes a CGI parameter name; if a file is uploaded under that name,
2482 return a hash reference suitable for AddCustomFieldValue's use:
2483 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2485 Returns C<undef> if no files were uploaded in the C<$arg> field.
2491 my $cgi_object = $m->cgi_object;
2492 my $fh = $cgi_object->upload($arg) or return undef;
2493 my $upload_info = $cgi_object->uploadInfo($fh);
2495 my $filename = "$fh";
2496 $filename =~ s#^.*[\\/]##;
2501 LargeContent => do { local $/; scalar <$fh> },
2502 ContentType => $upload_info->{'Content-Type'},
2506 sub GetColumnMapEntry {
2507 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2509 # deal with the simplest thing first
2510 if ( $args{'Map'}{ $args{'Name'} } ) {
2511 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2515 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2516 return undef unless $args{'Map'}->{$mainkey};
2517 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2518 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2520 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2525 sub ProcessColumnMapValue {
2527 my %args = ( Arguments => [], Escape => 1, @_ );
2530 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2531 my @tmp = $value->( @{ $args{'Arguments'} } );
2532 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2533 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2534 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2535 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2540 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2544 =head2 _load_container_object ( $type, $id );
2546 Instantiate container object for saving searches.
2550 sub _load_container_object {
2551 my ( $obj_type, $obj_id ) = @_;
2552 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2555 =head2 _parse_saved_search ( $arg );
2557 Given a serialization string for saved search, and returns the
2558 container object and the search id.
2562 sub _parse_saved_search {
2564 return unless $spec;
2565 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2572 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2575 =head2 ScrubHTML content
2577 Removes unsafe and undesired HTML from the passed content
2583 my $Content = shift;
2584 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2586 $Content = '' if !defined($Content);
2587 return $SCRUBBER->scrub($Content);
2592 Returns a new L<HTML::Scrubber> object.
2594 If you need to be more lax about what HTML tags and attributes are allowed,
2595 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2598 package HTML::Mason::Commands;
2599 # Let tables through
2600 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2605 our @SCRUBBER_ALLOWED_TAGS = qw(
2606 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2607 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2610 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2611 # Match http, ftp and relative urls
2612 # XXX: we also scrub format strings with this module then allow simple config options
2613 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2619 (?:(?:background-)?color: \s*
2620 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
2621 \#[a-f0-9]{3,6} | # #fff or #ffffff
2622 [\w\-]+ # green, light-blue, etc.
2624 text-align: \s* \w+ |
2625 font-size: \s* [\w.\-]+ |
2626 font-family: \s* [\w\s"',.\-]+ |
2627 font-weight: \s* [\w\-]+ |
2629 # MS Office styles, which are probably fine. If we don't, then any
2630 # associated styles in the same attribute get stripped.
2631 mso-[\w\-]+?: \s* [\w\s"',.\-]+
2633 +$ # one or more of these allowed properties from here 'till sunset
2637 our %SCRUBBER_RULES = ();
2640 require HTML::Scrubber;
2641 my $scrubber = HTML::Scrubber->new();
2645 %SCRUBBER_ALLOWED_ATTRIBUTES,
2646 '*' => 0, # require attributes be explicitly allowed
2649 $scrubber->deny(qw[*]);
2650 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2651 $scrubber->rules(%SCRUBBER_RULES);
2653 # Scrubbing comments is vital since IE conditional comments can contain
2654 # arbitrary HTML and we'd pass it right on through.
2655 $scrubber->comment(0);
2660 package RT::Interface::Web;
2661 RT::Base->_ImportOverlays();