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 MaybeShowNoAuthPage($ARGS);
200 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
202 _ForceLogout() unless _UserLoggedIn();
204 # Process per-page authentication callbacks
205 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
207 unless ( _UserLoggedIn() ) {
210 # Authenticate if the user is trying to login via user/pass query args
211 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
214 my $m = $HTML::Mason::Commands::m;
216 # REST urls get a special 401 response
217 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
218 $HTML::Mason::Commands::r->content_type("text/plain");
219 $m->error_format("text");
220 $m->out("RT/$RT::VERSION 401 Credentials required\n");
221 $m->out("\n$msg\n") if $msg;
224 # Specially handle /index.html so that we get a nicer URL
225 elsif ( $m->request_comp->path eq '/index.html' ) {
226 my $next = SetNextPage(RT->Config->Get('WebURL'));
227 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
231 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
236 # now it applies not only to home page, but any dashboard that can be used as a workspace
237 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
238 if ( $ARGS->{'HomeRefreshInterval'} );
240 # Process per-page global callbacks
241 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
243 ShowRequestedPage($ARGS);
244 LogRecordedSQLStatements();
246 # Process per-page final cleanup callbacks
247 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
252 delete $HTML::Mason::Commands::session{'CurrentUser'};
256 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
264 =head2 LoginError ERROR
266 Pushes a login error into the Actions session store and returns the hash key.
272 my $key = Digest::MD5::md5_hex( rand(1024) );
273 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
274 $HTML::Mason::Commands::session{'i'}++;
278 =head2 SetNextPage [PATH]
280 Intuits and stashes the next page in the sesssion hash. If PATH is
281 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
287 my $next = shift || IntuitNextPage();
288 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
290 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
291 $HTML::Mason::Commands::session{'i'}++;
298 =head2 TangentForLogin [HASH]
300 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
301 the next page. Optionally takes a hash which is dumped into query params.
305 sub TangentForLogin {
306 my $hash = SetNextPage();
307 my %query = (@_, next => $hash);
308 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
309 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
313 =head2 TangentForLoginWithError ERROR
315 Localizes the passed error message, stashes it with L<LoginError> and then
316 calls L<TangentForLogin> with the appropriate results key.
320 sub TangentForLoginWithError {
321 my $key = LoginError(HTML::Mason::Commands::loc(@_));
322 TangentForLogin( results => $key );
325 =head2 IntuitNextPage
327 Attempt to figure out the path to which we should return the user after a
328 tangent. The current request URL is used, or failing that, the C<WebURL>
329 configuration variable.
336 # This includes any query parameters. Redirect will take care of making
337 # it an absolute URL.
338 if ($ENV{'REQUEST_URI'}) {
339 $req_uri = $ENV{'REQUEST_URI'};
341 # collapse multiple leading slashes so the first part doesn't look like
342 # a hostname of a schema-less URI
343 $req_uri =~ s{^/+}{/};
346 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
349 my $uri = URI->new($next);
351 # You get undef scheme with a relative uri like "/Search/Build.html"
352 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
353 $next = RT->Config->Get('WebURL');
356 # Make sure we're logging in to the same domain
357 # You can get an undef authority with a relative uri like "index.html"
358 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
359 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
360 $next = RT->Config->Get('WebURL');
366 =head2 MaybeShowInstallModePage
368 This function, called exclusively by RT's autohandler, dispatches
369 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
371 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
375 sub MaybeShowInstallModePage {
376 return unless RT->InstallMode;
378 my $m = $HTML::Mason::Commands::m;
379 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
381 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
382 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
389 =head2 MaybeShowNoAuthPage \%ARGS
391 This function, called exclusively by RT's autohandler, dispatches
392 a request to the page a user requested (but only if it matches the "noauth" regex.
394 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
398 sub MaybeShowNoAuthPage {
401 my $m = $HTML::Mason::Commands::m;
403 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
405 # Don't show the login page to logged in users
406 Redirect(RT->Config->Get('WebURL'))
407 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
409 # If it's a noauth file, don't ask for auth.
411 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
415 =head2 ShowRequestedPage \%ARGS
417 This function, called exclusively by RT's autohandler, dispatches
418 a request to the page a user requested (making sure that unpriviled users
419 can only see self-service pages.
423 sub ShowRequestedPage {
426 my $m = $HTML::Mason::Commands::m;
430 # If the user isn't privileged, they can only see SelfService
431 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
433 # if the user is trying to access a ticket, redirect them
434 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
435 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
438 # otherwise, drop the user at the SelfService default page
439 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
440 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
443 # if user is in SelfService dir let him do anything
445 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
448 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
453 sub AttemptExternalAuth {
456 return unless ( RT->Config->Get('WebExternalAuth') );
458 my $user = $ARGS->{user};
459 my $m = $HTML::Mason::Commands::m;
461 # If RT is configured for external auth, let's go through and get REMOTE_USER
463 # do we actually have a REMOTE_USER equivlent?
464 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
465 my $orig_user = $user;
467 $user = RT::Interface::Web::WebCanonicalizeInfo();
468 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
470 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
471 my $NodeName = Win32::NodeName();
472 $user =~ s/^\Q$NodeName\E\\//i;
475 InstantiateNewSession() unless _UserLoggedIn;
476 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
477 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
479 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
481 # Create users on-the-fly
482 my $UserObj = RT::User->new($RT::SystemUser);
483 my ( $val, $msg ) = $UserObj->Create(
484 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
491 # now get user specific information, to better create our user.
492 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
494 # set the attributes that have been defined.
495 foreach my $attribute ( $UserObj->WritableAttributes ) {
497 Attribute => $attribute,
499 UserInfo => $new_user_info,
500 CallbackName => 'NewUser',
501 CallbackPage => '/autohandler'
503 my $method = "Set$attribute";
504 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
506 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
509 # we failed to successfully create the user. abort abort abort.
510 delete $HTML::Mason::Commands::session{'CurrentUser'};
512 if (RT->Config->Get('WebFallbackToInternalAuth')) {
513 TangentForLoginWithError('Cannot create user: [_1]', $msg);
520 if ( _UserLoggedIn() ) {
521 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
523 delete $HTML::Mason::Commands::session{'CurrentUser'};
526 if ( RT->Config->Get('WebExternalOnly') ) {
527 TangentForLoginWithError('You are not an authorized user');
530 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
531 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
532 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
533 TangentForLoginWithError('You are not an authorized user');
537 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
538 # XXX: we must return AUTH_REQUIRED status or we fallback to
539 # internal auth here too.
540 delete $HTML::Mason::Commands::session{'CurrentUser'}
541 if defined $HTML::Mason::Commands::session{'CurrentUser'};
545 sub AttemptPasswordAuthentication {
547 return unless defined $ARGS->{user} && defined $ARGS->{pass};
549 my $user_obj = RT::CurrentUser->new();
550 $user_obj->Load( $ARGS->{user} );
552 my $m = $HTML::Mason::Commands::m;
554 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
555 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
556 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
557 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
560 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
562 # It's important to nab the next page from the session before we blow
564 my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
566 InstantiateNewSession();
567 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
570 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
572 # Really the only time we don't want to redirect here is if we were
573 # passed user and pass as query params in the URL.
577 elsif ($ARGS->{'next'}) {
578 # Invalid hash, but still wants to go somewhere, take them to /
579 Redirect(RT->Config->Get('WebURL'));
582 return (1, HTML::Mason::Commands::loc('Logged in'));
586 =head2 LoadSessionFromCookie
588 Load or setup a session cookie for the current user.
592 sub _SessionCookieName {
593 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
594 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
598 sub LoadSessionFromCookie {
600 my %cookies = CGI::Cookie->fetch;
601 my $cookiename = _SessionCookieName();
602 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
603 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
604 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
605 undef $cookies{$cookiename};
607 if ( int RT->Config->Get('AutoLogoff') ) {
608 my $now = int( time / 60 );
609 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
611 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
612 InstantiateNewSession();
615 # save session on each request when AutoLogoff is turned on
616 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
620 sub InstantiateNewSession {
621 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
622 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
625 sub SendSessionCookie {
626 my $cookie = CGI::Cookie->new(
627 -name => _SessionCookieName(),
628 -value => $HTML::Mason::Commands::session{_session_id},
629 -path => RT->Config->Get('WebPath'),
630 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 )
633 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
638 This routine ells the current user's browser to redirect to URL.
639 Additionally, it unties the user's currently active session, helping to avoid
640 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
641 a cached DBI statement handle twice at the same time.
646 my $redir_to = shift;
647 untie $HTML::Mason::Commands::session;
648 my $uri = URI->new($redir_to);
649 my $server_uri = URI->new( RT->Config->Get('WebURL') );
651 # Make relative URIs absolute from the server host and scheme
652 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
653 if (not defined $uri->host) {
654 $uri->host($server_uri->host);
655 $uri->port($server_uri->port);
658 # If the user is coming in via a non-canonical
659 # hostname, don't redirect them to the canonical host,
660 # it will just upset them (and invalidate their credentials)
661 # don't do this if $RT::CanoniaclRedirectURLs is true
662 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
663 && $uri->host eq $server_uri->host
664 && $uri->port eq $server_uri->port )
666 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
667 $uri->scheme('https');
669 $uri->scheme('http');
672 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
673 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
674 $uri->port( $ENV{'SERVER_PORT'} );
677 # not sure why, but on some systems without this call mason doesn't
678 # set status to 302, but 200 instead and people see blank pages
679 $HTML::Mason::Commands::r->status(302);
681 # Perlbal expects a status message, but Mason's default redirect status
682 # doesn't provide one. See also rt.cpan.org #36689.
683 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
685 $HTML::Mason::Commands::m->abort;
688 =head2 StaticFileHeaders
690 Send the browser a few headers to try to get it to (somewhat agressively)
691 cache RT's static Javascript and CSS files.
693 This routine could really use _accurate_ heuristics. (XXX TODO)
697 sub StaticFileHeaders {
698 my $date = RT::Date->new($RT::SystemUser);
701 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
703 # Expire things in a month.
704 $date->Set( Value => time + 30 * 24 * 60 * 60 );
705 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
707 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
708 # request, but we don't handle it and generate full reply again
709 # Last modified at server start time
710 # $date->Set( Value => $^T );
711 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
716 Takes a C<< Path => path >> and returns a boolean indicating that
717 the path is safely within RT's control or not. The path I<must> be
720 This function does not consult the filesystem at all; it is merely
721 a logical sanity checking of the path. This explicitly does not handle
722 symlinks; if you have symlinks in RT's webroot pointing outside of it,
723 then we assume you know what you are doing.
730 my $path = $args{Path};
732 # Get File::Spec to clean up extra /s, ./, etc
733 my $cleaned_up = File::Spec->canonpath($path);
735 if (!defined($cleaned_up)) {
736 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
740 # Forbid too many ..s. We can't just sum then check because
741 # "../foo/bar/baz" should be illegal even though it has more
742 # downdirs than updirs. So as soon as we get a negative score
743 # (which means "breaking out" of the top level) we reject the path.
745 my @components = split '/', $cleaned_up;
747 for my $component (@components) {
748 if ($component eq '..') {
751 $RT::Logger->info("Rejecting unsafe path: $path");
755 elsif ($component eq '.' || $component eq '') {
756 # these two have no effect on $score
766 =head2 SendStaticFile
768 Takes a File => path and a Type => Content-type
770 If Type isn't provided and File is an image, it will
771 figure out a sane Content-type, otherwise it will
772 send application/octet-stream
774 Will set caching headers using StaticFileHeaders
781 my $file = $args{File};
782 my $type = $args{Type};
783 my $relfile = $args{RelativeFile};
785 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
786 $HTML::Mason::Commands::r->status(400);
787 $HTML::Mason::Commands::m->abort;
790 $self->StaticFileHeaders();
793 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
795 $type =~ s/jpg/jpeg/gi;
797 $type ||= "application/octet-stream";
799 $HTML::Mason::Commands::r->content_type($type);
800 open my $fh, "<$file" or die "couldn't open file: $!";
804 $HTML::Mason::Commands::m->out($_) while (<$fh>);
805 $HTML::Mason::Commands::m->flush_buffer;
812 my $content = $args{Content};
813 return '' unless $content;
815 # Make the content have no 'weird' newlines in it
816 $content =~ s/\r+\n/\n/g;
818 my $return_content = $content;
820 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
821 my $sigonly = $args{StripSignature};
823 # massage content to easily detect if there's any real content
824 $content =~ s/\s+//g; # yes! remove all the spaces
826 # remove html version of spaces and newlines
827 $content =~ s! !!g;
828 $content =~ s!<br/?>!!g;
831 # Filter empty content when type is text/html
832 return '' if $html && $content !~ /\S/;
834 # If we aren't supposed to strip the sig, just bail now.
835 return $return_content unless $sigonly;
838 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
841 # Check for plaintext sig
842 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
844 # Check for html-formatted sig
845 RT::Interface::Web::EscapeUTF8( \$sig );
848 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
851 return $return_content;
859 # if they've passed multiple values, they'll be an array. if they've
860 # passed just one, a scalar whatever they are, mark them as utf8
863 ? Encode::is_utf8($_)
865 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
866 : ( $type eq 'ARRAY' )
867 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
869 : ( $type eq 'HASH' )
870 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
876 sub PreprocessTimeUpdates {
879 # Later in the code we use
880 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
881 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
882 # The call_next method pass through original arguments and if you have
883 # an argument with unicode key then in a next component you'll get two
884 # records in the args hash: one with key without UTF8 flag and another
885 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
886 # is copied from mason's source to get the same results as we get from
887 # call_next method, this feature is not documented, so we just leave it
888 # here to avoid possible side effects.
890 # This code canonicalizes time inputs in hours into minutes
891 foreach my $field ( keys %$ARGS ) {
892 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
894 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
895 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
896 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
897 $ARGS->{$local} *= 60;
899 delete $ARGS->{$field};
904 sub MaybeEnableSQLStatementLog {
906 my $log_sql_statements = RT->Config->Get('StatementLog');
908 if ($log_sql_statements) {
909 $RT::Handle->ClearSQLStatementLog;
910 $RT::Handle->LogSQLStatements(1);
915 sub LogRecordedSQLStatements {
916 my $log_sql_statements = RT->Config->Get('StatementLog');
918 return unless ($log_sql_statements);
920 my @log = $RT::Handle->SQLStatementLog;
921 $RT::Handle->ClearSQLStatementLog;
922 for my $stmt (@log) {
923 my ( $time, $sql, $bind, $duration ) = @{$stmt};
933 level => $log_sql_statements,
935 . sprintf( "%.6f", $duration )
937 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
943 package HTML::Mason::Commands;
945 use vars qw/$r $m %session/;
951 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
952 with whatever it's called with. If there is no $session{'CurrentUser'},
953 it creates a temporary user, so we have something to get a localisation handle
960 if ( $session{'CurrentUser'}
961 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
963 return ( $session{'CurrentUser'}->loc(@_) );
966 RT::CurrentUser->new();
970 return ( $u->loc(@_) );
973 # pathetic case -- SystemUser is gone.
982 =head2 loc_fuzzy STRING
984 loc_fuzzy is for handling localizations of messages that may already
985 contain interpolated variables, typically returned from libraries
986 outside RT's control. It takes the message string and extracts the
987 variable array automatically by matching against the candidate entries
988 inside the lexicon file.
995 if ( $session{'CurrentUser'}
996 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
998 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1000 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1001 return ( $u->loc_fuzzy($msg) );
1008 # Error - calls Error and aborts
1013 if ( $session{'ErrorDocument'}
1014 && $session{'ErrorDocumentType'} )
1016 $r->content_type( $session{'ErrorDocumentType'} );
1017 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1020 $m->comp( "/Elements/Error", Why => $why, %args );
1027 # {{{ sub CreateTicket
1029 =head2 CreateTicket ARGS
1031 Create a new ticket, using Mason's %ARGS. returns @results.
1040 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1042 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1043 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1044 Abort('Queue not found');
1047 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1048 Abort('You have no permission to create tickets in that queue.');
1052 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1053 $due = new RT::Date( $session{'CurrentUser'} );
1054 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1057 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1058 $starts = new RT::Date( $session{'CurrentUser'} );
1059 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1062 my $sigless = RT::Interface::Web::StripContent(
1063 Content => $ARGS{Content},
1064 ContentType => $ARGS{ContentType},
1065 StripSignature => 1,
1066 CurrentUser => $session{'CurrentUser'},
1069 my $MIMEObj = MakeMIMEEntity(
1070 Subject => $ARGS{'Subject'},
1071 From => $ARGS{'From'},
1074 Type => $ARGS{'ContentType'},
1077 if ( $ARGS{'Attachments'} ) {
1078 my $rv = $MIMEObj->make_multipart;
1079 $RT::Logger->error("Couldn't make multipart message")
1080 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1082 foreach ( values %{ $ARGS{'Attachments'} } ) {
1084 $RT::Logger->error("Couldn't add empty attachemnt");
1087 $MIMEObj->add_part($_);
1091 foreach my $argument (qw(Encrypt Sign)) {
1092 $MIMEObj->head->add(
1093 "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1094 ) if defined $ARGS{$argument};
1098 Type => $ARGS{'Type'} || 'ticket',
1099 Queue => $ARGS{'Queue'},
1100 Owner => $ARGS{'Owner'},
1103 Requestor => $ARGS{'Requestors'},
1105 AdminCc => $ARGS{'AdminCc'},
1106 InitialPriority => $ARGS{'InitialPriority'},
1107 FinalPriority => $ARGS{'FinalPriority'},
1108 TimeLeft => $ARGS{'TimeLeft'},
1109 TimeEstimated => $ARGS{'TimeEstimated'},
1110 TimeWorked => $ARGS{'TimeWorked'},
1111 Subject => $ARGS{'Subject'},
1112 Status => $ARGS{'Status'},
1113 Due => $due ? $due->ISO : undef,
1114 Starts => $starts ? $starts->ISO : undef,
1119 foreach my $type (qw(Requestor Cc AdminCc)) {
1120 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1121 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1125 if (@temp_squelch) {
1126 require RT::Action::SendEmail;
1127 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1130 if ( $ARGS{'AttachTickets'} ) {
1131 require RT::Action::SendEmail;
1132 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1133 ref $ARGS{'AttachTickets'}
1134 ? @{ $ARGS{'AttachTickets'} }
1135 : ( $ARGS{'AttachTickets'} ) );
1138 foreach my $arg ( keys %ARGS ) {
1139 next if $arg =~ /-(?:Magic|Category)$/;
1141 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1142 $create_args{$arg} = $ARGS{$arg};
1145 # Object-RT::Ticket--CustomField-3-Values
1146 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1149 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1151 unless ( $cf->id ) {
1152 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1156 if ( $arg =~ /-Upload$/ ) {
1157 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1161 my $type = $cf->Type;
1164 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1165 @values = @{ $ARGS{$arg} };
1166 } elsif ( $type =~ /text/i ) {
1167 @values = ( $ARGS{$arg} );
1169 no warnings 'uninitialized';
1170 @values = split /\r*\n/, $ARGS{$arg};
1172 @values = grep length, map {
1178 grep defined, @values;
1180 $create_args{"CustomField-$cfid"} = \@values;
1184 # turn new link lists into arrays, and pass in the proper arguments
1186 'new-DependsOn' => 'DependsOn',
1187 'DependsOn-new' => 'DependedOnBy',
1188 'new-MemberOf' => 'Parents',
1189 'MemberOf-new' => 'Children',
1190 'new-RefersTo' => 'RefersTo',
1191 'RefersTo-new' => 'ReferredToBy',
1193 foreach my $key ( keys %map ) {
1194 next unless $ARGS{$key};
1195 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1199 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1204 push( @Actions, split( "\n", $ErrMsg ) );
1205 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1206 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1208 return ( $Ticket, @Actions );
1214 # {{{ sub LoadTicket - loads a ticket
1216 =head2 LoadTicket id
1218 Takes a ticket id as its only variable. if it's handed an array, it takes
1221 Returns an RT::Ticket object as the current user.
1228 if ( ref($id) eq "ARRAY" ) {
1233 Abort("No ticket specified");
1236 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1238 unless ( $Ticket->id ) {
1239 Abort("Could not load ticket $id");
1246 # {{{ sub ProcessUpdateMessage
1248 =head2 ProcessUpdateMessage
1250 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1252 Don't write message if it only contains current user's signature and
1253 SkipSignatureOnly argument is true. Function anyway adds attachments
1254 and updates time worked field even if skips message. The default value
1259 sub ProcessUpdateMessage {
1264 SkipSignatureOnly => 1,
1268 if ( $args{ARGSRef}->{'UpdateAttachments'}
1269 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1271 delete $args{ARGSRef}->{'UpdateAttachments'};
1274 # Strip the signature
1275 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1276 Content => $args{ARGSRef}->{UpdateContent},
1277 ContentType => $args{ARGSRef}->{UpdateContentType},
1278 StripSignature => $args{SkipSignatureOnly},
1279 CurrentUser => $args{'TicketObj'}->CurrentUser,
1282 # If, after stripping the signature, we have no message, move the
1283 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1284 # ProcessBasics can deal -- then bail out.
1285 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1286 and not length $args{ARGSRef}->{'UpdateContent'} )
1288 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1289 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1294 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1295 $args{ARGSRef}->{'UpdateSubject'} = undef;
1298 my $Message = MakeMIMEEntity(
1299 Subject => $args{ARGSRef}->{'UpdateSubject'},
1300 Body => $args{ARGSRef}->{'UpdateContent'},
1301 Type => $args{ARGSRef}->{'UpdateContentType'},
1304 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1305 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1307 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1308 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1309 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1311 $old_txn = $args{TicketObj}->Transactions->First();
1314 if ( my $msg = $old_txn->Message->First ) {
1315 RT::Interface::Email::SetInReplyTo(
1316 Message => $Message,
1321 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1322 $Message->make_multipart;
1323 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1326 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1327 require RT::Action::SendEmail;
1328 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1329 ref $args{ARGSRef}->{'AttachTickets'}
1330 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1331 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1334 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1335 my $cc = $args{ARGSRef}->{'UpdateCc'};
1337 my %txn_customfields;
1339 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1340 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1341 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1345 my %message_args = (
1347 BccMessageTo => $bcc,
1348 Sign => $args{ARGSRef}->{'Sign'},
1349 Encrypt => $args{ARGSRef}->{'Encrypt'},
1350 MIMEObj => $Message,
1351 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1352 CustomFields => \%txn_customfields,
1356 foreach my $type (qw(Cc AdminCc)) {
1357 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1358 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1359 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1360 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1363 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1364 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1365 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1368 if (@temp_squelch) {
1369 require RT::Action::SendEmail;
1370 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1373 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1374 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1375 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1377 my $var = ucfirst($1) . 'MessageTo';
1379 if ( $message_args{$var} ) {
1380 $message_args{$var} .= ", $value";
1382 $message_args{$var} = $value;
1388 # Do the update via the appropriate Ticket method
1389 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1390 my ( $Transaction, $Description, $Object ) =
1391 $args{TicketObj}->Comment(%message_args);
1392 push( @results, $Description );
1393 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1394 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1395 my ( $Transaction, $Description, $Object ) =
1396 $args{TicketObj}->Correspond(%message_args);
1397 push( @results, $Description );
1398 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1401 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1408 # {{{ sub MakeMIMEEntity
1410 =head2 MakeMIMEEntity PARAMHASH
1412 Takes a paramhash Subject, Body and AttachmentFieldName.
1414 Also takes Form, Cc and Type as optional paramhash keys.
1416 Returns a MIME::Entity.
1420 sub MakeMIMEEntity {
1422 #TODO document what else this takes.
1428 AttachmentFieldName => undef,
1432 my $Message = MIME::Entity->build(
1433 Type => 'multipart/mixed',
1434 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1435 grep defined $args{$_}, qw(Subject From Cc)
1438 if ( defined $args{'Body'} && length $args{'Body'} ) {
1440 # Make the update content have no 'weird' newlines in it
1441 $args{'Body'} =~ s/\r\n/\n/gs;
1444 Type => $args{'Type'} || 'text/plain',
1446 Data => $args{'Body'},
1450 if ( $args{'AttachmentFieldName'} ) {
1452 my $cgi_object = $m->cgi_object;
1454 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1456 my ( @content, $buffer );
1457 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1458 push @content, $buffer;
1461 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1463 # Prefer the cached name first over CGI.pm stringification.
1464 my $filename = $RT::Mason::CGI::Filename;
1465 $filename = "$filehandle" unless defined $filename;
1466 $filename = Encode::encode_utf8( $filename );
1467 $filename =~ s{^.*[\\/]}{};
1470 Type => $uploadinfo->{'Content-Type'},
1471 Filename => $filename,
1474 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1475 $Message->head->set( 'Subject' => $filename );
1480 $Message->make_singlepart;
1482 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1490 # {{{ sub ParseDateToISO
1492 =head2 ParseDateToISO
1494 Takes a date in an arbitrary format.
1495 Returns an ISO date and time in GMT
1499 sub ParseDateToISO {
1502 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1504 Format => 'unknown',
1507 return ( $date_obj->ISO );
1512 # {{{ sub ProcessACLChanges
1514 sub ProcessACLChanges {
1515 my $ARGSref = shift;
1519 foreach my $arg ( keys %$ARGSref ) {
1520 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1522 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1525 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1526 @rights = @{ $ARGSref->{$arg} };
1528 @rights = $ARGSref->{$arg};
1530 @rights = grep $_, @rights;
1531 next unless @rights;
1533 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1534 $principal->Load($principal_id);
1537 if ( $object_type eq 'RT::System' ) {
1539 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1540 $obj = $object_type->new( $session{'CurrentUser'} );
1541 $obj->Load($object_id);
1542 unless ( $obj->id ) {
1543 $RT::Logger->error("couldn't load $object_type #$object_id");
1547 $RT::Logger->error("object type '$object_type' is incorrect");
1548 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1552 foreach my $right (@rights) {
1553 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1554 push( @results, $msg );
1563 # {{{ sub UpdateRecordObj
1565 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1567 @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.
1569 Returns an array of success/failure messages
1573 sub UpdateRecordObject {
1576 AttributesRef => undef,
1578 AttributePrefix => undef,
1582 my $Object = $args{'Object'};
1583 my @results = $Object->Update(
1584 AttributesRef => $args{'AttributesRef'},
1585 ARGSRef => $args{'ARGSRef'},
1586 AttributePrefix => $args{'AttributePrefix'},
1594 # {{{ Sub ProcessCustomFieldUpdates
1596 sub ProcessCustomFieldUpdates {
1598 CustomFieldObj => undef,
1603 my $Object = $args{'CustomFieldObj'};
1604 my $ARGSRef = $args{'ARGSRef'};
1606 my @attribs = qw(Name Type Description Queue SortOrder);
1607 my @results = UpdateRecordObject(
1608 AttributesRef => \@attribs,
1613 my $prefix = "CustomField-" . $Object->Id;
1614 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1615 my ( $addval, $addmsg ) = $Object->AddValue(
1616 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1617 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1618 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1620 push( @results, $addmsg );
1624 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1625 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1626 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1628 foreach my $id (@delete_values) {
1629 next unless defined $id;
1630 my ( $err, $msg ) = $Object->DeleteValue($id);
1631 push( @results, $msg );
1634 my $vals = $Object->Values();
1635 while ( my $cfv = $vals->Next() ) {
1636 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1637 if ( $cfv->SortOrder != $so ) {
1638 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1639 push( @results, $msg );
1649 # {{{ sub ProcessTicketBasics
1651 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1653 Returns an array of results messages.
1657 sub ProcessTicketBasics {
1665 my $TicketObj = $args{'TicketObj'};
1666 my $ARGSRef = $args{'ARGSRef'};
1668 # {{{ Set basic fields
1681 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1682 my $tempqueue = RT::Queue->new($RT::SystemUser);
1683 $tempqueue->Load( $ARGSRef->{'Queue'} );
1684 if ( $tempqueue->id ) {
1685 $ARGSRef->{'Queue'} = $tempqueue->id;
1689 # Status isn't a field that can be set to a null value.
1690 # RT core complains if you try
1691 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1693 my @results = UpdateRecordObject(
1694 AttributesRef => \@attribs,
1695 Object => $TicketObj,
1696 ARGSRef => $ARGSRef,
1699 # We special case owner changing, so we can use ForceOwnerChange
1700 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1702 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1703 $ChownType = "Force";
1705 $ChownType = "Give";
1708 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1709 push( @results, $msg );
1719 sub ProcessTicketCustomFieldUpdates {
1721 $args{'Object'} = delete $args{'TicketObj'};
1722 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1724 # Build up a list of objects that we want to work with
1725 my %custom_fields_to_mod;
1726 foreach my $arg ( keys %$ARGSRef ) {
1727 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1728 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1729 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1730 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1731 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
1732 delete $ARGSRef->{$arg}; # don't try to update transaction fields
1736 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1739 sub ProcessObjectCustomFieldUpdates {
1741 my $ARGSRef = $args{'ARGSRef'};
1744 # Build up a list of objects that we want to work with
1745 my %custom_fields_to_mod;
1746 foreach my $arg ( keys %$ARGSRef ) {
1748 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1749 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1751 # For each of those objects, find out what custom fields we want to work with.
1752 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1755 # For each of those objects
1756 foreach my $class ( keys %custom_fields_to_mod ) {
1757 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1758 my $Object = $args{'Object'};
1759 $Object = $class->new( $session{'CurrentUser'} )
1760 unless $Object && ref $Object eq $class;
1762 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1763 unless ( $Object->id ) {
1764 $RT::Logger->warning("Couldn't load object $class #$id");
1768 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1769 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1770 $CustomFieldObj->LoadById($cf);
1771 unless ( $CustomFieldObj->id ) {
1772 $RT::Logger->warning("Couldn't load custom field #$cf");
1776 _ProcessObjectCustomFieldUpdates(
1777 Prefix => "Object-$class-$id-CustomField-$cf-",
1779 CustomField => $CustomFieldObj,
1780 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1788 sub _ProcessObjectCustomFieldUpdates {
1790 my $cf = $args{'CustomField'};
1791 my $cf_type = $cf->Type;
1793 # Remove blank Values since the magic field will take care of this. Sometimes
1794 # the browser gives you a blank value which causes CFs to be processed twice
1795 if ( defined $args{'ARGS'}->{'Values'}
1796 && !length $args{'ARGS'}->{'Values'}
1797 && $args{'ARGS'}->{'Values-Magic'} )
1799 delete $args{'ARGS'}->{'Values'};
1803 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1805 # skip category argument
1806 next if $arg eq 'Category';
1808 # since http won't pass in a form element with a null value, we need
1810 if ( $arg eq 'Values-Magic' ) {
1812 # We don't care about the magic, if there's really a values element;
1813 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1814 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1816 # "Empty" values does not mean anything for Image and Binary fields
1817 next if $cf_type =~ /^(?:Image|Binary)$/;
1820 $args{'ARGS'}->{'Values'} = undef;
1824 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1825 @values = @{ $args{'ARGS'}->{$arg} };
1826 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1827 @values = ( $args{'ARGS'}->{$arg} );
1829 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1830 if defined $args{'ARGS'}->{$arg};
1832 @values = grep length, map {
1838 grep defined, @values;
1840 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1841 foreach my $value (@values) {
1842 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1846 push( @results, $msg );
1848 } elsif ( $arg eq 'Upload' ) {
1849 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1850 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1851 push( @results, $msg );
1852 } elsif ( $arg eq 'DeleteValues' ) {
1853 foreach my $value (@values) {
1854 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1858 push( @results, $msg );
1860 } elsif ( $arg eq 'DeleteValueIds' ) {
1861 foreach my $value (@values) {
1862 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1866 push( @results, $msg );
1868 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1869 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1872 foreach my $value (@values) {
1873 if ( my $entry = $cf_values->HasEntry($value) ) {
1874 $values_hash{ $entry->id } = 1;
1878 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1882 push( @results, $msg );
1883 $values_hash{$val} = 1 if $val;
1886 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1887 return @results if ( $cf->Type eq 'Date' && ! @values );
1889 $cf_values->RedoSearch;
1890 while ( my $cf_value = $cf_values->Next ) {
1891 next if $values_hash{ $cf_value->id };
1893 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1895 ValueId => $cf_value->id
1897 push( @results, $msg );
1899 } elsif ( $arg eq 'Values' ) {
1900 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1902 # keep everything up to the point of difference, delete the rest
1904 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1905 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1914 # now add/replace extra things, if any
1915 foreach my $value (@values) {
1916 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1920 push( @results, $msg );
1925 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1926 $cf->Name, ref $args{'Object'},
1935 # {{{ sub ProcessTicketWatchers
1937 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1939 Returns an array of results messages.
1943 sub ProcessTicketWatchers {
1951 my $Ticket = $args{'TicketObj'};
1952 my $ARGSRef = $args{'ARGSRef'};
1956 foreach my $key ( keys %$ARGSRef ) {
1958 # Delete deletable watchers
1959 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1960 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1964 push @results, $msg;
1967 # Delete watchers in the simple style demanded by the bulk manipulator
1968 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1969 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1970 Email => $ARGSRef->{$key},
1973 push @results, $msg;
1976 # Add new wathchers by email address
1977 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1978 and $key =~ /^WatcherTypeEmail(\d*)$/ )
1981 #They're in this order because otherwise $1 gets clobbered :/
1982 my ( $code, $msg ) = $Ticket->AddWatcher(
1983 Type => $ARGSRef->{$key},
1984 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1986 push @results, $msg;
1989 #Add requestors in the simple style demanded by the bulk manipulator
1990 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1991 my ( $code, $msg ) = $Ticket->AddWatcher(
1993 Email => $ARGSRef->{$key}
1995 push @results, $msg;
1998 # Add new watchers by owner
1999 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2000 my $principal_id = $1;
2001 my $form = $ARGSRef->{$key};
2002 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2003 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2005 my ( $code, $msg ) = $Ticket->AddWatcher(
2007 PrincipalId => $principal_id
2009 push @results, $msg;
2019 # {{{ sub ProcessTicketDates
2021 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2023 Returns an array of results messages.
2027 sub ProcessTicketDates {
2034 my $Ticket = $args{'TicketObj'};
2035 my $ARGSRef = $args{'ARGSRef'};
2039 # {{{ Set date fields
2040 my @date_fields = qw(
2048 #Run through each field in this list. update the value if apropriate
2049 foreach my $field (@date_fields) {
2050 next unless exists $ARGSRef->{ $field . '_Date' };
2051 next if $ARGSRef->{ $field . '_Date' } eq '';
2055 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2057 Format => 'unknown',
2058 Value => $ARGSRef->{ $field . '_Date' }
2061 my $obj = $field . "Obj";
2062 if ( ( defined $DateObj->Unix )
2063 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2065 my $method = "Set$field";
2066 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2067 push @results, "$msg";
2077 # {{{ sub ProcessTicketLinks
2079 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2081 Returns an array of results messages.
2085 sub ProcessTicketLinks {
2092 my $Ticket = $args{'TicketObj'};
2093 my $ARGSRef = $args{'ARGSRef'};
2095 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2097 #Merge if we need to
2098 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2099 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2100 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2101 push @results, $msg;
2109 sub ProcessRecordLinks {
2116 my $Record = $args{'RecordObj'};
2117 my $ARGSRef = $args{'ARGSRef'};
2121 # Delete links that are gone gone gone.
2122 foreach my $arg ( keys %$ARGSRef ) {
2123 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2128 my ( $val, $msg ) = $Record->DeleteLink(
2134 push @results, $msg;
2140 my @linktypes = qw( DependsOn MemberOf RefersTo );
2142 foreach my $linktype (@linktypes) {
2143 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2144 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2145 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2147 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2149 $luri =~ s/\s+$//; # Strip trailing whitespace
2150 my ( $val, $msg ) = $Record->AddLink(
2154 push @results, $msg;
2157 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2158 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2159 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2161 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2163 my ( $val, $msg ) = $Record->AddLink(
2168 push @results, $msg;
2176 =head2 _UploadedFile ( $arg );
2178 Takes a CGI parameter name; if a file is uploaded under that name,
2179 return a hash reference suitable for AddCustomFieldValue's use:
2180 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2182 Returns C<undef> if no files were uploaded in the C<$arg> field.
2188 my $cgi_object = $m->cgi_object;
2189 my $fh = $cgi_object->upload($arg) or return undef;
2190 my $upload_info = $cgi_object->uploadInfo($fh);
2192 my $filename = "$fh";
2193 $filename =~ s#^.*[\\/]##;
2198 LargeContent => do { local $/; scalar <$fh> },
2199 ContentType => $upload_info->{'Content-Type'},
2203 sub GetColumnMapEntry {
2204 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2206 # deal with the simplest thing first
2207 if ( $args{'Map'}{ $args{'Name'} } ) {
2208 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2212 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2213 return undef unless $args{'Map'}->{$mainkey};
2214 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2215 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2217 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2222 sub ProcessColumnMapValue {
2224 my %args = ( Arguments => [], Escape => 1, @_ );
2227 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2228 my @tmp = $value->( @{ $args{'Arguments'} } );
2229 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2230 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2231 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2232 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2237 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2241 =head2 _load_container_object ( $type, $id );
2243 Instantiate container object for saving searches.
2247 sub _load_container_object {
2248 my ( $obj_type, $obj_id ) = @_;
2249 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2252 =head2 _parse_saved_search ( $arg );
2254 Given a serialization string for saved search, and returns the
2255 container object and the search id.
2259 sub _parse_saved_search {
2261 return unless $spec;
2262 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2269 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2272 eval "require RT::Interface::Web_Vendor";
2273 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2274 eval "require RT::Interface::Web_Local";
2275 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );