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 # {{{ WebCanonicalizeInfo
115 =head2 WebCanonicalizeInfo();
117 Different web servers set different environmental varibles. This
118 function must return something suitable for REMOTE_USER. By default,
119 just downcase $ENV{'REMOTE_USER'}
123 sub WebCanonicalizeInfo {
124 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
129 # {{{ WebExternalAutoInfo
131 =head2 WebExternalAutoInfo($user);
133 Returns a hash of user attributes, used when WebExternalAuto is set.
137 sub WebExternalAutoInfo {
142 # default to making Privileged users, even if they specify
143 # some other default Attributes
144 if ( !$RT::AutoCreate
145 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
147 $user_info{'Privileged'} = 1;
150 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
152 # Populate fields with information from Unix /etc/passwd
154 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
155 $user_info{'Comments'} = $comments if defined $comments;
156 $user_info{'RealName'} = $realname if defined $realname;
157 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
159 # Populate fields with information from NT domain controller
162 # and return the wad of stuff
171 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
173 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
175 # Roll back any dangling transactions from a previous failed connection
176 $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth;
178 MaybeEnableSQLStatementLog();
180 # avoid reentrancy, as suggested by masonbook
181 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
183 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
184 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
187 PreprocessTimeUpdates($ARGS);
189 MaybeShowInstallModePage();
191 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
193 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
195 # Process session-related callbacks before any auth attempts
196 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
198 MaybeRejectPrivateComponentRequest();
200 MaybeShowNoAuthPage($ARGS);
202 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
204 _ForceLogout() unless _UserLoggedIn();
206 # Process per-page authentication callbacks
207 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
209 unless ( _UserLoggedIn() ) {
212 # Authenticate if the user is trying to login via user/pass query args
213 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
216 my $m = $HTML::Mason::Commands::m;
218 # REST urls get a special 401 response
219 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
220 $HTML::Mason::Commands::r->content_type("text/plain");
221 $m->error_format("text");
222 $m->out("RT/$RT::VERSION 401 Credentials required\n");
223 $m->out("\n$msg\n") if $msg;
226 # Specially handle /index.html so that we get a nicer URL
227 elsif ( $m->request_comp->path eq '/index.html' ) {
228 my $next = SetNextPage(RT->Config->Get('WebURL'));
229 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
233 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
238 # now it applies not only to home page, but any dashboard that can be used as a workspace
239 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
240 if ( $ARGS->{'HomeRefreshInterval'} );
242 # Process per-page global callbacks
243 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
245 ShowRequestedPage($ARGS);
246 LogRecordedSQLStatements();
248 # Process per-page final cleanup callbacks
249 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
254 delete $HTML::Mason::Commands::session{'CurrentUser'};
258 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
266 =head2 LoginError ERROR
268 Pushes a login error into the Actions session store and returns the hash key.
274 my $key = Digest::MD5::md5_hex( rand(1024) );
275 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
276 $HTML::Mason::Commands::session{'i'}++;
280 =head2 SetNextPage [PATH]
282 Intuits and stashes the next page in the sesssion hash. If PATH is
283 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
289 my $next = shift || IntuitNextPage();
290 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
292 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
293 $HTML::Mason::Commands::session{'i'}++;
300 =head2 TangentForLogin [HASH]
302 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
303 the next page. Optionally takes a hash which is dumped into query params.
307 sub TangentForLogin {
308 my $hash = SetNextPage();
309 my %query = (@_, next => $hash);
310 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
311 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
315 =head2 TangentForLoginWithError ERROR
317 Localizes the passed error message, stashes it with L<LoginError> and then
318 calls L<TangentForLogin> with the appropriate results key.
322 sub TangentForLoginWithError {
323 my $key = LoginError(HTML::Mason::Commands::loc(@_));
324 TangentForLogin( results => $key );
327 =head2 IntuitNextPage
329 Attempt to figure out the path to which we should return the user after a
330 tangent. The current request URL is used, or failing that, the C<WebURL>
331 configuration variable.
338 # This includes any query parameters. Redirect will take care of making
339 # it an absolute URL.
340 if ($ENV{'REQUEST_URI'}) {
341 $req_uri = $ENV{'REQUEST_URI'};
343 # collapse multiple leading slashes so the first part doesn't look like
344 # a hostname of a schema-less URI
345 $req_uri =~ s{^/+}{/};
348 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
351 my $uri = URI->new($next);
353 # You get undef scheme with a relative uri like "/Search/Build.html"
354 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
355 $next = RT->Config->Get('WebURL');
358 # Make sure we're logging in to the same domain
359 # You can get an undef authority with a relative uri like "index.html"
360 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
361 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
362 $next = RT->Config->Get('WebURL');
368 =head2 MaybeShowInstallModePage
370 This function, called exclusively by RT's autohandler, dispatches
371 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
373 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
377 sub MaybeShowInstallModePage {
378 return unless RT->InstallMode;
380 my $m = $HTML::Mason::Commands::m;
381 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
383 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
384 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
391 =head2 MaybeShowNoAuthPage \%ARGS
393 This function, called exclusively by RT's autohandler, dispatches
394 a request to the page a user requested (but only if it matches the "noauth" regex.
396 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
400 sub MaybeShowNoAuthPage {
403 my $m = $HTML::Mason::Commands::m;
405 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
407 # Don't show the login page to logged in users
408 Redirect(RT->Config->Get('WebURL'))
409 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
411 # If it's a noauth file, don't ask for auth.
413 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
417 =head2 MaybeRejectPrivateComponentRequest
419 This function will reject calls to private components, like those under
420 C</Elements>. If the requested path is a private component then we will
421 abort with a C<403> error.
425 sub MaybeRejectPrivateComponentRequest {
426 my $m = $HTML::Mason::Commands::m;
427 my $path = $m->request_comp->path;
429 # We do not check for dhandler here, because requesting our dhandlers
430 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
436 _elements | # mobile UI
438 autohandler | # requesting this directly is suspicious
440 ( $ | / ) # trailing slash or end of path
448 =head2 ShowRequestedPage \%ARGS
450 This function, called exclusively by RT's autohandler, dispatches
451 a request to the page a user requested (making sure that unpriviled users
452 can only see self-service pages.
456 sub ShowRequestedPage {
459 my $m = $HTML::Mason::Commands::m;
463 # If the user isn't privileged, they can only see SelfService
464 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
466 # if the user is trying to access a ticket, redirect them
467 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
468 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
471 # otherwise, drop the user at the SelfService default page
472 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
473 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
476 # if user is in SelfService dir let him do anything
478 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
481 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
486 sub AttemptExternalAuth {
489 return unless ( RT->Config->Get('WebExternalAuth') );
491 my $user = $ARGS->{user};
492 my $m = $HTML::Mason::Commands::m;
494 # If RT is configured for external auth, let's go through and get REMOTE_USER
496 # do we actually have a REMOTE_USER equivlent?
497 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
498 my $orig_user = $user;
500 $user = RT::Interface::Web::WebCanonicalizeInfo();
501 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
503 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
504 my $NodeName = Win32::NodeName();
505 $user =~ s/^\Q$NodeName\E\\//i;
508 InstantiateNewSession() unless _UserLoggedIn;
509 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
510 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
512 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
514 # Create users on-the-fly
515 my $UserObj = RT::User->new($RT::SystemUser);
516 my ( $val, $msg ) = $UserObj->Create(
517 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
524 # now get user specific information, to better create our user.
525 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
527 # set the attributes that have been defined.
528 foreach my $attribute ( $UserObj->WritableAttributes ) {
530 Attribute => $attribute,
532 UserInfo => $new_user_info,
533 CallbackName => 'NewUser',
534 CallbackPage => '/autohandler'
536 my $method = "Set$attribute";
537 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
539 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
542 # we failed to successfully create the user. abort abort abort.
543 delete $HTML::Mason::Commands::session{'CurrentUser'};
545 if (RT->Config->Get('WebFallbackToInternalAuth')) {
546 TangentForLoginWithError('Cannot create user: [_1]', $msg);
553 if ( _UserLoggedIn() ) {
554 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
556 delete $HTML::Mason::Commands::session{'CurrentUser'};
559 if ( RT->Config->Get('WebExternalOnly') ) {
560 TangentForLoginWithError('You are not an authorized user');
563 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
564 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
565 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
566 TangentForLoginWithError('You are not an authorized user');
570 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
571 # XXX: we must return AUTH_REQUIRED status or we fallback to
572 # internal auth here too.
573 delete $HTML::Mason::Commands::session{'CurrentUser'}
574 if defined $HTML::Mason::Commands::session{'CurrentUser'};
578 sub AttemptPasswordAuthentication {
580 return unless defined $ARGS->{user} && defined $ARGS->{pass};
582 my $user_obj = RT::CurrentUser->new();
583 $user_obj->Load( $ARGS->{user} );
585 my $m = $HTML::Mason::Commands::m;
587 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
588 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
589 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
590 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
593 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
595 # It's important to nab the next page from the session before we blow
597 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
599 InstantiateNewSession();
600 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
603 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
605 # Really the only time we don't want to redirect here is if we were
606 # passed user and pass as query params in the URL.
610 elsif ($ARGS->{'next'}) {
611 # Invalid hash, but still wants to go somewhere, take them to /
612 Redirect(RT->Config->Get('WebURL'));
615 return (1, HTML::Mason::Commands::loc('Logged in'));
619 =head2 LoadSessionFromCookie
621 Load or setup a session cookie for the current user.
625 sub _SessionCookieName {
626 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
627 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
631 sub LoadSessionFromCookie {
633 my %cookies = CGI::Cookie->fetch;
634 my $cookiename = _SessionCookieName();
635 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
636 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
637 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
638 undef $cookies{$cookiename};
640 if ( int RT->Config->Get('AutoLogoff') ) {
641 my $now = int( time / 60 );
642 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
644 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
645 InstantiateNewSession();
648 # save session on each request when AutoLogoff is turned on
649 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
653 sub InstantiateNewSession {
654 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
655 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
658 sub SendSessionCookie {
659 my $cookie = CGI::Cookie->new(
660 -name => _SessionCookieName(),
661 -value => $HTML::Mason::Commands::session{_session_id},
662 -path => RT->Config->Get('WebPath'),
663 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 )
666 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
671 This routine ells the current user's browser to redirect to URL.
672 Additionally, it unties the user's currently active session, helping to avoid
673 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
674 a cached DBI statement handle twice at the same time.
679 my $redir_to = shift;
680 untie $HTML::Mason::Commands::session;
681 my $uri = URI->new($redir_to);
682 my $server_uri = URI->new( RT->Config->Get('WebURL') );
684 # Make relative URIs absolute from the server host and scheme
685 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
686 if (not defined $uri->host) {
687 $uri->host($server_uri->host);
688 $uri->port($server_uri->port);
691 # If the user is coming in via a non-canonical
692 # hostname, don't redirect them to the canonical host,
693 # it will just upset them (and invalidate their credentials)
694 # don't do this if $RT::CanoniaclRedirectURLs is true
695 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
696 && $uri->host eq $server_uri->host
697 && $uri->port eq $server_uri->port )
699 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
700 $uri->scheme('https');
702 $uri->scheme('http');
705 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
706 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
707 $uri->port( $ENV{'SERVER_PORT'} );
710 # not sure why, but on some systems without this call mason doesn't
711 # set status to 302, but 200 instead and people see blank pages
712 $HTML::Mason::Commands::r->status(302);
714 # Perlbal expects a status message, but Mason's default redirect status
715 # doesn't provide one. See also rt.cpan.org #36689.
716 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
718 $HTML::Mason::Commands::m->abort;
721 =head2 StaticFileHeaders
723 Send the browser a few headers to try to get it to (somewhat agressively)
724 cache RT's static Javascript and CSS files.
726 This routine could really use _accurate_ heuristics. (XXX TODO)
730 sub StaticFileHeaders {
731 my $date = RT::Date->new($RT::SystemUser);
734 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
736 # Expire things in a month.
737 $date->Set( Value => time + 30 * 24 * 60 * 60 );
738 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
740 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
741 # request, but we don't handle it and generate full reply again
742 # Last modified at server start time
743 # $date->Set( Value => $^T );
744 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
749 Takes a C<< Path => path >> and returns a boolean indicating that
750 the path is safely within RT's control or not. The path I<must> be
753 This function does not consult the filesystem at all; it is merely
754 a logical sanity checking of the path. This explicitly does not handle
755 symlinks; if you have symlinks in RT's webroot pointing outside of it,
756 then we assume you know what you are doing.
763 my $path = $args{Path};
765 # Get File::Spec to clean up extra /s, ./, etc
766 my $cleaned_up = File::Spec->canonpath($path);
768 if (!defined($cleaned_up)) {
769 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
773 # Forbid too many ..s. We can't just sum then check because
774 # "../foo/bar/baz" should be illegal even though it has more
775 # downdirs than updirs. So as soon as we get a negative score
776 # (which means "breaking out" of the top level) we reject the path.
778 my @components = split '/', $cleaned_up;
780 for my $component (@components) {
781 if ($component eq '..') {
784 $RT::Logger->info("Rejecting unsafe path: $path");
788 elsif ($component eq '.' || $component eq '') {
789 # these two have no effect on $score
799 =head2 SendStaticFile
801 Takes a File => path and a Type => Content-type
803 If Type isn't provided and File is an image, it will
804 figure out a sane Content-type, otherwise it will
805 send application/octet-stream
807 Will set caching headers using StaticFileHeaders
814 my $file = $args{File};
815 my $type = $args{Type};
816 my $relfile = $args{RelativeFile};
818 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
819 $HTML::Mason::Commands::r->status(400);
820 $HTML::Mason::Commands::m->abort;
823 $self->StaticFileHeaders();
826 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
828 $type =~ s/jpg/jpeg/gi;
830 $type ||= "application/octet-stream";
833 # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
834 # since we don't specify a charset
835 if ( $type =~ m{application/javascript} &&
836 $type !~ m{charset=([\w-]+)$} ) {
837 $type .= "; charset=utf-8";
839 $HTML::Mason::Commands::r->content_type($type);
840 open( my $fh, '<', $file ) or die "couldn't open file: $!";
844 $HTML::Mason::Commands::m->out($_) while (<$fh>);
845 $HTML::Mason::Commands::m->flush_buffer;
852 my $content = $args{Content};
853 return '' unless $content;
855 # Make the content have no 'weird' newlines in it
856 $content =~ s/\r+\n/\n/g;
858 my $return_content = $content;
860 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
861 my $sigonly = $args{StripSignature};
863 # massage content to easily detect if there's any real content
864 $content =~ s/\s+//g; # yes! remove all the spaces
866 # remove html version of spaces and newlines
867 $content =~ s! !!g;
868 $content =~ s!<br/?>!!g;
871 # Filter empty content when type is text/html
872 return '' if $html && $content !~ /\S/;
874 # If we aren't supposed to strip the sig, just bail now.
875 return $return_content unless $sigonly;
878 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
881 # Check for plaintext sig
882 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
884 # Check for html-formatted sig; we don't use EscapeUTF8 here
885 # because we want to precisely match the escaping that FCKEditor
886 # uses. see also 311223f5, which fixed this for 4.0
893 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
896 return $return_content;
904 # if they've passed multiple values, they'll be an array. if they've
905 # passed just one, a scalar whatever they are, mark them as utf8
908 ? Encode::is_utf8($_)
910 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
911 : ( $type eq 'ARRAY' )
912 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
914 : ( $type eq 'HASH' )
915 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
921 sub PreprocessTimeUpdates {
924 # Later in the code we use
925 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
926 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
927 # The call_next method pass through original arguments and if you have
928 # an argument with unicode key then in a next component you'll get two
929 # records in the args hash: one with key without UTF8 flag and another
930 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
931 # is copied from mason's source to get the same results as we get from
932 # call_next method, this feature is not documented, so we just leave it
933 # here to avoid possible side effects.
935 # This code canonicalizes time inputs in hours into minutes
936 foreach my $field ( keys %$ARGS ) {
937 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
939 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
940 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
941 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
942 $ARGS->{$local} *= 60;
944 delete $ARGS->{$field};
949 sub MaybeEnableSQLStatementLog {
951 my $log_sql_statements = RT->Config->Get('StatementLog');
953 if ($log_sql_statements) {
954 $RT::Handle->ClearSQLStatementLog;
955 $RT::Handle->LogSQLStatements(1);
960 sub LogRecordedSQLStatements {
961 my $log_sql_statements = RT->Config->Get('StatementLog');
963 return unless ($log_sql_statements);
965 my @log = $RT::Handle->SQLStatementLog;
966 $RT::Handle->ClearSQLStatementLog;
967 for my $stmt (@log) {
968 my ( $time, $sql, $bind, $duration ) = @{$stmt};
978 level => $log_sql_statements,
980 . sprintf( "%.6f", $duration )
982 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
988 package HTML::Mason::Commands;
990 use vars qw/$r $m %session/;
996 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
997 with whatever it's called with. If there is no $session{'CurrentUser'},
998 it creates a temporary user, so we have something to get a localisation handle
1005 if ( $session{'CurrentUser'}
1006 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1008 return ( $session{'CurrentUser'}->loc(@_) );
1011 RT::CurrentUser->new();
1015 return ( $u->loc(@_) );
1018 # pathetic case -- SystemUser is gone.
1027 =head2 loc_fuzzy STRING
1029 loc_fuzzy is for handling localizations of messages that may already
1030 contain interpolated variables, typically returned from libraries
1031 outside RT's control. It takes the message string and extracts the
1032 variable array automatically by matching against the candidate entries
1033 inside the lexicon file.
1040 if ( $session{'CurrentUser'}
1041 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1043 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1045 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1046 return ( $u->loc_fuzzy($msg) );
1053 # Error - calls Error and aborts
1058 if ( $session{'ErrorDocument'}
1059 && $session{'ErrorDocumentType'} )
1061 $r->content_type( $session{'ErrorDocumentType'} );
1062 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1065 $m->comp( "/Elements/Error", Why => $why, %args );
1072 # {{{ sub CreateTicket
1074 =head2 CreateTicket ARGS
1076 Create a new ticket, using Mason's %ARGS. returns @results.
1085 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1087 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1088 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1089 Abort('Queue not found');
1092 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1093 Abort('You have no permission to create tickets in that queue.');
1097 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1098 $due = new RT::Date( $session{'CurrentUser'} );
1099 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1102 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1103 $starts = new RT::Date( $session{'CurrentUser'} );
1104 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1107 my $sigless = RT::Interface::Web::StripContent(
1108 Content => $ARGS{Content},
1109 ContentType => $ARGS{ContentType},
1110 StripSignature => 1,
1111 CurrentUser => $session{'CurrentUser'},
1114 my $MIMEObj = MakeMIMEEntity(
1115 Subject => $ARGS{'Subject'},
1116 From => $ARGS{'From'},
1119 Type => $ARGS{'ContentType'},
1122 if ( $ARGS{'Attachments'} ) {
1123 my $rv = $MIMEObj->make_multipart;
1124 $RT::Logger->error("Couldn't make multipart message")
1125 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1127 foreach ( values %{ $ARGS{'Attachments'} } ) {
1129 $RT::Logger->error("Couldn't add empty attachemnt");
1132 $MIMEObj->add_part($_);
1136 foreach my $argument (qw(Encrypt Sign)) {
1137 $MIMEObj->head->add(
1138 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1139 ) if defined $ARGS{$argument};
1143 Type => $ARGS{'Type'} || 'ticket',
1144 Queue => $ARGS{'Queue'},
1145 Owner => $ARGS{'Owner'},
1148 Requestor => $ARGS{'Requestors'},
1150 AdminCc => $ARGS{'AdminCc'},
1151 InitialPriority => $ARGS{'InitialPriority'},
1152 FinalPriority => $ARGS{'FinalPriority'},
1153 TimeLeft => $ARGS{'TimeLeft'},
1154 TimeEstimated => $ARGS{'TimeEstimated'},
1155 TimeWorked => $ARGS{'TimeWorked'},
1156 Subject => $ARGS{'Subject'},
1157 Status => $ARGS{'Status'},
1158 Due => $due ? $due->ISO : undef,
1159 Starts => $starts ? $starts->ISO : undef,
1164 foreach my $type (qw(Requestor Cc AdminCc)) {
1165 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1166 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1170 if (@temp_squelch) {
1171 require RT::Action::SendEmail;
1172 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1175 if ( $ARGS{'AttachTickets'} ) {
1176 require RT::Action::SendEmail;
1177 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1178 ref $ARGS{'AttachTickets'}
1179 ? @{ $ARGS{'AttachTickets'} }
1180 : ( $ARGS{'AttachTickets'} ) );
1183 foreach my $arg ( keys %ARGS ) {
1184 next if $arg =~ /-(?:Magic|Category)$/;
1186 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1187 $create_args{$arg} = $ARGS{$arg};
1190 # Object-RT::Ticket--CustomField-3-Values
1191 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1194 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1196 unless ( $cf->id ) {
1197 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1201 if ( $arg =~ /-Upload$/ ) {
1202 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1206 my $type = $cf->Type;
1209 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1210 @values = @{ $ARGS{$arg} };
1211 } elsif ( $type =~ /text/i ) {
1212 @values = ( $ARGS{$arg} );
1214 no warnings 'uninitialized';
1215 @values = split /\r*\n/, $ARGS{$arg};
1217 @values = grep length, map {
1223 grep defined, @values;
1225 $create_args{"CustomField-$cfid"} = \@values;
1229 # turn new link lists into arrays, and pass in the proper arguments
1231 'new-DependsOn' => 'DependsOn',
1232 'DependsOn-new' => 'DependedOnBy',
1233 'new-MemberOf' => 'Parents',
1234 'MemberOf-new' => 'Children',
1235 'new-RefersTo' => 'RefersTo',
1236 'RefersTo-new' => 'ReferredToBy',
1238 foreach my $key ( keys %map ) {
1239 next unless $ARGS{$key};
1240 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1244 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1249 push( @Actions, split( "\n", $ErrMsg ) );
1250 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1251 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1253 return ( $Ticket, @Actions );
1259 # {{{ sub LoadTicket - loads a ticket
1261 =head2 LoadTicket id
1263 Takes a ticket id as its only variable. if it's handed an array, it takes
1266 Returns an RT::Ticket object as the current user.
1273 if ( ref($id) eq "ARRAY" ) {
1278 Abort("No ticket specified");
1281 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1283 unless ( $Ticket->id ) {
1284 Abort("Could not load ticket $id");
1291 # {{{ sub ProcessUpdateMessage
1293 =head2 ProcessUpdateMessage
1295 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1297 Don't write message if it only contains current user's signature and
1298 SkipSignatureOnly argument is true. Function anyway adds attachments
1299 and updates time worked field even if skips message. The default value
1304 sub ProcessUpdateMessage {
1309 SkipSignatureOnly => 1,
1313 if ( $args{ARGSRef}->{'UpdateAttachments'}
1314 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1316 delete $args{ARGSRef}->{'UpdateAttachments'};
1319 # Strip the signature
1320 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1321 Content => $args{ARGSRef}->{UpdateContent},
1322 ContentType => $args{ARGSRef}->{UpdateContentType},
1323 StripSignature => $args{SkipSignatureOnly},
1324 CurrentUser => $args{'TicketObj'}->CurrentUser,
1327 # If, after stripping the signature, we have no message, move the
1328 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1329 # ProcessBasics can deal -- then bail out.
1330 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1331 and not length $args{ARGSRef}->{'UpdateContent'} )
1333 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1334 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1339 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1340 $args{ARGSRef}->{'UpdateSubject'} = undef;
1343 my $Message = MakeMIMEEntity(
1344 Subject => $args{ARGSRef}->{'UpdateSubject'},
1345 Body => $args{ARGSRef}->{'UpdateContent'},
1346 Type => $args{ARGSRef}->{'UpdateContentType'},
1349 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1350 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1352 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1353 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1354 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1356 $old_txn = $args{TicketObj}->Transactions->First();
1359 if ( my $msg = $old_txn->Message->First ) {
1360 RT::Interface::Email::SetInReplyTo(
1361 Message => $Message,
1366 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1367 $Message->make_multipart;
1368 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1371 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1372 require RT::Action::SendEmail;
1373 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1374 ref $args{ARGSRef}->{'AttachTickets'}
1375 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1376 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1379 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1380 my $cc = $args{ARGSRef}->{'UpdateCc'};
1382 my %txn_customfields;
1384 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1385 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1386 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1390 my %message_args = (
1392 BccMessageTo => $bcc,
1393 Sign => $args{ARGSRef}->{'Sign'},
1394 Encrypt => $args{ARGSRef}->{'Encrypt'},
1395 MIMEObj => $Message,
1396 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1397 CustomFields => \%txn_customfields,
1401 foreach my $type (qw(Cc AdminCc)) {
1402 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1403 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1404 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1405 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1408 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1409 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1410 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1413 if (@temp_squelch) {
1414 require RT::Action::SendEmail;
1415 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1418 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1419 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1420 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1422 my $var = ucfirst($1) . 'MessageTo';
1424 if ( $message_args{$var} ) {
1425 $message_args{$var} .= ", $value";
1427 $message_args{$var} = $value;
1433 # Do the update via the appropriate Ticket method
1434 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1435 my ( $Transaction, $Description, $Object ) =
1436 $args{TicketObj}->Comment(%message_args);
1437 push( @results, $Description );
1438 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1439 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1440 my ( $Transaction, $Description, $Object ) =
1441 $args{TicketObj}->Correspond(%message_args);
1442 push( @results, $Description );
1443 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1446 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1453 # {{{ sub MakeMIMEEntity
1455 =head2 MakeMIMEEntity PARAMHASH
1457 Takes a paramhash Subject, Body and AttachmentFieldName.
1459 Also takes Form, Cc and Type as optional paramhash keys.
1461 Returns a MIME::Entity.
1465 sub MakeMIMEEntity {
1467 #TODO document what else this takes.
1473 AttachmentFieldName => undef,
1477 my $Message = MIME::Entity->build(
1478 Type => 'multipart/mixed',
1479 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1480 grep defined $args{$_}, qw(Subject From Cc)
1483 if ( defined $args{'Body'} && length $args{'Body'} ) {
1485 # Make the update content have no 'weird' newlines in it
1486 $args{'Body'} =~ s/\r\n/\n/gs;
1489 Type => $args{'Type'} || 'text/plain',
1491 Data => $args{'Body'},
1495 if ( $args{'AttachmentFieldName'} ) {
1497 my $cgi_object = $m->cgi_object;
1499 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1501 my ( @content, $buffer );
1502 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1503 push @content, $buffer;
1506 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1508 # Prefer the cached name first over CGI.pm stringification.
1509 my $filename = $RT::Mason::CGI::Filename;
1510 $filename = "$filehandle" unless defined $filename;
1511 $filename = Encode::encode_utf8( $filename );
1512 $filename =~ s{^.*[\\/]}{};
1515 Type => $uploadinfo->{'Content-Type'},
1516 Filename => $filename,
1519 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1520 $Message->head->set( 'Subject' => $filename );
1525 $Message->make_singlepart;
1527 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1535 # {{{ sub ParseDateToISO
1537 =head2 ParseDateToISO
1539 Takes a date in an arbitrary format.
1540 Returns an ISO date and time in GMT
1544 sub ParseDateToISO {
1547 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1549 Format => 'unknown',
1552 return ( $date_obj->ISO );
1557 # {{{ sub ProcessACLChanges
1559 sub ProcessACLChanges {
1560 my $ARGSref = shift;
1564 foreach my $arg ( keys %$ARGSref ) {
1565 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1567 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1570 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1571 @rights = @{ $ARGSref->{$arg} };
1573 @rights = $ARGSref->{$arg};
1575 @rights = grep $_, @rights;
1576 next unless @rights;
1578 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1579 $principal->Load($principal_id);
1582 if ( $object_type eq 'RT::System' ) {
1584 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1585 $obj = $object_type->new( $session{'CurrentUser'} );
1586 $obj->Load($object_id);
1587 unless ( $obj->id ) {
1588 $RT::Logger->error("couldn't load $object_type #$object_id");
1592 $RT::Logger->error("object type '$object_type' is incorrect");
1593 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1597 foreach my $right (@rights) {
1598 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1599 push( @results, $msg );
1608 # {{{ sub UpdateRecordObj
1610 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1612 @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.
1614 Returns an array of success/failure messages
1618 sub UpdateRecordObject {
1621 AttributesRef => undef,
1623 AttributePrefix => undef,
1627 my $Object = $args{'Object'};
1628 my @results = $Object->Update(
1629 AttributesRef => $args{'AttributesRef'},
1630 ARGSRef => $args{'ARGSRef'},
1631 AttributePrefix => $args{'AttributePrefix'},
1639 # {{{ Sub ProcessCustomFieldUpdates
1641 sub ProcessCustomFieldUpdates {
1643 CustomFieldObj => undef,
1648 my $Object = $args{'CustomFieldObj'};
1649 my $ARGSRef = $args{'ARGSRef'};
1651 my @attribs = qw(Name Type Description Queue SortOrder);
1652 my @results = UpdateRecordObject(
1653 AttributesRef => \@attribs,
1658 my $prefix = "CustomField-" . $Object->Id;
1659 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1660 my ( $addval, $addmsg ) = $Object->AddValue(
1661 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1662 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1663 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1665 push( @results, $addmsg );
1669 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1670 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1671 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1673 foreach my $id (@delete_values) {
1674 next unless defined $id;
1675 my ( $err, $msg ) = $Object->DeleteValue($id);
1676 push( @results, $msg );
1679 my $vals = $Object->Values();
1680 while ( my $cfv = $vals->Next() ) {
1681 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1682 if ( $cfv->SortOrder != $so ) {
1683 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1684 push( @results, $msg );
1694 # {{{ sub ProcessTicketBasics
1696 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1698 Returns an array of results messages.
1702 sub ProcessTicketBasics {
1710 my $TicketObj = $args{'TicketObj'};
1711 my $ARGSRef = $args{'ARGSRef'};
1713 # {{{ Set basic fields
1726 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1727 my $tempqueue = RT::Queue->new($RT::SystemUser);
1728 $tempqueue->Load( $ARGSRef->{'Queue'} );
1729 if ( $tempqueue->id ) {
1730 $ARGSRef->{'Queue'} = $tempqueue->id;
1734 # Status isn't a field that can be set to a null value.
1735 # RT core complains if you try
1736 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1738 my @results = UpdateRecordObject(
1739 AttributesRef => \@attribs,
1740 Object => $TicketObj,
1741 ARGSRef => $ARGSRef,
1744 # We special case owner changing, so we can use ForceOwnerChange
1745 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1747 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1748 $ChownType = "Force";
1750 $ChownType = "Give";
1753 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1754 push( @results, $msg );
1764 sub ProcessTicketCustomFieldUpdates {
1766 $args{'Object'} = delete $args{'TicketObj'};
1767 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1769 # Build up a list of objects that we want to work with
1770 my %custom_fields_to_mod;
1771 foreach my $arg ( keys %$ARGSRef ) {
1772 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1773 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1774 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1775 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1776 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
1777 delete $ARGSRef->{$arg}; # don't try to update transaction fields
1781 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1784 sub ProcessObjectCustomFieldUpdates {
1786 my $ARGSRef = $args{'ARGSRef'};
1789 # Build up a list of objects that we want to work with
1790 my %custom_fields_to_mod;
1791 foreach my $arg ( keys %$ARGSRef ) {
1793 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1794 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1796 # For each of those objects, find out what custom fields we want to work with.
1797 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1800 # For each of those objects
1801 foreach my $class ( keys %custom_fields_to_mod ) {
1802 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1803 my $Object = $args{'Object'};
1804 $Object = $class->new( $session{'CurrentUser'} )
1805 unless $Object && ref $Object eq $class;
1807 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1808 unless ( $Object->id ) {
1809 $RT::Logger->warning("Couldn't load object $class #$id");
1813 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1814 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1815 $CustomFieldObj->LoadById($cf);
1816 unless ( $CustomFieldObj->id ) {
1817 $RT::Logger->warning("Couldn't load custom field #$cf");
1821 _ProcessObjectCustomFieldUpdates(
1822 Prefix => "Object-$class-$id-CustomField-$cf-",
1824 CustomField => $CustomFieldObj,
1825 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1833 sub _ProcessObjectCustomFieldUpdates {
1835 my $cf = $args{'CustomField'};
1836 my $cf_type = $cf->Type;
1838 # Remove blank Values since the magic field will take care of this. Sometimes
1839 # the browser gives you a blank value which causes CFs to be processed twice
1840 if ( defined $args{'ARGS'}->{'Values'}
1841 && !length $args{'ARGS'}->{'Values'}
1842 && $args{'ARGS'}->{'Values-Magic'} )
1844 delete $args{'ARGS'}->{'Values'};
1848 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1850 # skip category argument
1851 next if $arg eq 'Category';
1854 next if $arg eq 'Value-TimeUnits';
1856 # since http won't pass in a form element with a null value, we need
1858 if ( $arg eq 'Values-Magic' ) {
1860 # We don't care about the magic, if there's really a values element;
1861 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1862 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1864 # "Empty" values does not mean anything for Image and Binary fields
1865 next if $cf_type =~ /^(?:Image|Binary)$/;
1868 $args{'ARGS'}->{'Values'} = undef;
1872 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1873 @values = @{ $args{'ARGS'}->{$arg} };
1874 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1875 @values = ( $args{'ARGS'}->{$arg} );
1877 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1878 if defined $args{'ARGS'}->{$arg};
1880 @values = grep length, map {
1886 grep defined, @values;
1888 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1889 foreach my $value (@values) {
1890 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1894 push( @results, $msg );
1896 } elsif ( $arg eq 'Upload' ) {
1897 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1898 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1899 push( @results, $msg );
1900 } elsif ( $arg eq 'DeleteValues' ) {
1901 foreach my $value (@values) {
1902 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1906 push( @results, $msg );
1908 } elsif ( $arg eq 'DeleteValueIds' ) {
1909 foreach my $value (@values) {
1910 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1914 push( @results, $msg );
1916 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1917 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1920 foreach my $value (@values) {
1921 if ( my $entry = $cf_values->HasEntry($value) ) {
1922 $values_hash{ $entry->id } = 1;
1926 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1930 push( @results, $msg );
1931 $values_hash{$val} = 1 if $val;
1934 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1935 return @results if ( $cf->Type eq 'Date' && ! @values );
1937 $cf_values->RedoSearch;
1938 while ( my $cf_value = $cf_values->Next ) {
1939 next if $values_hash{ $cf_value->id };
1941 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1943 ValueId => $cf_value->id
1945 push( @results, $msg );
1947 } elsif ( $arg eq 'Values' ) {
1948 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1950 # keep everything up to the point of difference, delete the rest
1952 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1953 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1962 # now add/replace extra things, if any
1963 foreach my $value (@values) {
1964 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1968 push( @results, $msg );
1973 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1974 $cf->Name, ref $args{'Object'},
1983 # {{{ sub ProcessTicketWatchers
1985 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1987 Returns an array of results messages.
1991 sub ProcessTicketWatchers {
1999 my $Ticket = $args{'TicketObj'};
2000 my $ARGSRef = $args{'ARGSRef'};
2004 foreach my $key ( keys %$ARGSRef ) {
2006 # Delete deletable watchers
2007 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2008 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2012 push @results, $msg;
2015 # Delete watchers in the simple style demanded by the bulk manipulator
2016 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2017 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2018 Email => $ARGSRef->{$key},
2021 push @results, $msg;
2024 # Add new wathchers by email address
2025 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2026 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2029 #They're in this order because otherwise $1 gets clobbered :/
2030 my ( $code, $msg ) = $Ticket->AddWatcher(
2031 Type => $ARGSRef->{$key},
2032 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2034 push @results, $msg;
2037 #Add requestors in the simple style demanded by the bulk manipulator
2038 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2039 my ( $code, $msg ) = $Ticket->AddWatcher(
2041 Email => $ARGSRef->{$key}
2043 push @results, $msg;
2046 # Add new watchers by owner
2047 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2048 my $principal_id = $1;
2049 my $form = $ARGSRef->{$key};
2050 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2051 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2053 my ( $code, $msg ) = $Ticket->AddWatcher(
2055 PrincipalId => $principal_id
2057 push @results, $msg;
2067 # {{{ sub ProcessTicketDates
2069 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2071 Returns an array of results messages.
2075 sub ProcessTicketDates {
2082 my $Ticket = $args{'TicketObj'};
2083 my $ARGSRef = $args{'ARGSRef'};
2087 # {{{ Set date fields
2088 my @date_fields = qw(
2096 #Run through each field in this list. update the value if apropriate
2097 foreach my $field (@date_fields) {
2098 next unless exists $ARGSRef->{ $field . '_Date' };
2099 next if $ARGSRef->{ $field . '_Date' } eq '';
2103 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2105 Format => 'unknown',
2106 Value => $ARGSRef->{ $field . '_Date' }
2109 my $obj = $field . "Obj";
2110 if ( ( defined $DateObj->Unix )
2111 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2113 my $method = "Set$field";
2114 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2115 push @results, "$msg";
2125 # {{{ sub ProcessTicketLinks
2127 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2129 Returns an array of results messages.
2133 sub ProcessTicketLinks {
2140 my $Ticket = $args{'TicketObj'};
2141 my $ARGSRef = $args{'ARGSRef'};
2143 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2145 #Merge if we need to
2146 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2147 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2148 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2149 push @results, $msg;
2157 sub ProcessRecordLinks {
2164 my $Record = $args{'RecordObj'};
2165 my $ARGSRef = $args{'ARGSRef'};
2169 # Delete links that are gone gone gone.
2170 foreach my $arg ( keys %$ARGSRef ) {
2171 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2176 my ( $val, $msg ) = $Record->DeleteLink(
2182 push @results, $msg;
2188 my @linktypes = qw( DependsOn MemberOf RefersTo );
2190 foreach my $linktype (@linktypes) {
2191 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2192 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2193 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2195 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2197 $luri =~ s/\s+$//; # Strip trailing whitespace
2198 my ( $val, $msg ) = $Record->AddLink(
2202 push @results, $msg;
2205 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2206 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2207 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2209 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2211 my ( $val, $msg ) = $Record->AddLink(
2216 push @results, $msg;
2224 =head2 _UploadedFile ( $arg );
2226 Takes a CGI parameter name; if a file is uploaded under that name,
2227 return a hash reference suitable for AddCustomFieldValue's use:
2228 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2230 Returns C<undef> if no files were uploaded in the C<$arg> field.
2236 my $cgi_object = $m->cgi_object;
2237 my $fh = $cgi_object->upload($arg) or return undef;
2238 my $upload_info = $cgi_object->uploadInfo($fh);
2240 my $filename = "$fh";
2241 $filename =~ s#^.*[\\/]##;
2246 LargeContent => do { local $/; scalar <$fh> },
2247 ContentType => $upload_info->{'Content-Type'},
2251 sub GetColumnMapEntry {
2252 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2254 # deal with the simplest thing first
2255 if ( $args{'Map'}{ $args{'Name'} } ) {
2256 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2260 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2261 return undef unless $args{'Map'}->{$mainkey};
2262 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2263 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2265 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2270 sub ProcessColumnMapValue {
2272 my %args = ( Arguments => [], Escape => 1, @_ );
2275 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2276 my @tmp = $value->( @{ $args{'Arguments'} } );
2277 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2278 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2279 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2280 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2285 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2289 =head2 _load_container_object ( $type, $id );
2291 Instantiate container object for saving searches.
2295 sub _load_container_object {
2296 my ( $obj_type, $obj_id ) = @_;
2297 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2300 =head2 _parse_saved_search ( $arg );
2302 Given a serialization string for saved search, and returns the
2303 container object and the search id.
2307 sub _parse_saved_search {
2309 return unless $spec;
2310 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2317 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2320 package RT::Interface::Web;
2321 RT::Base->_ImportOverlays();