1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
6 # <jesse@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 MaybeShowNoAuthPage($ARGS);
197 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
199 _ForceLogout() unless _UserLoggedIn();
201 # Process per-page authentication callbacks
202 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
204 unless ( _UserLoggedIn() ) {
207 # If the user is logging in, let's authenticate
208 if ( defined $ARGS->{user} && defined $ARGS->{pass} ) {
209 AttemptPasswordAuthentication($ARGS);
211 # if no credentials then show him login page
212 $HTML::Mason::Commands::m->comp( '/Elements/Login', %$ARGS );
213 $HTML::Mason::Commands::m->abort;
217 # now it applies not only to home page, but any dashboard that can be used as a workspace
218 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
219 if ( $ARGS->{'HomeRefreshInterval'} );
221 # Process per-page global callbacks
222 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
224 ShowRequestedPage($ARGS);
225 LogRecordedSQLStatements();
230 delete $HTML::Mason::Commands::session{'CurrentUser'};
234 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
242 =head2 MaybeShowInstallModePage
244 This function, called exclusively by RT's autohandler, dispatches
245 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
247 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
251 sub MaybeShowInstallModePage {
252 return unless RT->InstallMode;
254 my $m = $HTML::Mason::Commands::m;
255 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
257 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
258 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
265 =head2 MaybeShowNoAuthPage \%ARGS
267 This function, called exclusively by RT's autohandler, dispatches
268 a request to the page a user requested (but only if it matches the "noauth" regex.
270 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
274 sub MaybeShowNoAuthPage {
277 my $m = $HTML::Mason::Commands::m;
279 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
281 # If it's a noauth file, don't ask for auth.
283 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
287 =head2 ShowRequestedPage \%ARGS
289 This function, called exclusively by RT's autohandler, dispatches
290 a request to the page a user requested (making sure that unpriviled users
291 can only see self-service pages.
295 sub ShowRequestedPage {
298 my $m = $HTML::Mason::Commands::m;
302 # If the user isn't privileged, they can only see SelfService
303 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
305 # if the user is trying to access a ticket, redirect them
306 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
307 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
310 # otherwise, drop the user at the SelfService default page
311 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
312 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
315 # if user is in SelfService dir let him do anything
317 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
320 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
325 sub AttemptExternalAuth {
328 return unless ( RT->Config->Get('WebExternalAuth') );
330 my $user = $ARGS->{user};
331 my $m = $HTML::Mason::Commands::m;
333 # If RT is configured for external auth, let's go through and get REMOTE_USER
335 # do we actually have a REMOTE_USER equivlent?
336 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
337 my $orig_user = $user;
339 $user = RT::Interface::Web::WebCanonicalizeInfo();
340 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
342 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
343 my $NodeName = Win32::NodeName();
344 $user =~ s/^\Q$NodeName\E\\//i;
347 InstantiateNewSession() unless _UserLoggedIn;
348 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
349 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
351 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
353 # Create users on-the-fly
354 my $UserObj = RT::User->new($RT::SystemUser);
355 my ( $val, $msg ) = $UserObj->Create(
356 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
363 # now get user specific information, to better create our user.
364 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
366 # set the attributes that have been defined.
367 foreach my $attribute ( $UserObj->WritableAttributes ) {
369 Attribute => $attribute,
371 UserInfo => $new_user_info,
372 CallbackName => 'NewUser',
373 CallbackPage => '/autohandler'
375 my $method = "Set$attribute";
376 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
378 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
381 # we failed to successfully create the user. abort abort abort.
382 delete $HTML::Mason::Commands::session{'CurrentUser'};
383 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc( 'Cannot create user: [_1]', $msg ) )
384 if RT->Config->Get('WebFallbackToInternalAuth');;
389 if ( _UserLoggedIn() ) {
390 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
392 delete $HTML::Mason::Commands::session{'CurrentUser'};
395 if ( RT->Config->Get('WebExternalOnly') ) {
396 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('You are not an authorized user') );
400 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
401 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
402 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
403 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('You are not an authorized user') );
408 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
409 # XXX: we must return AUTH_REQUIRED status or we fallback to
410 # internal auth here too.
411 delete $HTML::Mason::Commands::session{'CurrentUser'}
412 if defined $HTML::Mason::Commands::session{'CurrentUser'};
416 sub AttemptPasswordAuthentication {
418 my $user_obj = RT::CurrentUser->new();
419 $user_obj->Load( $ARGS->{user} );
421 my $m = $HTML::Mason::Commands::m;
423 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
424 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
425 $m->comp( '/Elements/Login', %$ARGS, Error => HTML::Mason::Commands::loc('Your username or password is incorrect'), );
426 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
430 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
431 InstantiateNewSession();
432 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
433 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
436 =head2 LoadSessionFromCookie
438 Load or setup a session cookie for the current user.
442 sub _SessionCookieName {
443 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
444 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
448 sub LoadSessionFromCookie {
450 my %cookies = CGI::Cookie->fetch;
451 my $cookiename = _SessionCookieName();
452 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
453 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
454 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
455 undef $cookies{$cookiename};
457 if ( int RT->Config->Get('AutoLogoff') ) {
458 my $now = int( time / 60 );
459 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
461 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
462 InstantiateNewSession();
465 # save session on each request when AutoLogoff is turned on
466 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
470 sub InstantiateNewSession {
471 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
472 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
475 sub SendSessionCookie {
476 my $cookie = CGI::Cookie->new(
477 -name => _SessionCookieName(),
478 -value => $HTML::Mason::Commands::session{_session_id},
479 -path => RT->Config->Get('WebPath'),
480 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 )
483 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
488 This routine ells the current user's browser to redirect to URL.
489 Additionally, it unties the user's currently active session, helping to avoid
490 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
491 a cached DBI statement handle twice at the same time.
496 my $redir_to = shift;
497 untie $HTML::Mason::Commands::session;
498 my $uri = URI->new($redir_to);
499 my $server_uri = URI->new( RT->Config->Get('WebURL') );
501 # If the user is coming in via a non-canonical
502 # hostname, don't redirect them to the canonical host,
503 # it will just upset them (and invalidate their credentials)
504 # don't do this if $RT::CanoniaclRedirectURLs is true
505 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
506 && $uri->host eq $server_uri->host
507 && $uri->port eq $server_uri->port )
509 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
510 $uri->scheme('https');
512 $uri->scheme('http');
515 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
516 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
517 $uri->port( $ENV{'SERVER_PORT'} );
520 # not sure why, but on some systems without this call mason doesn't
521 # set status to 302, but 200 instead and people see blank pages
522 $HTML::Mason::Commands::r->status(302);
524 # Perlbal expects a status message, but Mason's default redirect status
525 # doesn't provide one. See also rt.cpan.org #36689.
526 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
528 $HTML::Mason::Commands::m->abort;
531 =head2 StaticFileHeaders
533 Send the browser a few headers to try to get it to (somewhat agressively)
534 cache RT's static Javascript and CSS files.
536 This routine could really use _accurate_ heuristics. (XXX TODO)
540 sub StaticFileHeaders {
541 my $date = RT::Date->new($RT::SystemUser);
544 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
546 # Expire things in a month.
547 $date->Set( Value => time + 30 * 24 * 60 * 60 );
548 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
550 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
551 # request, but we don't handle it and generate full reply again
552 # Last modified at server start time
553 # $date->Set( Value => $^T );
554 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
557 =head2 SendStaticFile
559 Takes a File => path and a Type => Content-type
561 If Type isn't provided and File is an image, it will
562 figure out a sane Content-type, otherwise it will
563 send application/octet-stream
565 Will set caching headers using StaticFileHeaders
572 my $file = $args{File};
573 my $type = $args{Type};
575 $self->StaticFileHeaders();
578 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
580 $type =~ s/jpg/jpeg/gi;
582 $type ||= "application/octet-stream";
584 $HTML::Mason::Commands::r->content_type($type);
585 open my $fh, "<$file" or die "couldn't open file: $!";
589 $HTML::Mason::Commands::m->out($_) while (<$fh>);
590 $HTML::Mason::Commands::m->flush_buffer;
597 my $content = $args{Content};
598 return '' unless $content;
600 # Make the content have no 'weird' newlines in it
601 $content =~ s/\r+\n/\n/g;
603 my $return_content = $content;
605 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
606 my $sigonly = $args{StripSignature};
608 # massage content to easily detect if there's any real content
609 $content =~ s/\s+//g; # yes! remove all the spaces
611 # remove html version of spaces and newlines
612 $content =~ s! !!g;
613 $content =~ s!<br/?>!!g;
616 # Filter empty content when type is text/html
617 return '' if $html && $content !~ /\S/;
619 # If we aren't supposed to strip the sig, just bail now.
620 return $return_content unless $sigonly;
623 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
626 # Check for plaintext sig
627 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
629 # Check for html-formatted sig
630 RT::Interface::Web::EscapeUTF8( \$sig );
633 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
636 return $return_content;
644 # if they've passed multiple values, they'll be an array. if they've
645 # passed just one, a scalar whatever they are, mark them as utf8
648 ? Encode::is_utf8($_)
650 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
651 : ( $type eq 'ARRAY' )
652 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
654 : ( $type eq 'HASH' )
655 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
661 sub PreprocessTimeUpdates {
664 # Later in the code we use
665 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
666 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
667 # The call_next method pass through original arguments and if you have
668 # an argument with unicode key then in a next component you'll get two
669 # records in the args hash: one with key without UTF8 flag and another
670 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
671 # is copied from mason's source to get the same results as we get from
672 # call_next method, this feature is not documented, so we just leave it
673 # here to avoid possible side effects.
675 # This code canonicalizes time inputs in hours into minutes
676 foreach my $field ( keys %$ARGS ) {
677 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
679 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
680 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
681 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
682 $ARGS->{$local} *= 60;
684 delete $ARGS->{$field};
689 sub MaybeEnableSQLStatementLog {
691 my $log_sql_statements = RT->Config->Get('StatementLog');
693 if ($log_sql_statements) {
694 $RT::Handle->ClearSQLStatementLog;
695 $RT::Handle->LogSQLStatements(1);
700 sub LogRecordedSQLStatements {
701 my $log_sql_statements = RT->Config->Get('StatementLog');
703 return unless ($log_sql_statements);
705 my @log = $RT::Handle->SQLStatementLog;
706 $RT::Handle->ClearSQLStatementLog;
707 for my $stmt (@log) {
708 my ( $time, $sql, $bind, $duration ) = @{$stmt};
718 level => $log_sql_statements,
720 . sprintf( "%.6f", $duration )
722 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
728 package HTML::Mason::Commands;
730 use vars qw/$r $m %session/;
736 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
737 with whatever it's called with. If there is no $session{'CurrentUser'},
738 it creates a temporary user, so we have something to get a localisation handle
745 if ( $session{'CurrentUser'}
746 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
748 return ( $session{'CurrentUser'}->loc(@_) );
751 RT::CurrentUser->new();
755 return ( $u->loc(@_) );
758 # pathetic case -- SystemUser is gone.
767 =head2 loc_fuzzy STRING
769 loc_fuzzy is for handling localizations of messages that may already
770 contain interpolated variables, typically returned from libraries
771 outside RT's control. It takes the message string and extracts the
772 variable array automatically by matching against the candidate entries
773 inside the lexicon file.
780 if ( $session{'CurrentUser'}
781 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
783 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
785 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
786 return ( $u->loc_fuzzy($msg) );
793 # Error - calls Error and aborts
798 if ( $session{'ErrorDocument'}
799 && $session{'ErrorDocumentType'} )
801 $r->content_type( $session{'ErrorDocumentType'} );
802 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
805 $m->comp( "/Elements/Error", Why => $why, %args );
812 # {{{ sub CreateTicket
814 =head2 CreateTicket ARGS
816 Create a new ticket, using Mason's %ARGS. returns @results.
825 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
827 my $Queue = new RT::Queue( $session{'CurrentUser'} );
828 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
829 Abort('Queue not found');
832 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
833 Abort('You have no permission to create tickets in that queue.');
837 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
838 $due = new RT::Date( $session{'CurrentUser'} );
839 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
842 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
843 $starts = new RT::Date( $session{'CurrentUser'} );
844 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
847 my $sigless = RT::Interface::Web::StripContent(
848 Content => $ARGS{Content},
849 ContentType => $ARGS{ContentType},
851 CurrentUser => $session{'CurrentUser'},
854 my $MIMEObj = MakeMIMEEntity(
855 Subject => $ARGS{'Subject'},
856 From => $ARGS{'From'},
859 Type => $ARGS{'ContentType'},
862 if ( $ARGS{'Attachments'} ) {
863 my $rv = $MIMEObj->make_multipart;
864 $RT::Logger->error("Couldn't make multipart message")
865 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
867 foreach ( values %{ $ARGS{'Attachments'} } ) {
869 $RT::Logger->error("Couldn't add empty attachemnt");
872 $MIMEObj->add_part($_);
876 foreach my $argument (qw(Encrypt Sign)) {
877 $MIMEObj->head->add( "X-RT-$argument" => $ARGS{$argument} ) if defined $ARGS{$argument};
881 Type => $ARGS{'Type'} || 'ticket',
882 Queue => $ARGS{'Queue'},
883 Owner => $ARGS{'Owner'},
886 Requestor => $ARGS{'Requestors'},
888 AdminCc => $ARGS{'AdminCc'},
889 InitialPriority => $ARGS{'InitialPriority'},
890 FinalPriority => $ARGS{'FinalPriority'},
891 TimeLeft => $ARGS{'TimeLeft'},
892 TimeEstimated => $ARGS{'TimeEstimated'},
893 TimeWorked => $ARGS{'TimeWorked'},
894 Subject => $ARGS{'Subject'},
895 Status => $ARGS{'Status'},
896 Due => $due ? $due->ISO : undef,
897 Starts => $starts ? $starts->ISO : undef,
902 foreach my $type (qw(Requestor Cc AdminCc)) {
903 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
904 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
909 require RT::Action::SendEmail;
910 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
913 if ( $ARGS{'AttachTickets'} ) {
914 require RT::Action::SendEmail;
915 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
916 ref $ARGS{'AttachTickets'}
917 ? @{ $ARGS{'AttachTickets'} }
918 : ( $ARGS{'AttachTickets'} ) );
921 foreach my $arg ( keys %ARGS ) {
922 next if $arg =~ /-(?:Magic|Category)$/;
924 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
925 $create_args{$arg} = $ARGS{$arg};
928 # Object-RT::Ticket--CustomField-3-Values
929 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
932 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
935 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
939 if ( $arg =~ /-Upload$/ ) {
940 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
944 my $type = $cf->Type;
947 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
948 @values = @{ $ARGS{$arg} };
949 } elsif ( $type =~ /text/i ) {
950 @values = ( $ARGS{$arg} );
952 no warnings 'uninitialized';
953 @values = split /\r*\n/, $ARGS{$arg};
955 @values = grep length, map {
961 grep defined, @values;
963 $create_args{"CustomField-$cfid"} = \@values;
967 # turn new link lists into arrays, and pass in the proper arguments
969 'new-DependsOn' => 'DependsOn',
970 'DependsOn-new' => 'DependedOnBy',
971 'new-MemberOf' => 'Parents',
972 'MemberOf-new' => 'Children',
973 'new-RefersTo' => 'RefersTo',
974 'RefersTo-new' => 'ReferredToBy',
976 foreach my $key ( keys %map ) {
977 next unless $ARGS{$key};
978 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
982 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
987 push( @Actions, split( "\n", $ErrMsg ) );
988 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
989 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
991 return ( $Ticket, @Actions );
997 # {{{ sub LoadTicket - loads a ticket
1001 Takes a ticket id as its only variable. if it's handed an array, it takes
1004 Returns an RT::Ticket object as the current user.
1011 if ( ref($id) eq "ARRAY" ) {
1016 Abort("No ticket specified");
1019 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1021 unless ( $Ticket->id ) {
1022 Abort("Could not load ticket $id");
1029 # {{{ sub ProcessUpdateMessage
1031 =head2 ProcessUpdateMessage
1033 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1035 Don't write message if it only contains current user's signature and
1036 SkipSignatureOnly argument is true. Function anyway adds attachments
1037 and updates time worked field even if skips message. The default value
1042 sub ProcessUpdateMessage {
1047 SkipSignatureOnly => 1,
1051 if ( $args{ARGSRef}->{'UpdateAttachments'}
1052 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1054 delete $args{ARGSRef}->{'UpdateAttachments'};
1057 # Strip the signature
1058 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1059 Content => $args{ARGSRef}->{UpdateContent},
1060 ContentType => $args{ARGSRef}->{UpdateContentType},
1061 StripSignature => $args{SkipSignatureOnly},
1062 CurrentUser => $args{'TicketObj'}->CurrentUser,
1065 # If, after stripping the signature, we have no message, move the
1066 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1067 # ProcessBasics can deal -- then bail out.
1068 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1069 and not length $args{ARGSRef}->{'UpdateContent'} )
1071 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1072 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1077 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1078 $args{ARGSRef}->{'UpdateSubject'} = undef;
1081 my $Message = MakeMIMEEntity(
1082 Subject => $args{ARGSRef}->{'UpdateSubject'},
1083 Body => $args{ARGSRef}->{'UpdateContent'},
1084 Type => $args{ARGSRef}->{'UpdateContentType'},
1087 $Message->head->add( 'Message-ID' => RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'}, ) );
1088 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1089 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1090 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1092 $old_txn = $args{TicketObj}->Transactions->First();
1095 if ( my $msg = $old_txn->Message->First ) {
1096 RT::Interface::Email::SetInReplyTo(
1097 Message => $Message,
1102 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1103 $Message->make_multipart;
1104 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1107 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1108 require RT::Action::SendEmail;
1109 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1110 ref $args{ARGSRef}->{'AttachTickets'}
1111 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1112 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1115 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1116 my $cc = $args{ARGSRef}->{'UpdateCc'};
1118 my %message_args = (
1120 BccMessageTo => $bcc,
1121 Sign => $args{ARGSRef}->{'Sign'},
1122 Encrypt => $args{ARGSRef}->{'Encrypt'},
1123 MIMEObj => $Message,
1124 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
1127 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1128 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1129 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1131 my $var = ucfirst($1) . 'MessageTo';
1133 if ( $message_args{$var} ) {
1134 $message_args{$var} .= ", $value";
1136 $message_args{$var} = $value;
1142 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1143 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1144 push( @results, $Description );
1145 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1146 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1147 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1148 push( @results, $Description );
1149 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1152 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1159 # {{{ sub MakeMIMEEntity
1161 =head2 MakeMIMEEntity PARAMHASH
1163 Takes a paramhash Subject, Body and AttachmentFieldName.
1165 Also takes Form, Cc and Type as optional paramhash keys.
1167 Returns a MIME::Entity.
1171 sub MakeMIMEEntity {
1173 #TODO document what else this takes.
1179 AttachmentFieldName => undef,
1183 my $Message = MIME::Entity->build(
1184 Type => 'multipart/mixed',
1185 Subject => $args{'Subject'} || "",
1186 From => $args{'From'},
1190 if ( defined $args{'Body'} && length $args{'Body'} ) {
1192 # Make the update content have no 'weird' newlines in it
1193 $args{'Body'} =~ s/\r\n/\n/gs;
1195 # MIME::Head is not happy in utf-8 domain. This only happens
1196 # when processing an incoming email (so far observed).
1200 Type => $args{'Type'} || 'text/plain',
1202 Data => $args{'Body'},
1206 if ( $args{'AttachmentFieldName'} ) {
1208 my $cgi_object = $m->cgi_object;
1210 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1212 my ( @content, $buffer );
1213 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1214 push @content, $buffer;
1217 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1219 # Prefer the cached name first over CGI.pm stringification.
1220 my $filename = $RT::Mason::CGI::Filename;
1221 $filename = "$filehandle" unless defined($filename);
1222 $filename = Encode::decode_utf8($filename);
1223 $filename =~ s{^.*[\\/]}{};
1226 Type => $uploadinfo->{'Content-Type'},
1227 Filename => $filename,
1230 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1231 $Message->head->set( 'Subject' => $filename );
1236 $Message->make_singlepart;
1237 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1245 # {{{ sub ParseDateToISO
1247 =head2 ParseDateToISO
1249 Takes a date in an arbitrary format.
1250 Returns an ISO date and time in GMT
1254 sub ParseDateToISO {
1257 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1259 Format => 'unknown',
1262 return ( $date_obj->ISO );
1267 # {{{ sub ProcessACLChanges
1269 sub ProcessACLChanges {
1270 my $ARGSref = shift;
1272 #XXX: why don't we get ARGSref like in other Process* subs?
1276 foreach my $arg ( keys %$ARGSref ) {
1277 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1279 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1282 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1283 @rights = @{ $ARGSref->{$arg} };
1285 @rights = $ARGSref->{$arg};
1287 @rights = grep $_, @rights;
1288 next unless @rights;
1290 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1291 $principal->Load($principal_id);
1294 if ( $object_type eq 'RT::System' ) {
1296 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1297 $obj = $object_type->new( $session{'CurrentUser'} );
1298 $obj->Load($object_id);
1299 unless ( $obj->id ) {
1300 $RT::Logger->error("couldn't load $object_type #$object_id");
1304 $RT::Logger->error("object type '$object_type' is incorrect");
1305 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1309 foreach my $right (@rights) {
1310 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1311 push( @results, $msg );
1320 # {{{ sub UpdateRecordObj
1322 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1324 @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.
1326 Returns an array of success/failure messages
1330 sub UpdateRecordObject {
1333 AttributesRef => undef,
1335 AttributePrefix => undef,
1339 my $Object = $args{'Object'};
1340 my @results = $Object->Update(
1341 AttributesRef => $args{'AttributesRef'},
1342 ARGSRef => $args{'ARGSRef'},
1343 AttributePrefix => $args{'AttributePrefix'},
1351 # {{{ Sub ProcessCustomFieldUpdates
1353 sub ProcessCustomFieldUpdates {
1355 CustomFieldObj => undef,
1360 my $Object = $args{'CustomFieldObj'};
1361 my $ARGSRef = $args{'ARGSRef'};
1363 my @attribs = qw(Name Type Description Queue SortOrder);
1364 my @results = UpdateRecordObject(
1365 AttributesRef => \@attribs,
1370 my $prefix = "CustomField-" . $Object->Id;
1371 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1372 my ( $addval, $addmsg ) = $Object->AddValue(
1373 Name => $ARGSRef->{"$prefix-AddValue-Name"},
1374 Description => $ARGSRef->{"$prefix-AddValue-Description"},
1375 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1377 push( @results, $addmsg );
1381 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1382 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1383 : ( $ARGSRef->{"$prefix-DeleteValue"} );
1385 foreach my $id (@delete_values) {
1386 next unless defined $id;
1387 my ( $err, $msg ) = $Object->DeleteValue($id);
1388 push( @results, $msg );
1391 my $vals = $Object->Values();
1392 while ( my $cfv = $vals->Next() ) {
1393 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1394 if ( $cfv->SortOrder != $so ) {
1395 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1396 push( @results, $msg );
1406 # {{{ sub ProcessTicketBasics
1408 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1410 Returns an array of results messages.
1414 sub ProcessTicketBasics {
1422 my $TicketObj = $args{'TicketObj'};
1423 my $ARGSRef = $args{'ARGSRef'};
1425 # {{{ Set basic fields
1438 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1439 my $tempqueue = RT::Queue->new($RT::SystemUser);
1440 $tempqueue->Load( $ARGSRef->{'Queue'} );
1441 if ( $tempqueue->id ) {
1442 $ARGSRef->{'Queue'} = $tempqueue->id;
1446 # Status isn't a field that can be set to a null value.
1447 # RT core complains if you try
1448 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1450 my @results = UpdateRecordObject(
1451 AttributesRef => \@attribs,
1452 Object => $TicketObj,
1453 ARGSRef => $ARGSRef,
1456 # We special case owner changing, so we can use ForceOwnerChange
1457 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1459 if ( $ARGSRef->{'ForceOwnerChange'} ) {
1460 $ChownType = "Force";
1462 $ChownType = "Give";
1465 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1466 push( @results, $msg );
1476 sub ProcessTicketCustomFieldUpdates {
1478 $args{'Object'} = delete $args{'TicketObj'};
1479 my $ARGSRef = { %{ $args{'ARGSRef'} } };
1481 # Build up a list of objects that we want to work with
1482 my %custom_fields_to_mod;
1483 foreach my $arg ( keys %$ARGSRef ) {
1484 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1485 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1486 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1487 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1491 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1494 sub ProcessObjectCustomFieldUpdates {
1496 my $ARGSRef = $args{'ARGSRef'};
1499 # Build up a list of objects that we want to work with
1500 my %custom_fields_to_mod;
1501 foreach my $arg ( keys %$ARGSRef ) {
1503 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1504 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1506 # For each of those objects, find out what custom fields we want to work with.
1507 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1510 # For each of those objects
1511 foreach my $class ( keys %custom_fields_to_mod ) {
1512 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1513 my $Object = $args{'Object'};
1514 $Object = $class->new( $session{'CurrentUser'} )
1515 unless $Object && ref $Object eq $class;
1517 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1518 unless ( $Object->id ) {
1519 $RT::Logger->warning("Couldn't load object $class #$id");
1523 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1524 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1525 $CustomFieldObj->LoadById($cf);
1526 unless ( $CustomFieldObj->id ) {
1527 $RT::Logger->warning("Couldn't load custom field #$cf");
1531 _ProcessObjectCustomFieldUpdates(
1532 Prefix => "Object-$class-$id-CustomField-$cf-",
1534 CustomField => $CustomFieldObj,
1535 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
1543 sub _ProcessObjectCustomFieldUpdates {
1545 my $cf = $args{'CustomField'};
1546 my $cf_type = $cf->Type;
1548 # Remove blank Values since the magic field will take care of this. Sometimes
1549 # the browser gives you a blank value which causes CFs to be processed twice
1550 if ( defined $args{'ARGS'}->{'Values'}
1551 && !length $args{'ARGS'}->{'Values'}
1552 && $args{'ARGS'}->{'Values-Magic'} )
1554 delete $args{'ARGS'}->{'Values'};
1558 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1560 # skip category argument
1561 next if $arg eq 'Category';
1563 # since http won't pass in a form element with a null value, we need
1565 if ( $arg eq 'Values-Magic' ) {
1567 # We don't care about the magic, if there's really a values element;
1568 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
1569 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1571 # "Empty" values does not mean anything for Image and Binary fields
1572 next if $cf_type =~ /^(?:Image|Binary)$/;
1575 $args{'ARGS'}->{'Values'} = undef;
1579 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1580 @values = @{ $args{'ARGS'}->{$arg} };
1581 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
1582 @values = ( $args{'ARGS'}->{$arg} );
1584 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1585 if defined $args{'ARGS'}->{$arg};
1587 @values = grep length, map {
1593 grep defined, @values;
1595 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1596 foreach my $value (@values) {
1597 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1601 push( @results, $msg );
1603 } elsif ( $arg eq 'Upload' ) {
1604 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1605 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1606 push( @results, $msg );
1607 } elsif ( $arg eq 'DeleteValues' ) {
1608 foreach my $value (@values) {
1609 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1613 push( @results, $msg );
1615 } elsif ( $arg eq 'DeleteValueIds' ) {
1616 foreach my $value (@values) {
1617 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1621 push( @results, $msg );
1623 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1624 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1627 foreach my $value (@values) {
1628 if ( my $entry = $cf_values->HasEntry($value) ) {
1629 $values_hash{ $entry->id } = 1;
1633 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1637 push( @results, $msg );
1638 $values_hash{$val} = 1 if $val;
1641 $cf_values->RedoSearch;
1642 while ( my $cf_value = $cf_values->Next ) {
1643 next if $values_hash{ $cf_value->id };
1645 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1647 ValueId => $cf_value->id
1649 push( @results, $msg );
1651 } elsif ( $arg eq 'Values' ) {
1652 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1654 # keep everything up to the point of difference, delete the rest
1656 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1657 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1666 # now add/replace extra things, if any
1667 foreach my $value (@values) {
1668 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1672 push( @results, $msg );
1677 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1678 $cf->Name, ref $args{'Object'},
1687 # {{{ sub ProcessTicketWatchers
1689 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1691 Returns an array of results messages.
1695 sub ProcessTicketWatchers {
1703 my $Ticket = $args{'TicketObj'};
1704 my $ARGSRef = $args{'ARGSRef'};
1708 foreach my $key ( keys %$ARGSRef ) {
1710 # Delete deletable watchers
1711 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1712 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1716 push @results, $msg;
1719 # Delete watchers in the simple style demanded by the bulk manipulator
1720 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1721 my ( $code, $msg ) = $Ticket->DeleteWatcher(
1722 Email => $ARGSRef->{$key},
1725 push @results, $msg;
1728 # Add new wathchers by email address
1729 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1730 and $key =~ /^WatcherTypeEmail(\d*)$/ )
1733 #They're in this order because otherwise $1 gets clobbered :/
1734 my ( $code, $msg ) = $Ticket->AddWatcher(
1735 Type => $ARGSRef->{$key},
1736 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1738 push @results, $msg;
1741 #Add requestors in the simple style demanded by the bulk manipulator
1742 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1743 my ( $code, $msg ) = $Ticket->AddWatcher(
1745 Email => $ARGSRef->{$key}
1747 push @results, $msg;
1750 # Add new watchers by owner
1751 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1752 my $principal_id = $1;
1753 my $form = $ARGSRef->{$key};
1754 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1755 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1757 my ( $code, $msg ) = $Ticket->AddWatcher(
1759 PrincipalId => $principal_id
1761 push @results, $msg;
1771 # {{{ sub ProcessTicketDates
1773 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1775 Returns an array of results messages.
1779 sub ProcessTicketDates {
1786 my $Ticket = $args{'TicketObj'};
1787 my $ARGSRef = $args{'ARGSRef'};
1791 # {{{ Set date fields
1792 my @date_fields = qw(
1800 #Run through each field in this list. update the value if apropriate
1801 foreach my $field (@date_fields) {
1802 next unless exists $ARGSRef->{ $field . '_Date' };
1803 next if $ARGSRef->{ $field . '_Date' } eq '';
1807 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
1809 Format => 'unknown',
1810 Value => $ARGSRef->{ $field . '_Date' }
1813 my $obj = $field . "Obj";
1814 if ( ( defined $DateObj->Unix )
1815 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
1817 my $method = "Set$field";
1818 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
1819 push @results, "$msg";
1829 # {{{ sub ProcessTicketLinks
1831 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1833 Returns an array of results messages.
1837 sub ProcessTicketLinks {
1844 my $Ticket = $args{'TicketObj'};
1845 my $ARGSRef = $args{'ARGSRef'};
1847 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
1849 #Merge if we need to
1850 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
1851 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
1852 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
1853 push @results, $msg;
1861 sub ProcessRecordLinks {
1868 my $Record = $args{'RecordObj'};
1869 my $ARGSRef = $args{'ARGSRef'};
1873 # Delete links that are gone gone gone.
1874 foreach my $arg ( keys %$ARGSRef ) {
1875 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
1880 my ( $val, $msg ) = $Record->DeleteLink(
1886 push @results, $msg;
1892 my @linktypes = qw( DependsOn MemberOf RefersTo );
1894 foreach my $linktype (@linktypes) {
1895 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
1896 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
1897 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
1899 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
1901 $luri =~ s/\s+$//; # Strip trailing whitespace
1902 my ( $val, $msg ) = $Record->AddLink(
1906 push @results, $msg;
1909 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
1910 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
1911 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
1913 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
1915 my ( $val, $msg ) = $Record->AddLink(
1920 push @results, $msg;
1928 =head2 _UploadedFile ( $arg );
1930 Takes a CGI parameter name; if a file is uploaded under that name,
1931 return a hash reference suitable for AddCustomFieldValue's use:
1932 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
1934 Returns C<undef> if no files were uploaded in the C<$arg> field.
1940 my $cgi_object = $m->cgi_object;
1941 my $fh = $cgi_object->upload($arg) or return undef;
1942 my $upload_info = $cgi_object->uploadInfo($fh);
1944 my $filename = "$fh";
1945 $filename =~ s#^.*[\\/]##;
1950 LargeContent => do { local $/; scalar <$fh> },
1951 ContentType => $upload_info->{'Content-Type'},
1955 sub GetColumnMapEntry {
1956 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
1958 # deal with the simplest thing first
1959 if ( $args{'Map'}{ $args{'Name'} } ) {
1960 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
1964 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
1965 return undef unless $args{'Map'}->{$mainkey};
1966 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
1967 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
1969 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
1974 sub ProcessColumnMapValue {
1976 my %args = ( Arguments => [], Escape => 1, @_ );
1979 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
1980 my @tmp = $value->( @{ $args{'Arguments'} } );
1981 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
1982 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
1983 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
1984 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
1989 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
1993 =head2 _load_container_object ( $type, $id );
1995 Instantiate container object for saving searches.
1999 sub _load_container_object {
2000 my ( $obj_type, $obj_id ) = @_;
2001 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2004 =head2 _parse_saved_search ( $arg );
2006 Given a serialization string for saved search, and returns the
2007 container object and the search id.
2011 sub _parse_saved_search {
2013 return unless $spec;
2014 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2021 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2024 eval "require RT::Interface::Web_Vendor";
2025 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2026 eval "require RT::Interface::Web_Local";
2027 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );