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
442 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
445 warn "rejecting private component $path\n";
452 =head2 ShowRequestedPage \%ARGS
454 This function, called exclusively by RT's autohandler, dispatches
455 a request to the page a user requested (making sure that unpriviled users
456 can only see self-service pages.
460 sub ShowRequestedPage {
463 my $m = $HTML::Mason::Commands::m;
467 # If the user isn't privileged, they can only see SelfService
468 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
470 # if the user is trying to access a ticket, redirect them
471 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
472 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
475 # otherwise, drop the user at the SelfService default page
476 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
477 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
480 # if user is in SelfService dir let him do anything
482 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
485 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
490 sub AttemptExternalAuth {
493 return unless ( RT->Config->Get('WebExternalAuth') );
495 my $user = $ARGS->{user};
496 my $m = $HTML::Mason::Commands::m;
498 # If RT is configured for external auth, let's go through and get REMOTE_USER
500 # do we actually have a REMOTE_USER equivlent?
501 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
502 my $orig_user = $user;
504 $user = RT::Interface::Web::WebCanonicalizeInfo();
505 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
507 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
508 my $NodeName = Win32::NodeName();
509 $user =~ s/^\Q$NodeName\E\\//i;
512 InstantiateNewSession() unless _UserLoggedIn;
513 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
514 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
516 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
518 # Create users on-the-fly
519 my $UserObj = RT::User->new($RT::SystemUser);
520 my ( $val, $msg ) = $UserObj->Create(
521 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
528 # now get user specific information, to better create our user.
529 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
531 # set the attributes that have been defined.
532 foreach my $attribute ( $UserObj->WritableAttributes ) {
534 Attribute => $attribute,
536 UserInfo => $new_user_info,
537 CallbackName => 'NewUser',
538 CallbackPage => '/autohandler'
540 my $method = "Set$attribute";
541 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
543 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
546 # we failed to successfully create the user. abort abort abort.
547 delete $HTML::Mason::Commands::session{'CurrentUser'};
549 if (RT->Config->Get('WebFallbackToInternalAuth')) {
550 TangentForLoginWithError('Cannot create user: [_1]', $msg);
557 if ( _UserLoggedIn() ) {
558 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
560 delete $HTML::Mason::Commands::session{'CurrentUser'};
563 if ( RT->Config->Get('WebExternalOnly') ) {
564 TangentForLoginWithError('You are not an authorized user');
567 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
568 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
569 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
570 TangentForLoginWithError('You are not an authorized user');
574 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
575 # XXX: we must return AUTH_REQUIRED status or we fallback to
576 # internal auth here too.
577 delete $HTML::Mason::Commands::session{'CurrentUser'}
578 if defined $HTML::Mason::Commands::session{'CurrentUser'};
582 sub AttemptPasswordAuthentication {
584 return unless defined $ARGS->{user} && defined $ARGS->{pass};
586 my $user_obj = RT::CurrentUser->new();
587 $user_obj->Load( $ARGS->{user} );
589 my $m = $HTML::Mason::Commands::m;
591 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
592 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
593 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
594 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
597 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
599 # It's important to nab the next page from the session before we blow
601 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
603 InstantiateNewSession();
604 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
607 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
609 # Really the only time we don't want to redirect here is if we were
610 # passed user and pass as query params in the URL.
614 elsif ($ARGS->{'next'}) {
615 # Invalid hash, but still wants to go somewhere, take them to /
616 Redirect(RT->Config->Get('WebURL'));
619 return (1, HTML::Mason::Commands::loc('Logged in'));
623 =head2 LoadSessionFromCookie
625 Load or setup a session cookie for the current user.
629 sub _SessionCookieName {
630 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
631 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
635 sub LoadSessionFromCookie {
637 my %cookies = CGI::Cookie->fetch;
638 my $cookiename = _SessionCookieName();
639 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
640 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
641 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
642 undef $cookies{$cookiename};
644 if ( int RT->Config->Get('AutoLogoff') ) {
645 my $now = int( time / 60 );
646 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
648 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
649 InstantiateNewSession();
652 # save session on each request when AutoLogoff is turned on
653 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
657 sub InstantiateNewSession {
658 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
659 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
662 sub SendSessionCookie {
663 my $cookie = CGI::Cookie->new(
664 -name => _SessionCookieName(),
665 -value => $HTML::Mason::Commands::session{_session_id},
666 -path => RT->Config->Get('WebPath'),
667 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
668 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
671 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
676 This routine ells the current user's browser to redirect to URL.
677 Additionally, it unties the user's currently active session, helping to avoid
678 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
679 a cached DBI statement handle twice at the same time.
684 my $redir_to = shift;
685 untie $HTML::Mason::Commands::session;
686 my $uri = URI->new($redir_to);
687 my $server_uri = URI->new( RT->Config->Get('WebURL') );
689 # Make relative URIs absolute from the server host and scheme
690 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
691 if (not defined $uri->host) {
692 $uri->host($server_uri->host);
693 $uri->port($server_uri->port);
696 # If the user is coming in via a non-canonical
697 # hostname, don't redirect them to the canonical host,
698 # it will just upset them (and invalidate their credentials)
699 # don't do this if $RT::CanoniaclRedirectURLs is true
700 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
701 && $uri->host eq $server_uri->host
702 && $uri->port eq $server_uri->port )
704 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
705 $uri->scheme('https');
707 $uri->scheme('http');
710 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
711 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
712 $uri->port( $ENV{'SERVER_PORT'} );
715 # not sure why, but on some systems without this call mason doesn't
716 # set status to 302, but 200 instead and people see blank pages
717 $HTML::Mason::Commands::r->status(302);
719 # Perlbal expects a status message, but Mason's default redirect status
720 # doesn't provide one. See also rt.cpan.org #36689.
721 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
723 $HTML::Mason::Commands::m->abort;
726 =head2 StaticFileHeaders
728 Send the browser a few headers to try to get it to (somewhat agressively)
729 cache RT's static Javascript and CSS files.
731 This routine could really use _accurate_ heuristics. (XXX TODO)
735 sub StaticFileHeaders {
736 my $date = RT::Date->new($RT::SystemUser);
739 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
741 # Expire things in a month.
742 $date->Set( Value => time + 30 * 24 * 60 * 60 );
743 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
745 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
746 # request, but we don't handle it and generate full reply again
747 # Last modified at server start time
748 # $date->Set( Value => $^T );
749 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
754 Takes a C<< Path => path >> and returns a boolean indicating that
755 the path is safely within RT's control or not. The path I<must> be
758 This function does not consult the filesystem at all; it is merely
759 a logical sanity checking of the path. This explicitly does not handle
760 symlinks; if you have symlinks in RT's webroot pointing outside of it,
761 then we assume you know what you are doing.
768 my $path = $args{Path};
770 # Get File::Spec to clean up extra /s, ./, etc
771 my $cleaned_up = File::Spec->canonpath($path);
773 if (!defined($cleaned_up)) {
774 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
778 # Forbid too many ..s. We can't just sum then check because
779 # "../foo/bar/baz" should be illegal even though it has more
780 # downdirs than updirs. So as soon as we get a negative score
781 # (which means "breaking out" of the top level) we reject the path.
783 my @components = split '/', $cleaned_up;
785 for my $component (@components) {
786 if ($component eq '..') {
789 $RT::Logger->info("Rejecting unsafe path: $path");
793 elsif ($component eq '.' || $component eq '') {
794 # these two have no effect on $score
804 =head2 SendStaticFile
806 Takes a File => path and a Type => Content-type
808 If Type isn't provided and File is an image, it will
809 figure out a sane Content-type, otherwise it will
810 send application/octet-stream
812 Will set caching headers using StaticFileHeaders
819 my $file = $args{File};
820 my $type = $args{Type};
821 my $relfile = $args{RelativeFile};
823 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
824 $HTML::Mason::Commands::r->status(400);
825 $HTML::Mason::Commands::m->abort;
828 $self->StaticFileHeaders();
831 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
833 $type =~ s/jpg/jpeg/gi;
835 $type ||= "application/octet-stream";
838 # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
839 # since we don't specify a charset
840 if ( $type =~ m{application/javascript} &&
841 $type !~ m{charset=([\w-]+)$} ) {
842 $type .= "; charset=utf-8";
844 $HTML::Mason::Commands::r->content_type($type);
845 open( my $fh, '<', $file ) or die "couldn't open file: $!";
849 $HTML::Mason::Commands::m->out($_) while (<$fh>);
850 $HTML::Mason::Commands::m->flush_buffer;
857 my $content = $args{Content};
858 return '' unless $content;
860 # Make the content have no 'weird' newlines in it
861 $content =~ s/\r+\n/\n/g;
863 my $return_content = $content;
865 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
866 my $sigonly = $args{StripSignature};
868 # massage content to easily detect if there's any real content
869 $content =~ s/\s+//g; # yes! remove all the spaces
871 # remove html version of spaces and newlines
872 $content =~ s! !!g;
873 $content =~ s!<br/?>!!g;
876 # Filter empty content when type is text/html
877 return '' if $html && $content !~ /\S/;
879 # If we aren't supposed to strip the sig, just bail now.
880 return $return_content unless $sigonly;
883 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
886 # Check for plaintext sig
887 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
889 # Check for html-formatted sig; we don't use EscapeUTF8 here
890 # because we want to precisely match the escaping that FCKEditor
891 # uses. see also 311223f5, which fixed this for 4.0
898 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
901 return $return_content;
909 # if they've passed multiple values, they'll be an array. if they've
910 # passed just one, a scalar whatever they are, mark them as utf8
913 ? Encode::is_utf8($_)
915 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
916 : ( $type eq 'ARRAY' )
917 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
919 : ( $type eq 'HASH' )
920 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
926 sub PreprocessTimeUpdates {
929 # Later in the code we use
930 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
931 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
932 # The call_next method pass through original arguments and if you have
933 # an argument with unicode key then in a next component you'll get two
934 # records in the args hash: one with key without UTF8 flag and another
935 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
936 # is copied from mason's source to get the same results as we get from
937 # call_next method, this feature is not documented, so we just leave it
938 # here to avoid possible side effects.
940 # This code canonicalizes time inputs in hours into minutes
941 foreach my $field ( keys %$ARGS ) {
942 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
944 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
945 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
946 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
947 $ARGS->{$local} *= 60;
949 delete $ARGS->{$field};
954 sub MaybeEnableSQLStatementLog {
956 my $log_sql_statements = RT->Config->Get('StatementLog');
958 if ($log_sql_statements) {
959 $RT::Handle->ClearSQLStatementLog;
960 $RT::Handle->LogSQLStatements(1);
965 sub LogRecordedSQLStatements {
966 my $log_sql_statements = RT->Config->Get('StatementLog');
968 return unless ($log_sql_statements);
970 my @log = $RT::Handle->SQLStatementLog;
971 $RT::Handle->ClearSQLStatementLog;
972 for my $stmt (@log) {
973 my ( $time, $sql, $bind, $duration ) = @{$stmt};
983 level => $log_sql_statements,
985 . sprintf( "%.6f", $duration )
987 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
993 package HTML::Mason::Commands;
995 use vars qw/$r $m %session/;
1001 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1002 with whatever it's called with. If there is no $session{'CurrentUser'},
1003 it creates a temporary user, so we have something to get a localisation handle
1010 if ( $session{'CurrentUser'}
1011 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1013 return ( $session{'CurrentUser'}->loc(@_) );
1016 RT::CurrentUser->new();
1020 return ( $u->loc(@_) );
1023 # pathetic case -- SystemUser is gone.
1032 =head2 loc_fuzzy STRING
1034 loc_fuzzy is for handling localizations of messages that may already
1035 contain interpolated variables, typically returned from libraries
1036 outside RT's control. It takes the message string and extracts the
1037 variable array automatically by matching against the candidate entries
1038 inside the lexicon file.
1045 if ( $session{'CurrentUser'}
1046 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1048 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1050 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1051 return ( $u->loc_fuzzy($msg) );
1058 # Error - calls Error and aborts
1063 if ( $session{'ErrorDocument'}
1064 && $session{'ErrorDocumentType'} )
1066 $r->content_type( $session{'ErrorDocumentType'} );
1067 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1070 $m->comp( "/Elements/Error", Why => $why, %args );
1077 # {{{ sub CreateTicket
1079 =head2 CreateTicket ARGS
1081 Create a new ticket, using Mason's %ARGS. returns @results.
1090 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1092 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1093 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1094 Abort('Queue not found');
1097 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1098 Abort('You have no permission to create tickets in that queue.');
1102 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1103 $due = new RT::Date( $session{'CurrentUser'} );
1104 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1107 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1108 $starts = new RT::Date( $session{'CurrentUser'} );
1109 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1112 my $sigless = RT::Interface::Web::StripContent(
1113 Content => $ARGS{Content},
1114 ContentType => $ARGS{ContentType},
1115 StripSignature => 1,
1116 CurrentUser => $session{'CurrentUser'},
1119 my $MIMEObj = MakeMIMEEntity(
1120 Subject => $ARGS{'Subject'},
1121 From => $ARGS{'From'},
1124 Type => $ARGS{'ContentType'},
1127 if ( $ARGS{'Attachments'} ) {
1128 my $rv = $MIMEObj->make_multipart;
1129 $RT::Logger->error("Couldn't make multipart message")
1130 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1132 foreach ( values %{ $ARGS{'Attachments'} } ) {
1134 $RT::Logger->error("Couldn't add empty attachemnt");
1137 $MIMEObj->add_part($_);
1141 foreach my $argument (qw(Encrypt Sign)) {
1142 $MIMEObj->head->add(
1143 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1144 ) if defined $ARGS{$argument};
1148 Type => $ARGS{'Type'} || 'ticket',
1149 Queue => $ARGS{'Queue'},
1150 Owner => $ARGS{'Owner'},
1153 Requestor => $ARGS{'Requestors'},
1155 AdminCc => $ARGS{'AdminCc'},
1156 InitialPriority => $ARGS{'InitialPriority'},
1157 FinalPriority => $ARGS{'FinalPriority'},
1158 TimeLeft => $ARGS{'TimeLeft'},
1159 TimeEstimated => $ARGS{'TimeEstimated'},
1160 TimeWorked => $ARGS{'TimeWorked'},
1161 Subject => $ARGS{'Subject'},
1162 Status => $ARGS{'Status'},
1163 Due => $due ? $due->ISO : undef,
1164 Starts => $starts ? $starts->ISO : undef,
1169 foreach my $type (qw(Requestor Cc AdminCc)) {
1170 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1171 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1175 if (@temp_squelch) {
1176 require RT::Action::SendEmail;
1177 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1180 if ( $ARGS{'AttachTickets'} ) {
1181 require RT::Action::SendEmail;
1182 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1183 ref $ARGS{'AttachTickets'}
1184 ? @{ $ARGS{'AttachTickets'} }
1185 : ( $ARGS{'AttachTickets'} ) );
1188 foreach my $arg ( keys %ARGS ) {
1189 next if $arg =~ /-(?:Magic|Category)$/;
1191 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1192 $create_args{$arg} = $ARGS{$arg};
1195 # Object-RT::Ticket--CustomField-3-Values
1196 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1199 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1201 unless ( $cf->id ) {
1202 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1206 if ( $arg =~ /-Upload$/ ) {
1207 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1211 my $type = $cf->Type;
1214 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1215 @values = @{ $ARGS{$arg} };
1216 } elsif ( $type =~ /text/i ) {
1217 @values = ( $ARGS{$arg} );
1219 no warnings 'uninitialized';
1220 @values = split /\r*\n/, $ARGS{$arg};
1222 @values = grep length, map {
1228 grep defined, @values;
1230 $create_args{"CustomField-$cfid"} = \@values;
1234 # turn new link lists into arrays, and pass in the proper arguments
1236 'new-DependsOn' => 'DependsOn',
1237 'DependsOn-new' => 'DependedOnBy',
1238 'new-MemberOf' => 'Parents',
1239 'MemberOf-new' => 'Children',
1240 'new-RefersTo' => 'RefersTo',
1241 'RefersTo-new' => 'ReferredToBy',
1243 foreach my $key ( keys %map ) {
1244 next unless $ARGS{$key};
1245 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1249 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1254 push( @Actions, split( "\n", $ErrMsg ) );
1255 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1256 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1258 return ( $Ticket, @Actions );
1264 # {{{ sub LoadTicket - loads a ticket
1266 =head2 LoadTicket id
1268 Takes a ticket id as its only variable. if it's handed an array, it takes
1271 Returns an RT::Ticket object as the current user.
1278 if ( ref($id) eq "ARRAY" ) {
1283 Abort("No ticket specified");
1286 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1288 unless ( $Ticket->id ) {
1289 Abort("Could not load ticket $id");
1296 # {{{ sub ProcessUpdateMessage
1298 =head2 ProcessUpdateMessage
1300 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1302 Don't write message if it only contains current user's signature and
1303 SkipSignatureOnly argument is true. Function anyway adds attachments
1304 and updates time worked field even if skips message. The default value
1309 sub ProcessUpdateMessage {
1314 SkipSignatureOnly => 1,
1318 if ( $args{ARGSRef}->{'UpdateAttachments'}
1319 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1321 delete $args{ARGSRef}->{'UpdateAttachments'};
1324 # Strip the signature
1325 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1326 Content => $args{ARGSRef}->{UpdateContent},
1327 ContentType => $args{ARGSRef}->{UpdateContentType},
1328 StripSignature => $args{SkipSignatureOnly},
1329 CurrentUser => $args{'TicketObj'}->CurrentUser,
1332 # If, after stripping the signature, we have no message, move the
1333 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1334 # ProcessBasics can deal -- then bail out.
1335 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1336 and not length $args{ARGSRef}->{'UpdateContent'} )
1338 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1339 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1344 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1345 $args{ARGSRef}->{'UpdateSubject'} = undef;
1348 my $Message = MakeMIMEEntity(
1349 Subject => $args{ARGSRef}->{'UpdateSubject'},
1350 Body => $args{ARGSRef}->{'UpdateContent'},
1351 Type => $args{ARGSRef}->{'UpdateContentType'},
1354 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1355 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1357 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1358 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1359 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1361 $old_txn = $args{TicketObj}->Transactions->First();
1364 if ( my $msg = $old_txn->Message->First ) {
1365 RT::Interface::Email::SetInReplyTo(
1366 Message => $Message,
1371 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1372 $Message->make_multipart;
1373 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1376 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1377 require RT::Action::SendEmail;
1378 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1379 ref $args{ARGSRef}->{'AttachTickets'}
1380 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1381 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1384 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1385 my $cc = $args{ARGSRef}->{'UpdateCc'};
1387 my %txn_customfields;
1389 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1390 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1391 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1395 my %message_args = (
1397 BccMessageTo => $bcc,
1398 Sign => $args{ARGSRef}->{'Sign'},
1399 Encrypt => $args{ARGSRef}->{'Encrypt'},
1400 MIMEObj => $Message,
1401 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1402 CustomFields => \%txn_customfields,
1406 foreach my $type (qw(Cc AdminCc)) {
1407 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1408 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1409 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1410 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1413 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1414 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1415 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1418 if (@temp_squelch) {
1419 require RT::Action::SendEmail;
1420 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1423 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1424 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1425 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1427 my $var = ucfirst($1) . 'MessageTo';
1429 if ( $message_args{$var} ) {
1430 $message_args{$var} .= ", $value";
1432 $message_args{$var} = $value;
1438 # Do the update via the appropriate Ticket method
1439 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1440 my ( $Transaction, $Description, $Object ) =
1441 $args{TicketObj}->Comment(%message_args);
1442 push( @results, $Description );
1443 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1444 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1445 my ( $Transaction, $Description, $Object ) =
1446 $args{TicketObj}->Correspond(%message_args);
1447 push( @results, $Description );
1448 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1451 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1458 # {{{ sub MakeMIMEEntity
1460 =head2 MakeMIMEEntity PARAMHASH
1462 Takes a paramhash Subject, Body and AttachmentFieldName.
1464 Also takes Form, Cc and Type as optional paramhash keys.
1466 Returns a MIME::Entity.
1470 sub MakeMIMEEntity {
1472 #TODO document what else this takes.
1478 AttachmentFieldName => undef,
1482 my $Message = MIME::Entity->build(
1483 Type => 'multipart/mixed',
1484 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1485 grep defined $args{$_}, qw(Subject From Cc)
1488 if ( defined $args{'Body'} && length $args{'Body'} ) {
1490 # Make the update content have no 'weird' newlines in it
1491 $args{'Body'} =~ s/\r\n/\n/gs;
1494 Type => $args{'Type'} || 'text/plain',
1496 Data => $args{'Body'},
1500 if ( $args{'AttachmentFieldName'} ) {
1502 my $cgi_object = $m->cgi_object;
1504 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1506 my ( @content, $buffer );
1507 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1508 push @content, $buffer;
1511 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1513 # Prefer the cached name first over CGI.pm stringification.
1514 my $filename = $RT::Mason::CGI::Filename;
1515 $filename = "$filehandle" unless defined $filename;
1516 $filename = Encode::encode_utf8( $filename );
1517 $filename =~ s{^.*[\\/]}{};
1520 Type => $uploadinfo->{'Content-Type'},
1521 Filename => $filename,
1524 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1525 $Message->head->set( 'Subject' => $filename );
1530 $Message->make_singlepart;
1532 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1540 # {{{ sub ParseDateToISO
1542 =head2 ParseDateToISO
1544 Takes a date in an arbitrary format.
1545 Returns an ISO date and time in GMT
1549 sub ParseDateToISO {
1552 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1554 Format => 'unknown',
1557 return ( $date_obj->ISO );
1562 # {{{ sub ProcessACLChanges
1564 sub ProcessACLChanges {
1565 my $ARGSref = shift;
1569 foreach my $arg ( keys %$ARGSref ) {
1570 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1572 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1575 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1576 @rights = @{ $ARGSref->{$arg} };
1578 @rights = $ARGSref->{$arg};
1580 @rights = grep $_, @rights;
1581 next unless @rights;
1583 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1584 $principal->Load($principal_id);
1587 if ( $object_type eq 'RT::System' ) {
1589 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1590 $obj = $object_type->new( $session{'CurrentUser'} );
1591 $obj->Load($object_id);
1592 unless ( $obj->id ) {
1593 $RT::Logger->error("couldn't load $object_type #$object_id");
1597 $RT::Logger->error("object type '$object_type' is incorrect");
1598 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1602 foreach my $right (@rights) {
1603 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1604 push( @results, $msg );
1613 # {{{ sub UpdateRecordObj
1615 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1617 @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.
1619 Returns an array of success/failure messages
1623 sub UpdateRecordObject {
1626 AttributesRef => undef,
1628 AttributePrefix => undef,
1632 my $Object = $args{'Object'};
1633 my @results = $Object->Update(
1634 AttributesRef => $args{'AttributesRef'},
1635 ARGSRef => $args{'ARGSRef'},
1636 AttributePrefix => $args{'AttributePrefix'},
1644 # {{{ Sub ProcessCustomFieldUpdates
1646 sub ProcessCustomFieldUpdates {
1648 CustomFieldObj => undef,
1653 my $Object = $args{'CustomFieldObj'};
1654 my $ARGSRef = $args{'ARGSRef'};
1656 my @attribs = qw(Name Type Description Queue SortOrder);
1657 my @results = UpdateRecordObject(
1658 AttributesRef => \@attribs,
1663 my $prefix = "CustomField-" . $Object->Id;
1664 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1665 my ( $addval, $addmsg ) = $Object->AddValue(
1666 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1667 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1668 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1670 push( @results, $addmsg );
1674 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1675 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1676 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1678 foreach my $id (@delete_values) {
1679 next unless defined $id;
1680 my ( $err, $msg ) = $Object->DeleteValue($id);
1681 push( @results, $msg );
1684 my $vals = $Object->Values();
1685 while ( my $cfv = $vals->Next() ) {
1686 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1687 if ( $cfv->SortOrder != $so ) {
1688 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1689 push( @results, $msg );
1699 # {{{ sub ProcessTicketBasics
1701 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1703 Returns an array of results messages.
1707 sub ProcessTicketBasics {
1715 my $TicketObj = $args{'TicketObj'};
1716 my $ARGSRef = $args{'ARGSRef'};
1718 # {{{ Set basic fields
1731 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1732 my $tempqueue = RT::Queue->new($RT::SystemUser);
1733 $tempqueue->Load( $ARGSRef->{'Queue'} );
1734 if ( $tempqueue->id ) {
1735 $ARGSRef->{'Queue'} = $tempqueue->id;
1739 # Status isn't a field that can be set to a null value.
1740 # RT core complains if you try
1741 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1743 my @results = UpdateRecordObject(
1744 AttributesRef => \@attribs,
1745 Object => $TicketObj,
1746 ARGSRef => $ARGSRef,
1749 # We special case owner changing, so we can use ForceOwnerChange
1750 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1752 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1753 $ChownType = "Force";
1755 $ChownType = "Give";
1758 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1759 push( @results, $msg );
1769 sub ProcessTicketCustomFieldUpdates {
1771 $args{'Object'} = delete $args{'TicketObj'};
1772 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1774 # Build up a list of objects that we want to work with
1775 my %custom_fields_to_mod;
1776 foreach my $arg ( keys %$ARGSRef ) {
1777 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1778 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1779 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1780 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1781 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
1782 delete $ARGSRef->{$arg}; # don't try to update transaction fields
1786 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1789 sub ProcessObjectCustomFieldUpdates {
1791 my $ARGSRef = $args{'ARGSRef'};
1794 # Build up a list of objects that we want to work with
1795 my %custom_fields_to_mod;
1796 foreach my $arg ( keys %$ARGSRef ) {
1798 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1799 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1801 # For each of those objects, find out what custom fields we want to work with.
1802 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1805 # For each of those objects
1806 foreach my $class ( keys %custom_fields_to_mod ) {
1807 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1808 my $Object = $args{'Object'};
1809 $Object = $class->new( $session{'CurrentUser'} )
1810 unless $Object && ref $Object eq $class;
1812 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1813 unless ( $Object->id ) {
1814 $RT::Logger->warning("Couldn't load object $class #$id");
1818 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1819 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1820 $CustomFieldObj->LoadById($cf);
1821 unless ( $CustomFieldObj->id ) {
1822 $RT::Logger->warning("Couldn't load custom field #$cf");
1826 _ProcessObjectCustomFieldUpdates(
1827 Prefix => "Object-$class-$id-CustomField-$cf-",
1829 CustomField => $CustomFieldObj,
1830 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1838 sub _ProcessObjectCustomFieldUpdates {
1840 my $cf = $args{'CustomField'};
1841 my $cf_type = $cf->Type;
1843 # Remove blank Values since the magic field will take care of this. Sometimes
1844 # the browser gives you a blank value which causes CFs to be processed twice
1845 if ( defined $args{'ARGS'}->{'Values'}
1846 && !length $args{'ARGS'}->{'Values'}
1847 && $args{'ARGS'}->{'Values-Magic'} )
1849 delete $args{'ARGS'}->{'Values'};
1853 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1855 # skip category argument
1856 next if $arg eq 'Category';
1859 next if $arg eq 'Value-TimeUnits';
1861 # since http won't pass in a form element with a null value, we need
1863 if ( $arg eq 'Values-Magic' ) {
1865 # We don't care about the magic, if there's really a values element;
1866 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1867 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1869 # "Empty" values does not mean anything for Image and Binary fields
1870 next if $cf_type =~ /^(?:Image|Binary)$/;
1873 $args{'ARGS'}->{'Values'} = undef;
1877 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1878 @values = @{ $args{'ARGS'}->{$arg} };
1879 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1880 @values = ( $args{'ARGS'}->{$arg} );
1882 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1883 if defined $args{'ARGS'}->{$arg};
1885 @values = grep length, map {
1891 grep defined, @values;
1893 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1894 foreach my $value (@values) {
1895 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1899 push( @results, $msg );
1901 } elsif ( $arg eq 'Upload' ) {
1902 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1903 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1904 push( @results, $msg );
1905 } elsif ( $arg eq 'DeleteValues' ) {
1906 foreach my $value (@values) {
1907 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1911 push( @results, $msg );
1913 } elsif ( $arg eq 'DeleteValueIds' ) {
1914 foreach my $value (@values) {
1915 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1919 push( @results, $msg );
1921 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1922 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1925 foreach my $value (@values) {
1926 if ( my $entry = $cf_values->HasEntry($value) ) {
1927 $values_hash{ $entry->id } = 1;
1931 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1935 push( @results, $msg );
1936 $values_hash{$val} = 1 if $val;
1939 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1940 return @results if ( $cf->Type eq 'Date' && ! @values );
1942 $cf_values->RedoSearch;
1943 while ( my $cf_value = $cf_values->Next ) {
1944 next if $values_hash{ $cf_value->id };
1946 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1948 ValueId => $cf_value->id
1950 push( @results, $msg );
1952 } elsif ( $arg eq 'Values' ) {
1953 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1955 # keep everything up to the point of difference, delete the rest
1957 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1958 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1967 # now add/replace extra things, if any
1968 foreach my $value (@values) {
1969 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1973 push( @results, $msg );
1978 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1979 $cf->Name, ref $args{'Object'},
1988 # {{{ sub ProcessTicketWatchers
1990 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1992 Returns an array of results messages.
1996 sub ProcessTicketWatchers {
2004 my $Ticket = $args{'TicketObj'};
2005 my $ARGSRef = $args{'ARGSRef'};
2009 foreach my $key ( keys %$ARGSRef ) {
2011 # Delete deletable watchers
2012 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2013 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2017 push @results, $msg;
2020 # Delete watchers in the simple style demanded by the bulk manipulator
2021 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2022 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2023 Email => $ARGSRef->{$key},
2026 push @results, $msg;
2029 # Add new wathchers by email address
2030 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2031 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2034 #They're in this order because otherwise $1 gets clobbered :/
2035 my ( $code, $msg ) = $Ticket->AddWatcher(
2036 Type => $ARGSRef->{$key},
2037 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2039 push @results, $msg;
2042 #Add requestors in the simple style demanded by the bulk manipulator
2043 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2044 my ( $code, $msg ) = $Ticket->AddWatcher(
2046 Email => $ARGSRef->{$key}
2048 push @results, $msg;
2051 # Add new watchers by owner
2052 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2053 my $principal_id = $1;
2054 my $form = $ARGSRef->{$key};
2055 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2056 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2058 my ( $code, $msg ) = $Ticket->AddWatcher(
2060 PrincipalId => $principal_id
2062 push @results, $msg;
2072 # {{{ sub ProcessTicketDates
2074 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2076 Returns an array of results messages.
2080 sub ProcessTicketDates {
2087 my $Ticket = $args{'TicketObj'};
2088 my $ARGSRef = $args{'ARGSRef'};
2092 # {{{ Set date fields
2093 my @date_fields = qw(
2101 #Run through each field in this list. update the value if apropriate
2102 foreach my $field (@date_fields) {
2103 next unless exists $ARGSRef->{ $field . '_Date' };
2104 next if $ARGSRef->{ $field . '_Date' } eq '';
2108 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2110 Format => 'unknown',
2111 Value => $ARGSRef->{ $field . '_Date' }
2114 my $obj = $field . "Obj";
2115 if ( ( defined $DateObj->Unix )
2116 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2118 my $method = "Set$field";
2119 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2120 push @results, "$msg";
2130 # {{{ sub ProcessTicketLinks
2132 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2134 Returns an array of results messages.
2138 sub ProcessTicketLinks {
2145 my $Ticket = $args{'TicketObj'};
2146 my $ARGSRef = $args{'ARGSRef'};
2148 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2150 #Merge if we need to
2151 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2152 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2153 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2154 push @results, $msg;
2162 sub ProcessRecordLinks {
2169 my $Record = $args{'RecordObj'};
2170 my $ARGSRef = $args{'ARGSRef'};
2174 # Delete links that are gone gone gone.
2175 foreach my $arg ( keys %$ARGSRef ) {
2176 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2181 my ( $val, $msg ) = $Record->DeleteLink(
2187 push @results, $msg;
2193 my @linktypes = qw( DependsOn MemberOf RefersTo );
2195 foreach my $linktype (@linktypes) {
2196 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2197 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2198 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2200 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2202 $luri =~ s/\s+$//; # Strip trailing whitespace
2203 my ( $val, $msg ) = $Record->AddLink(
2207 push @results, $msg;
2210 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2211 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2212 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2214 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2216 my ( $val, $msg ) = $Record->AddLink(
2221 push @results, $msg;
2229 =head2 _UploadedFile ( $arg );
2231 Takes a CGI parameter name; if a file is uploaded under that name,
2232 return a hash reference suitable for AddCustomFieldValue's use:
2233 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2235 Returns C<undef> if no files were uploaded in the C<$arg> field.
2241 my $cgi_object = $m->cgi_object;
2242 my $fh = $cgi_object->upload($arg) or return undef;
2243 my $upload_info = $cgi_object->uploadInfo($fh);
2245 my $filename = "$fh";
2246 $filename =~ s#^.*[\\/]##;
2251 LargeContent => do { local $/; scalar <$fh> },
2252 ContentType => $upload_info->{'Content-Type'},
2256 sub GetColumnMapEntry {
2257 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2259 # deal with the simplest thing first
2260 if ( $args{'Map'}{ $args{'Name'} } ) {
2261 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2265 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2266 return undef unless $args{'Map'}->{$mainkey};
2267 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2268 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2270 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2275 sub ProcessColumnMapValue {
2277 my %args = ( Arguments => [], Escape => 1, @_ );
2280 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2281 my @tmp = $value->( @{ $args{'Arguments'} } );
2282 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2283 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2284 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2285 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2290 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2294 =head2 _load_container_object ( $type, $id );
2296 Instantiate container object for saving searches.
2300 sub _load_container_object {
2301 my ( $obj_type, $obj_id ) = @_;
2302 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2305 =head2 _parse_saved_search ( $arg );
2307 Given a serialization string for saved search, and returns the
2308 container object and the search id.
2312 sub _parse_saved_search {
2314 return unless $spec;
2315 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2322 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2325 package RT::Interface::Web;
2326 RT::Base->_ImportOverlays();