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 )
670 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
675 This routine ells the current user's browser to redirect to URL.
676 Additionally, it unties the user's currently active session, helping to avoid
677 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
678 a cached DBI statement handle twice at the same time.
683 my $redir_to = shift;
684 untie $HTML::Mason::Commands::session;
685 my $uri = URI->new($redir_to);
686 my $server_uri = URI->new( RT->Config->Get('WebURL') );
688 # Make relative URIs absolute from the server host and scheme
689 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
690 if (not defined $uri->host) {
691 $uri->host($server_uri->host);
692 $uri->port($server_uri->port);
695 # If the user is coming in via a non-canonical
696 # hostname, don't redirect them to the canonical host,
697 # it will just upset them (and invalidate their credentials)
698 # don't do this if $RT::CanoniaclRedirectURLs is true
699 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
700 && $uri->host eq $server_uri->host
701 && $uri->port eq $server_uri->port )
703 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
704 $uri->scheme('https');
706 $uri->scheme('http');
709 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
710 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
711 $uri->port( $ENV{'SERVER_PORT'} );
714 # not sure why, but on some systems without this call mason doesn't
715 # set status to 302, but 200 instead and people see blank pages
716 $HTML::Mason::Commands::r->status(302);
718 # Perlbal expects a status message, but Mason's default redirect status
719 # doesn't provide one. See also rt.cpan.org #36689.
720 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
722 $HTML::Mason::Commands::m->abort;
725 =head2 StaticFileHeaders
727 Send the browser a few headers to try to get it to (somewhat agressively)
728 cache RT's static Javascript and CSS files.
730 This routine could really use _accurate_ heuristics. (XXX TODO)
734 sub StaticFileHeaders {
735 my $date = RT::Date->new($RT::SystemUser);
738 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
740 # Expire things in a month.
741 $date->Set( Value => time + 30 * 24 * 60 * 60 );
742 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
744 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
745 # request, but we don't handle it and generate full reply again
746 # Last modified at server start time
747 # $date->Set( Value => $^T );
748 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
753 Takes a C<< Path => path >> and returns a boolean indicating that
754 the path is safely within RT's control or not. The path I<must> be
757 This function does not consult the filesystem at all; it is merely
758 a logical sanity checking of the path. This explicitly does not handle
759 symlinks; if you have symlinks in RT's webroot pointing outside of it,
760 then we assume you know what you are doing.
767 my $path = $args{Path};
769 # Get File::Spec to clean up extra /s, ./, etc
770 my $cleaned_up = File::Spec->canonpath($path);
772 if (!defined($cleaned_up)) {
773 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
777 # Forbid too many ..s. We can't just sum then check because
778 # "../foo/bar/baz" should be illegal even though it has more
779 # downdirs than updirs. So as soon as we get a negative score
780 # (which means "breaking out" of the top level) we reject the path.
782 my @components = split '/', $cleaned_up;
784 for my $component (@components) {
785 if ($component eq '..') {
788 $RT::Logger->info("Rejecting unsafe path: $path");
792 elsif ($component eq '.' || $component eq '') {
793 # these two have no effect on $score
803 =head2 SendStaticFile
805 Takes a File => path and a Type => Content-type
807 If Type isn't provided and File is an image, it will
808 figure out a sane Content-type, otherwise it will
809 send application/octet-stream
811 Will set caching headers using StaticFileHeaders
818 my $file = $args{File};
819 my $type = $args{Type};
820 my $relfile = $args{RelativeFile};
822 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
823 $HTML::Mason::Commands::r->status(400);
824 $HTML::Mason::Commands::m->abort;
827 $self->StaticFileHeaders();
830 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
832 $type =~ s/jpg/jpeg/gi;
834 $type ||= "application/octet-stream";
837 # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
838 # since we don't specify a charset
839 if ( $type =~ m{application/javascript} &&
840 $type !~ m{charset=([\w-]+)$} ) {
841 $type .= "; charset=utf-8";
843 $HTML::Mason::Commands::r->content_type($type);
844 open( my $fh, '<', $file ) or die "couldn't open file: $!";
848 $HTML::Mason::Commands::m->out($_) while (<$fh>);
849 $HTML::Mason::Commands::m->flush_buffer;
856 my $content = $args{Content};
857 return '' unless $content;
859 # Make the content have no 'weird' newlines in it
860 $content =~ s/\r+\n/\n/g;
862 my $return_content = $content;
864 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
865 my $sigonly = $args{StripSignature};
867 # massage content to easily detect if there's any real content
868 $content =~ s/\s+//g; # yes! remove all the spaces
870 # remove html version of spaces and newlines
871 $content =~ s! !!g;
872 $content =~ s!<br/?>!!g;
875 # Filter empty content when type is text/html
876 return '' if $html && $content !~ /\S/;
878 # If we aren't supposed to strip the sig, just bail now.
879 return $return_content unless $sigonly;
882 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
885 # Check for plaintext sig
886 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
888 # Check for html-formatted sig; we don't use EscapeUTF8 here
889 # because we want to precisely match the escaping that FCKEditor
890 # uses. see also 311223f5, which fixed this for 4.0
897 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
900 return $return_content;
908 # if they've passed multiple values, they'll be an array. if they've
909 # passed just one, a scalar whatever they are, mark them as utf8
912 ? Encode::is_utf8($_)
914 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
915 : ( $type eq 'ARRAY' )
916 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
918 : ( $type eq 'HASH' )
919 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
925 sub PreprocessTimeUpdates {
928 # Later in the code we use
929 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
930 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
931 # The call_next method pass through original arguments and if you have
932 # an argument with unicode key then in a next component you'll get two
933 # records in the args hash: one with key without UTF8 flag and another
934 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
935 # is copied from mason's source to get the same results as we get from
936 # call_next method, this feature is not documented, so we just leave it
937 # here to avoid possible side effects.
939 # This code canonicalizes time inputs in hours into minutes
940 foreach my $field ( keys %$ARGS ) {
941 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
943 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
944 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
945 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
946 $ARGS->{$local} *= 60;
948 delete $ARGS->{$field};
953 sub MaybeEnableSQLStatementLog {
955 my $log_sql_statements = RT->Config->Get('StatementLog');
957 if ($log_sql_statements) {
958 $RT::Handle->ClearSQLStatementLog;
959 $RT::Handle->LogSQLStatements(1);
964 sub LogRecordedSQLStatements {
965 my $log_sql_statements = RT->Config->Get('StatementLog');
967 return unless ($log_sql_statements);
969 my @log = $RT::Handle->SQLStatementLog;
970 $RT::Handle->ClearSQLStatementLog;
971 for my $stmt (@log) {
972 my ( $time, $sql, $bind, $duration ) = @{$stmt};
982 level => $log_sql_statements,
984 . sprintf( "%.6f", $duration )
986 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
992 package HTML::Mason::Commands;
994 use vars qw/$r $m %session/;
1000 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1001 with whatever it's called with. If there is no $session{'CurrentUser'},
1002 it creates a temporary user, so we have something to get a localisation handle
1009 if ( $session{'CurrentUser'}
1010 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1012 return ( $session{'CurrentUser'}->loc(@_) );
1015 RT::CurrentUser->new();
1019 return ( $u->loc(@_) );
1022 # pathetic case -- SystemUser is gone.
1031 =head2 loc_fuzzy STRING
1033 loc_fuzzy is for handling localizations of messages that may already
1034 contain interpolated variables, typically returned from libraries
1035 outside RT's control. It takes the message string and extracts the
1036 variable array automatically by matching against the candidate entries
1037 inside the lexicon file.
1044 if ( $session{'CurrentUser'}
1045 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1047 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1049 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1050 return ( $u->loc_fuzzy($msg) );
1057 # Error - calls Error and aborts
1062 if ( $session{'ErrorDocument'}
1063 && $session{'ErrorDocumentType'} )
1065 $r->content_type( $session{'ErrorDocumentType'} );
1066 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1069 $m->comp( "/Elements/Error", Why => $why, %args );
1076 # {{{ sub CreateTicket
1078 =head2 CreateTicket ARGS
1080 Create a new ticket, using Mason's %ARGS. returns @results.
1089 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1091 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1092 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1093 Abort('Queue not found');
1096 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1097 Abort('You have no permission to create tickets in that queue.');
1101 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1102 $due = new RT::Date( $session{'CurrentUser'} );
1103 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1106 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1107 $starts = new RT::Date( $session{'CurrentUser'} );
1108 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1111 my $sigless = RT::Interface::Web::StripContent(
1112 Content => $ARGS{Content},
1113 ContentType => $ARGS{ContentType},
1114 StripSignature => 1,
1115 CurrentUser => $session{'CurrentUser'},
1118 my $MIMEObj = MakeMIMEEntity(
1119 Subject => $ARGS{'Subject'},
1120 From => $ARGS{'From'},
1123 Type => $ARGS{'ContentType'},
1126 if ( $ARGS{'Attachments'} ) {
1127 my $rv = $MIMEObj->make_multipart;
1128 $RT::Logger->error("Couldn't make multipart message")
1129 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1131 foreach ( values %{ $ARGS{'Attachments'} } ) {
1133 $RT::Logger->error("Couldn't add empty attachemnt");
1136 $MIMEObj->add_part($_);
1140 foreach my $argument (qw(Encrypt Sign)) {
1141 $MIMEObj->head->add(
1142 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1143 ) if defined $ARGS{$argument};
1147 Type => $ARGS{'Type'} || 'ticket',
1148 Queue => $ARGS{'Queue'},
1149 Owner => $ARGS{'Owner'},
1152 Requestor => $ARGS{'Requestors'},
1154 AdminCc => $ARGS{'AdminCc'},
1155 InitialPriority => $ARGS{'InitialPriority'},
1156 FinalPriority => $ARGS{'FinalPriority'},
1157 TimeLeft => $ARGS{'TimeLeft'},
1158 TimeEstimated => $ARGS{'TimeEstimated'},
1159 TimeWorked => $ARGS{'TimeWorked'},
1160 Subject => $ARGS{'Subject'},
1161 Status => $ARGS{'Status'},
1162 Due => $due ? $due->ISO : undef,
1163 Starts => $starts ? $starts->ISO : undef,
1168 foreach my $type (qw(Requestor Cc AdminCc)) {
1169 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1170 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1174 if (@temp_squelch) {
1175 require RT::Action::SendEmail;
1176 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1179 if ( $ARGS{'AttachTickets'} ) {
1180 require RT::Action::SendEmail;
1181 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1182 ref $ARGS{'AttachTickets'}
1183 ? @{ $ARGS{'AttachTickets'} }
1184 : ( $ARGS{'AttachTickets'} ) );
1187 foreach my $arg ( keys %ARGS ) {
1188 next if $arg =~ /-(?:Magic|Category)$/;
1190 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1191 $create_args{$arg} = $ARGS{$arg};
1194 # Object-RT::Ticket--CustomField-3-Values
1195 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1198 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1200 unless ( $cf->id ) {
1201 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1205 if ( $arg =~ /-Upload$/ ) {
1206 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1210 my $type = $cf->Type;
1213 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1214 @values = @{ $ARGS{$arg} };
1215 } elsif ( $type =~ /text/i ) {
1216 @values = ( $ARGS{$arg} );
1218 no warnings 'uninitialized';
1219 @values = split /\r*\n/, $ARGS{$arg};
1221 @values = grep length, map {
1227 grep defined, @values;
1229 $create_args{"CustomField-$cfid"} = \@values;
1233 # turn new link lists into arrays, and pass in the proper arguments
1235 'new-DependsOn' => 'DependsOn',
1236 'DependsOn-new' => 'DependedOnBy',
1237 'new-MemberOf' => 'Parents',
1238 'MemberOf-new' => 'Children',
1239 'new-RefersTo' => 'RefersTo',
1240 'RefersTo-new' => 'ReferredToBy',
1242 foreach my $key ( keys %map ) {
1243 next unless $ARGS{$key};
1244 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1248 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1253 push( @Actions, split( "\n", $ErrMsg ) );
1254 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1255 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1257 return ( $Ticket, @Actions );
1263 # {{{ sub LoadTicket - loads a ticket
1265 =head2 LoadTicket id
1267 Takes a ticket id as its only variable. if it's handed an array, it takes
1270 Returns an RT::Ticket object as the current user.
1277 if ( ref($id) eq "ARRAY" ) {
1282 Abort("No ticket specified");
1285 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1287 unless ( $Ticket->id ) {
1288 Abort("Could not load ticket $id");
1295 # {{{ sub ProcessUpdateMessage
1297 =head2 ProcessUpdateMessage
1299 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1301 Don't write message if it only contains current user's signature and
1302 SkipSignatureOnly argument is true. Function anyway adds attachments
1303 and updates time worked field even if skips message. The default value
1308 sub ProcessUpdateMessage {
1313 SkipSignatureOnly => 1,
1317 if ( $args{ARGSRef}->{'UpdateAttachments'}
1318 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1320 delete $args{ARGSRef}->{'UpdateAttachments'};
1323 # Strip the signature
1324 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1325 Content => $args{ARGSRef}->{UpdateContent},
1326 ContentType => $args{ARGSRef}->{UpdateContentType},
1327 StripSignature => $args{SkipSignatureOnly},
1328 CurrentUser => $args{'TicketObj'}->CurrentUser,
1331 # If, after stripping the signature, we have no message, move the
1332 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1333 # ProcessBasics can deal -- then bail out.
1334 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1335 and not length $args{ARGSRef}->{'UpdateContent'} )
1337 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1338 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1343 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1344 $args{ARGSRef}->{'UpdateSubject'} = undef;
1347 my $Message = MakeMIMEEntity(
1348 Subject => $args{ARGSRef}->{'UpdateSubject'},
1349 Body => $args{ARGSRef}->{'UpdateContent'},
1350 Type => $args{ARGSRef}->{'UpdateContentType'},
1353 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1354 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1356 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1357 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1358 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1360 $old_txn = $args{TicketObj}->Transactions->First();
1363 if ( my $msg = $old_txn->Message->First ) {
1364 RT::Interface::Email::SetInReplyTo(
1365 Message => $Message,
1370 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1371 $Message->make_multipart;
1372 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1375 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1376 require RT::Action::SendEmail;
1377 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1378 ref $args{ARGSRef}->{'AttachTickets'}
1379 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1380 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1383 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1384 my $cc = $args{ARGSRef}->{'UpdateCc'};
1386 my %txn_customfields;
1388 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1389 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1390 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1394 my %message_args = (
1396 BccMessageTo => $bcc,
1397 Sign => $args{ARGSRef}->{'Sign'},
1398 Encrypt => $args{ARGSRef}->{'Encrypt'},
1399 MIMEObj => $Message,
1400 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1401 CustomFields => \%txn_customfields,
1405 foreach my $type (qw(Cc AdminCc)) {
1406 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1407 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1408 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1409 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1412 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1413 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1414 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1417 if (@temp_squelch) {
1418 require RT::Action::SendEmail;
1419 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1422 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1423 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1424 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1426 my $var = ucfirst($1) . 'MessageTo';
1428 if ( $message_args{$var} ) {
1429 $message_args{$var} .= ", $value";
1431 $message_args{$var} = $value;
1437 # Do the update via the appropriate Ticket method
1438 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1439 my ( $Transaction, $Description, $Object ) =
1440 $args{TicketObj}->Comment(%message_args);
1441 push( @results, $Description );
1442 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1443 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1444 my ( $Transaction, $Description, $Object ) =
1445 $args{TicketObj}->Correspond(%message_args);
1446 push( @results, $Description );
1447 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1450 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1457 # {{{ sub MakeMIMEEntity
1459 =head2 MakeMIMEEntity PARAMHASH
1461 Takes a paramhash Subject, Body and AttachmentFieldName.
1463 Also takes Form, Cc and Type as optional paramhash keys.
1465 Returns a MIME::Entity.
1469 sub MakeMIMEEntity {
1471 #TODO document what else this takes.
1477 AttachmentFieldName => undef,
1481 my $Message = MIME::Entity->build(
1482 Type => 'multipart/mixed',
1483 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1484 grep defined $args{$_}, qw(Subject From Cc)
1487 if ( defined $args{'Body'} && length $args{'Body'} ) {
1489 # Make the update content have no 'weird' newlines in it
1490 $args{'Body'} =~ s/\r\n/\n/gs;
1493 Type => $args{'Type'} || 'text/plain',
1495 Data => $args{'Body'},
1499 if ( $args{'AttachmentFieldName'} ) {
1501 my $cgi_object = $m->cgi_object;
1503 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1505 my ( @content, $buffer );
1506 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1507 push @content, $buffer;
1510 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1512 # Prefer the cached name first over CGI.pm stringification.
1513 my $filename = $RT::Mason::CGI::Filename;
1514 $filename = "$filehandle" unless defined $filename;
1515 $filename = Encode::encode_utf8( $filename );
1516 $filename =~ s{^.*[\\/]}{};
1519 Type => $uploadinfo->{'Content-Type'},
1520 Filename => $filename,
1523 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1524 $Message->head->set( 'Subject' => $filename );
1529 $Message->make_singlepart;
1531 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1539 # {{{ sub ParseDateToISO
1541 =head2 ParseDateToISO
1543 Takes a date in an arbitrary format.
1544 Returns an ISO date and time in GMT
1548 sub ParseDateToISO {
1551 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1553 Format => 'unknown',
1556 return ( $date_obj->ISO );
1561 # {{{ sub ProcessACLChanges
1563 sub ProcessACLChanges {
1564 my $ARGSref = shift;
1568 foreach my $arg ( keys %$ARGSref ) {
1569 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1571 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1574 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1575 @rights = @{ $ARGSref->{$arg} };
1577 @rights = $ARGSref->{$arg};
1579 @rights = grep $_, @rights;
1580 next unless @rights;
1582 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1583 $principal->Load($principal_id);
1586 if ( $object_type eq 'RT::System' ) {
1588 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1589 $obj = $object_type->new( $session{'CurrentUser'} );
1590 $obj->Load($object_id);
1591 unless ( $obj->id ) {
1592 $RT::Logger->error("couldn't load $object_type #$object_id");
1596 $RT::Logger->error("object type '$object_type' is incorrect");
1597 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1601 foreach my $right (@rights) {
1602 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1603 push( @results, $msg );
1612 # {{{ sub UpdateRecordObj
1614 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1616 @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.
1618 Returns an array of success/failure messages
1622 sub UpdateRecordObject {
1625 AttributesRef => undef,
1627 AttributePrefix => undef,
1631 my $Object = $args{'Object'};
1632 my @results = $Object->Update(
1633 AttributesRef => $args{'AttributesRef'},
1634 ARGSRef => $args{'ARGSRef'},
1635 AttributePrefix => $args{'AttributePrefix'},
1643 # {{{ Sub ProcessCustomFieldUpdates
1645 sub ProcessCustomFieldUpdates {
1647 CustomFieldObj => undef,
1652 my $Object = $args{'CustomFieldObj'};
1653 my $ARGSRef = $args{'ARGSRef'};
1655 my @attribs = qw(Name Type Description Queue SortOrder);
1656 my @results = UpdateRecordObject(
1657 AttributesRef => \@attribs,
1662 my $prefix = "CustomField-" . $Object->Id;
1663 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1664 my ( $addval, $addmsg ) = $Object->AddValue(
1665 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1666 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1667 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1669 push( @results, $addmsg );
1673 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1674 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1675 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1677 foreach my $id (@delete_values) {
1678 next unless defined $id;
1679 my ( $err, $msg ) = $Object->DeleteValue($id);
1680 push( @results, $msg );
1683 my $vals = $Object->Values();
1684 while ( my $cfv = $vals->Next() ) {
1685 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1686 if ( $cfv->SortOrder != $so ) {
1687 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1688 push( @results, $msg );
1698 # {{{ sub ProcessTicketBasics
1700 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1702 Returns an array of results messages.
1706 sub ProcessTicketBasics {
1714 my $TicketObj = $args{'TicketObj'};
1715 my $ARGSRef = $args{'ARGSRef'};
1717 # {{{ Set basic fields
1730 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1731 my $tempqueue = RT::Queue->new($RT::SystemUser);
1732 $tempqueue->Load( $ARGSRef->{'Queue'} );
1733 if ( $tempqueue->id ) {
1734 $ARGSRef->{'Queue'} = $tempqueue->id;
1738 # Status isn't a field that can be set to a null value.
1739 # RT core complains if you try
1740 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1742 my @results = UpdateRecordObject(
1743 AttributesRef => \@attribs,
1744 Object => $TicketObj,
1745 ARGSRef => $ARGSRef,
1748 # We special case owner changing, so we can use ForceOwnerChange
1749 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1751 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1752 $ChownType = "Force";
1754 $ChownType = "Give";
1757 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1758 push( @results, $msg );
1768 sub ProcessTicketCustomFieldUpdates {
1770 $args{'Object'} = delete $args{'TicketObj'};
1771 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1773 # Build up a list of objects that we want to work with
1774 my %custom_fields_to_mod;
1775 foreach my $arg ( keys %$ARGSRef ) {
1776 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1777 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1778 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1779 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1780 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
1781 delete $ARGSRef->{$arg}; # don't try to update transaction fields
1785 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1788 sub ProcessObjectCustomFieldUpdates {
1790 my $ARGSRef = $args{'ARGSRef'};
1793 # Build up a list of objects that we want to work with
1794 my %custom_fields_to_mod;
1795 foreach my $arg ( keys %$ARGSRef ) {
1797 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1798 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1800 # For each of those objects, find out what custom fields we want to work with.
1801 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1804 # For each of those objects
1805 foreach my $class ( keys %custom_fields_to_mod ) {
1806 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1807 my $Object = $args{'Object'};
1808 $Object = $class->new( $session{'CurrentUser'} )
1809 unless $Object && ref $Object eq $class;
1811 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1812 unless ( $Object->id ) {
1813 $RT::Logger->warning("Couldn't load object $class #$id");
1817 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1818 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1819 $CustomFieldObj->LoadById($cf);
1820 unless ( $CustomFieldObj->id ) {
1821 $RT::Logger->warning("Couldn't load custom field #$cf");
1825 _ProcessObjectCustomFieldUpdates(
1826 Prefix => "Object-$class-$id-CustomField-$cf-",
1828 CustomField => $CustomFieldObj,
1829 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1837 sub _ProcessObjectCustomFieldUpdates {
1839 my $cf = $args{'CustomField'};
1840 my $cf_type = $cf->Type;
1842 # Remove blank Values since the magic field will take care of this. Sometimes
1843 # the browser gives you a blank value which causes CFs to be processed twice
1844 if ( defined $args{'ARGS'}->{'Values'}
1845 && !length $args{'ARGS'}->{'Values'}
1846 && $args{'ARGS'}->{'Values-Magic'} )
1848 delete $args{'ARGS'}->{'Values'};
1852 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1854 # skip category argument
1855 next if $arg eq 'Category';
1858 next if $arg eq 'Value-TimeUnits';
1860 # since http won't pass in a form element with a null value, we need
1862 if ( $arg eq 'Values-Magic' ) {
1864 # We don't care about the magic, if there's really a values element;
1865 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1866 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1868 # "Empty" values does not mean anything for Image and Binary fields
1869 next if $cf_type =~ /^(?:Image|Binary)$/;
1872 $args{'ARGS'}->{'Values'} = undef;
1876 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1877 @values = @{ $args{'ARGS'}->{$arg} };
1878 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1879 @values = ( $args{'ARGS'}->{$arg} );
1881 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1882 if defined $args{'ARGS'}->{$arg};
1884 @values = grep length, map {
1890 grep defined, @values;
1892 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1893 foreach my $value (@values) {
1894 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1898 push( @results, $msg );
1900 } elsif ( $arg eq 'Upload' ) {
1901 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1902 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1903 push( @results, $msg );
1904 } elsif ( $arg eq 'DeleteValues' ) {
1905 foreach my $value (@values) {
1906 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1910 push( @results, $msg );
1912 } elsif ( $arg eq 'DeleteValueIds' ) {
1913 foreach my $value (@values) {
1914 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1918 push( @results, $msg );
1920 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1921 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1924 foreach my $value (@values) {
1925 if ( my $entry = $cf_values->HasEntry($value) ) {
1926 $values_hash{ $entry->id } = 1;
1930 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1934 push( @results, $msg );
1935 $values_hash{$val} = 1 if $val;
1938 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1939 return @results if ( $cf->Type eq 'Date' && ! @values );
1941 $cf_values->RedoSearch;
1942 while ( my $cf_value = $cf_values->Next ) {
1943 next if $values_hash{ $cf_value->id };
1945 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1947 ValueId => $cf_value->id
1949 push( @results, $msg );
1951 } elsif ( $arg eq 'Values' ) {
1952 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1954 # keep everything up to the point of difference, delete the rest
1956 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1957 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1966 # now add/replace extra things, if any
1967 foreach my $value (@values) {
1968 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1972 push( @results, $msg );
1977 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1978 $cf->Name, ref $args{'Object'},
1987 # {{{ sub ProcessTicketWatchers
1989 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1991 Returns an array of results messages.
1995 sub ProcessTicketWatchers {
2003 my $Ticket = $args{'TicketObj'};
2004 my $ARGSRef = $args{'ARGSRef'};
2008 foreach my $key ( keys %$ARGSRef ) {
2010 # Delete deletable watchers
2011 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2012 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2016 push @results, $msg;
2019 # Delete watchers in the simple style demanded by the bulk manipulator
2020 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2021 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2022 Email => $ARGSRef->{$key},
2025 push @results, $msg;
2028 # Add new wathchers by email address
2029 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2030 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2033 #They're in this order because otherwise $1 gets clobbered :/
2034 my ( $code, $msg ) = $Ticket->AddWatcher(
2035 Type => $ARGSRef->{$key},
2036 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2038 push @results, $msg;
2041 #Add requestors in the simple style demanded by the bulk manipulator
2042 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2043 my ( $code, $msg ) = $Ticket->AddWatcher(
2045 Email => $ARGSRef->{$key}
2047 push @results, $msg;
2050 # Add new watchers by owner
2051 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2052 my $principal_id = $1;
2053 my $form = $ARGSRef->{$key};
2054 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2055 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2057 my ( $code, $msg ) = $Ticket->AddWatcher(
2059 PrincipalId => $principal_id
2061 push @results, $msg;
2071 # {{{ sub ProcessTicketDates
2073 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2075 Returns an array of results messages.
2079 sub ProcessTicketDates {
2086 my $Ticket = $args{'TicketObj'};
2087 my $ARGSRef = $args{'ARGSRef'};
2091 # {{{ Set date fields
2092 my @date_fields = qw(
2100 #Run through each field in this list. update the value if apropriate
2101 foreach my $field (@date_fields) {
2102 next unless exists $ARGSRef->{ $field . '_Date' };
2103 next if $ARGSRef->{ $field . '_Date' } eq '';
2107 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2109 Format => 'unknown',
2110 Value => $ARGSRef->{ $field . '_Date' }
2113 my $obj = $field . "Obj";
2114 if ( ( defined $DateObj->Unix )
2115 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2117 my $method = "Set$field";
2118 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2119 push @results, "$msg";
2129 # {{{ sub ProcessTicketLinks
2131 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2133 Returns an array of results messages.
2137 sub ProcessTicketLinks {
2144 my $Ticket = $args{'TicketObj'};
2145 my $ARGSRef = $args{'ARGSRef'};
2147 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2149 #Merge if we need to
2150 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2151 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2152 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2153 push @results, $msg;
2161 sub ProcessRecordLinks {
2168 my $Record = $args{'RecordObj'};
2169 my $ARGSRef = $args{'ARGSRef'};
2173 # Delete links that are gone gone gone.
2174 foreach my $arg ( keys %$ARGSRef ) {
2175 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2180 my ( $val, $msg ) = $Record->DeleteLink(
2186 push @results, $msg;
2192 my @linktypes = qw( DependsOn MemberOf RefersTo );
2194 foreach my $linktype (@linktypes) {
2195 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2196 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2197 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2199 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2201 $luri =~ s/\s+$//; # Strip trailing whitespace
2202 my ( $val, $msg ) = $Record->AddLink(
2206 push @results, $msg;
2209 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2210 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2211 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2213 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2215 my ( $val, $msg ) = $Record->AddLink(
2220 push @results, $msg;
2228 =head2 _UploadedFile ( $arg );
2230 Takes a CGI parameter name; if a file is uploaded under that name,
2231 return a hash reference suitable for AddCustomFieldValue's use:
2232 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2234 Returns C<undef> if no files were uploaded in the C<$arg> field.
2240 my $cgi_object = $m->cgi_object;
2241 my $fh = $cgi_object->upload($arg) or return undef;
2242 my $upload_info = $cgi_object->uploadInfo($fh);
2244 my $filename = "$fh";
2245 $filename =~ s#^.*[\\/]##;
2250 LargeContent => do { local $/; scalar <$fh> },
2251 ContentType => $upload_info->{'Content-Type'},
2255 sub GetColumnMapEntry {
2256 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2258 # deal with the simplest thing first
2259 if ( $args{'Map'}{ $args{'Name'} } ) {
2260 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2264 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2265 return undef unless $args{'Map'}->{$mainkey};
2266 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2267 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2269 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2274 sub ProcessColumnMapValue {
2276 my %args = ( Arguments => [], Escape => 1, @_ );
2279 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2280 my @tmp = $value->( @{ $args{'Arguments'} } );
2281 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2282 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2283 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2284 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2289 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2293 =head2 _load_container_object ( $type, $id );
2295 Instantiate container object for saving searches.
2299 sub _load_container_object {
2300 my ( $obj_type, $obj_id ) = @_;
2301 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2304 =head2 _parse_saved_search ( $arg );
2306 Given a serialization string for saved search, and returns the
2307 container object and the search id.
2311 sub _parse_saved_search {
2313 return unless $spec;
2314 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2321 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2324 package RT::Interface::Web;
2325 RT::Base->_ImportOverlays();