Master to 4.2.8
[usit-rt.git] / lib / RT / Interface / Web.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
6 #                                          <sales@bestpractical.com>
7 #
8 # (Except where explicitly superseded by other copyright notices)
9 #
10 #
11 # LICENSE:
12 #
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
16 # from www.gnu.org.
17 #
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.
22 #
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.
28 #
29 #
30 # CONTRIBUTION SUBMISSION POLICY:
31 #
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.)
37 #
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.
46 #
47 # END BPS TAGGED BLOCK }}}
48
49 ## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
50
51 ## This is a library of static subs to be used by the Mason web
52 ## interface to RT
53
54 =head1 NAME
55
56 RT::Interface::Web
57
58
59 =cut
60
61 use strict;
62 use warnings;
63
64 package RT::Interface::Web;
65
66 use RT::SavedSearches;
67 use URI qw();
68 use RT::Interface::Web::Menu;
69 use RT::Interface::Web::Session;
70 use Digest::MD5 ();
71 use List::MoreUtils qw();
72 use JSON qw();
73 use Plack::Util;
74
75 =head2 SquishedCSS $style
76
77 =cut
78
79 my %SQUISHED_CSS;
80 sub SquishedCSS {
81     my $style = shift or die "need name";
82     return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
83     require RT::Squish::CSS;
84     my $css = RT::Squish::CSS->new( Style => $style );
85     $SQUISHED_CSS{ $css->Style } = $css;
86     return $css;
87 }
88
89 =head2 SquishedJS
90
91 =cut
92
93 my $SQUISHED_JS;
94 sub SquishedJS {
95     return $SQUISHED_JS if $SQUISHED_JS;
96
97     require RT::Squish::JS;
98     my $js = RT::Squish::JS->new();
99     $SQUISHED_JS = $js;
100     return $js;
101 }
102
103 =head2 JSFiles
104
105 =cut
106
107 sub JSFiles {
108     return qw{
109       jquery-1.9.1.min.js
110       jquery_noconflict.js
111       jquery-ui-1.10.0.custom.min.js
112       jquery-ui-timepicker-addon.js
113       jquery-ui-patch-datepicker.js
114       jquery.modal.min.js
115       jquery.modal-defaults.js
116       jquery.cookie.js
117       titlebox-state.js
118       i18n.js
119       util.js
120       autocomplete.js
121       jquery.event.hover-1.0.js
122       superfish.js
123       supersubs.js
124       jquery.supposition.js
125       history-folding.js
126       cascaded.js
127       forms.js
128       event-registration.js
129       late.js
130       /static/RichText/ckeditor.js
131       }, RT->Config->Get('JSFiles');
132 }
133
134 =head2 ClearSquished
135
136 Removes the cached CSS and JS entries, forcing them to be regenerated
137 on next use.
138
139 =cut
140
141 sub ClearSquished {
142     undef $SQUISHED_JS;
143     %SQUISHED_CSS = ();
144 }
145
146 =head2 EscapeHTML SCALARREF
147
148 does a css-busting but minimalist escaping of whatever html you're passing in.
149
150 =cut
151
152 sub EscapeHTML {
153     my $ref = shift;
154     return unless defined $$ref;
155
156     $$ref =~ s/&/&#38;/g;
157     $$ref =~ s/</&lt;/g;
158     $$ref =~ s/>/&gt;/g;
159     $$ref =~ s/\(/&#40;/g;
160     $$ref =~ s/\)/&#41;/g;
161     $$ref =~ s/"/&#34;/g;
162     $$ref =~ s/'/&#39;/g;
163 }
164
165 # Back-compat
166 # XXX: Remove in 4.4
167 sub EscapeUTF8 {
168     RT->Deprecated(
169         Instead => "EscapeHTML",
170         Remove => "4.4",
171     );
172     EscapeHTML(@_);
173 }
174
175 =head2 EscapeURI SCALARREF
176
177 Escapes URI component according to RFC2396
178
179 =cut
180
181 sub EscapeURI {
182     my $ref = shift;
183     return unless defined $$ref;
184
185     use bytes;
186     $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
187 }
188
189 =head2 EncodeJSON SCALAR
190
191 Encodes the SCALAR to JSON and returns a JSON Unicode (B<not> UTF-8) string.
192 SCALAR may be a simple value or a reference.
193
194 =cut
195
196 sub EncodeJSON {
197     my $s = JSON::to_json(shift, { allow_nonref => 1 });
198     $s =~ s{/}{\\/}g;
199     return $s;
200 }
201
202 sub _encode_surrogates {
203     my $uni = $_[0] - 0x10000;
204     return ($uni /  0x400 + 0xD800, $uni % 0x400 + 0xDC00);
205 }
206
207 sub EscapeJS {
208     my $ref = shift;
209     return unless defined $$ref;
210
211     $$ref = "'" . join('',
212                  map {
213                      chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
214                      $_  <= 255   ? sprintf("\\x%02X", $_) :
215                      $_  <= 65535 ? sprintf("\\u%04X", $_) :
216                      sprintf("\\u%X\\u%X", _encode_surrogates($_))
217                  } unpack('U*', $$ref))
218         . "'";
219 }
220
221 =head2 WebCanonicalizeInfo();
222
223 Different web servers set different environmental varibles. This
224 function must return something suitable for REMOTE_USER. By default,
225 just downcase $ENV{'REMOTE_USER'}
226
227 =cut
228
229 sub WebCanonicalizeInfo {
230     return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
231 }
232
233
234
235 =head2 WebRemoteUserAutocreateInfo($user);
236
237 Returns a hash of user attributes, used when WebRemoteUserAutocreate is set.
238
239 =cut
240
241 sub WebRemoteUserAutocreateInfo {
242     my $user = shift;
243
244     my %user_info;
245
246     # default to making Privileged users, even if they specify
247     # some other default Attributes
248     if ( !$RT::UserAutocreateDefaultsOnLogin
249         || ( ref($RT::UserAutocreateDefaultsOnLogin) && not exists $RT::UserAutocreateDefaultsOnLogin->{Privileged} ) )
250     {
251         $user_info{'Privileged'} = 1;
252     }
253
254     # Populate fields with information from Unix /etc/passwd
255     my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
256     $user_info{'Comments'} = $comments if defined $comments;
257     $user_info{'RealName'} = $realname if defined $realname;
258
259     # and return the wad of stuff
260     return {%user_info};
261 }
262
263
264 sub HandleRequest {
265     my $ARGS = shift;
266
267     if (RT->Config->Get('DevelMode')) {
268         require Module::Refresh;
269         Module::Refresh->refresh;
270     }
271
272     $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
273
274     $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
275
276     # Roll back any dangling transactions from a previous failed connection
277     $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
278
279     MaybeEnableSQLStatementLog();
280
281     # avoid reentrancy, as suggested by masonbook
282     local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
283
284     $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
285         if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
286
287     ValidateWebConfig();
288
289     DecodeARGS($ARGS);
290     local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
291     PreprocessTimeUpdates($ARGS);
292
293     InitializeMenu();
294     MaybeShowInstallModePage();
295
296     $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
297     SendSessionCookie();
298
299     if ( _UserLoggedIn() ) {
300         # make user info up to date
301         $HTML::Mason::Commands::session{'CurrentUser'}
302           ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
303         undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
304     }
305     else {
306         $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
307     }
308
309     # Process session-related callbacks before any auth attempts
310     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
311
312     MaybeRejectPrivateComponentRequest();
313
314     MaybeShowNoAuthPage($ARGS);
315
316     AttemptExternalAuth($ARGS) if RT->Config->Get('WebRemoteUserContinuous') or not _UserLoggedIn();
317
318     _ForceLogout() unless _UserLoggedIn();
319
320     # Process per-page authentication callbacks
321     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
322
323     if ( $ARGS->{'NotMobile'} ) {
324         $HTML::Mason::Commands::session{'NotMobile'} = 1;
325     }
326
327     unless ( _UserLoggedIn() ) {
328         _ForceLogout();
329
330         # Authenticate if the user is trying to login via user/pass query args
331         my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
332
333         unless ($authed) {
334             my $m = $HTML::Mason::Commands::m;
335
336             # REST urls get a special 401 response
337             if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
338                 $HTML::Mason::Commands::r->content_type("text/plain; charset=utf-8");
339                 $m->error_format("text");
340                 $m->out("RT/$RT::VERSION 401 Credentials required\n");
341                 $m->out("\n$msg\n") if $msg;
342                 $m->abort;
343             }
344             # Specially handle /index.html and /m/index.html so that we get a nicer URL
345             elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
346                 my $mobile = $1 ? 1 : 0;
347                 my $next   = SetNextPage($ARGS);
348                 $m->comp('/NoAuth/Login.html',
349                     next    => $next,
350                     actions => [$msg],
351                     mobile  => $mobile);
352                 $m->abort;
353             }
354             else {
355                 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
356             }
357         }
358     }
359
360     MaybeShowInterstitialCSRFPage($ARGS);
361
362     # now it applies not only to home page, but any dashboard that can be used as a workspace
363     $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
364         if ( $ARGS->{'HomeRefreshInterval'} );
365
366     # Process per-page global callbacks
367     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
368
369     ShowRequestedPage($ARGS);
370     LogRecordedSQLStatements(RequestData => {
371         Path => $HTML::Mason::Commands::m->request_path,
372     });
373
374     # Process per-page final cleanup callbacks
375     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
376
377     $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS );
378 }
379
380 sub _ForceLogout {
381
382     delete $HTML::Mason::Commands::session{'CurrentUser'};
383 }
384
385 sub _UserLoggedIn {
386     if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
387         return 1;
388     } else {
389         return undef;
390     }
391
392 }
393
394 =head2 LoginError ERROR
395
396 Pushes a login error into the Actions session store and returns the hash key.
397
398 =cut
399
400 sub LoginError {
401     my $new = shift;
402     my $key = Digest::MD5::md5_hex( rand(1024) );
403     push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
404     $HTML::Mason::Commands::session{'i'}++;
405     return $key;
406 }
407
408 =head2 SetNextPage ARGSRef [PATH]
409
410 Intuits and stashes the next page in the sesssion hash.  If PATH is
411 specified, uses that instead of the value of L<IntuitNextPage()>.  Returns
412 the hash value.
413
414 =cut
415
416 sub SetNextPage {
417     my $ARGS = shift;
418     my $next = $_[0] ? $_[0] : IntuitNextPage();
419     my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
420     my $page = { url => $next };
421
422     # If an explicit URL was passed and we didn't IntuitNextPage, then
423     # IsPossibleCSRF below is almost certainly unrelated to the actual
424     # destination.  Currently explicit next pages aren't used in RT, but the
425     # API is available.
426     if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
427         # This isn't really CSRF, but the CSRF heuristics are useful for catching
428         # requests which may have unintended side-effects.
429         my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
430         if ($is_csrf) {
431             RT->Logger->notice(
432                 "Marking original destination as having side-effects before redirecting for login.\n"
433                ."Request: $next\n"
434                ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
435             );
436             $page->{'HasSideEffects'} = [$msg, @loc];
437         }
438     }
439
440     $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
441     $HTML::Mason::Commands::session{'i'}++;
442     return $hash;
443 }
444
445 =head2 FetchNextPage HASHKEY
446
447 Returns the stashed next page hashref for the given hash.
448
449 =cut
450
451 sub FetchNextPage {
452     my $hash = shift || "";
453     return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
454 }
455
456 =head2 RemoveNextPage HASHKEY
457
458 Removes the stashed next page for the given hash and returns it.
459
460 =cut
461
462 sub RemoveNextPage {
463     my $hash = shift || "";
464     return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
465 }
466
467 =head2 TangentForLogin ARGSRef [HASH]
468
469 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
470 the next page.  Takes a hashref of request %ARGS as the first parameter.
471 Optionally takes all other parameters as a hash which is dumped into query
472 params.
473
474 =cut
475
476 sub TangentForLogin {
477     my $login = TangentForLoginURL(@_);
478     Redirect( RT->Config->Get('WebBaseURL') . $login );
479 }
480
481 =head2 TangentForLoginURL [HASH]
482
483 Returns a URL suitable for tangenting for login.  Optionally takes a hash which
484 is dumped into query params.
485
486 =cut
487
488 sub TangentForLoginURL {
489     my $ARGS  = shift;
490     my $hash  = SetNextPage($ARGS);
491     my %query = (@_, next => $hash);
492
493     $query{mobile} = 1
494         if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
495
496     my $login = RT->Config->Get('WebPath') . '/NoAuth/Login.html?';
497     $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
498     return $login;
499 }
500
501 =head2 TangentForLoginWithError ERROR
502
503 Localizes the passed error message, stashes it with L<LoginError> and then
504 calls L<TangentForLogin> with the appropriate results key.
505
506 =cut
507
508 sub TangentForLoginWithError {
509     my $ARGS = shift;
510     my $key  = LoginError(HTML::Mason::Commands::loc(@_));
511     TangentForLogin( $ARGS, results => $key );
512 }
513
514 =head2 IntuitNextPage
515
516 Attempt to figure out the path to which we should return the user after a
517 tangent.  The current request URL is used, or failing that, the C<WebURL>
518 configuration variable.
519
520 =cut
521
522 sub IntuitNextPage {
523     my $req_uri;
524
525     # This includes any query parameters.  Redirect will take care of making
526     # it an absolute URL.
527     if ($ENV{'REQUEST_URI'}) {
528         $req_uri = $ENV{'REQUEST_URI'};
529
530         # collapse multiple leading slashes so the first part doesn't look like
531         # a hostname of a schema-less URI
532         $req_uri =~ s{^/+}{/};
533     }
534
535     my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
536
537     # sanitize $next
538     my $uri = URI->new($next);
539
540     # You get undef scheme with a relative uri like "/Search/Build.html"
541     unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
542         $next = RT->Config->Get('WebURL');
543     }
544
545     # Make sure we're logging in to the same domain
546     # You can get an undef authority with a relative uri like "index.html"
547     my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
548     unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
549         $next = RT->Config->Get('WebURL');
550     }
551
552     return $next;
553 }
554
555 =head2 MaybeShowInstallModePage 
556
557 This function, called exclusively by RT's autohandler, dispatches
558 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
559
560 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
561
562 =cut 
563
564 sub MaybeShowInstallModePage {
565     return unless RT->InstallMode;
566
567     my $m = $HTML::Mason::Commands::m;
568     if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
569         $m->call_next();
570     } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
571         RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
572     } else {
573         $m->call_next();
574     }
575     $m->abort();
576 }
577
578 =head2 MaybeShowNoAuthPage  \%ARGS
579
580 This function, called exclusively by RT's autohandler, dispatches
581 a request to the page a user requested (but only if it matches the "noauth" regex.
582
583 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
584
585 =cut 
586
587 sub MaybeShowNoAuthPage {
588     my $ARGS = shift;
589
590     my $m = $HTML::Mason::Commands::m;
591
592     return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
593
594     # Don't show the login page to logged in users
595     Redirect(RT->Config->Get('WebURL'))
596         if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
597
598     # If it's a noauth file, don't ask for auth.
599     $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
600     $m->abort;
601 }
602
603 =head2 MaybeRejectPrivateComponentRequest
604
605 This function will reject calls to private components, like those under
606 C</Elements>. If the requested path is a private component then we will
607 abort with a C<403> error.
608
609 =cut
610
611 sub MaybeRejectPrivateComponentRequest {
612     my $m = $HTML::Mason::Commands::m;
613     my $path = $m->request_comp->path;
614
615     # We do not check for dhandler here, because requesting our dhandlers
616     # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
617     # 'dhandler'.
618
619     if ($path =~ m{
620             / # leading slash
621             ( Elements    |
622               _elements   | # mobile UI
623               Callbacks   |
624               Widgets     |
625               autohandler | # requesting this directly is suspicious
626               l (_unsafe)? ) # loc component
627             ( $ | / ) # trailing slash or end of path
628         }xi) {
629             $m->abort(403);
630     }
631
632     return;
633 }
634
635 sub InitializeMenu {
636     $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
637     $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
638     $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
639
640 }
641
642
643 =head2 ShowRequestedPage  \%ARGS
644
645 This function, called exclusively by RT's autohandler, dispatches
646 a request to the page a user requested (making sure that unpriviled users
647 can only see self-service pages.
648
649 =cut 
650
651 sub ShowRequestedPage {
652     my $ARGS = shift;
653
654     my $m = $HTML::Mason::Commands::m;
655
656     # Ensure that the cookie that we send is up-to-date, in case the
657     # session-id has been modified in any way
658     SendSessionCookie();
659
660     # precache all system level rights for the current user
661     $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
662
663     # If the user isn't privileged, they can only see SelfService
664     unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
665
666         # if the user is trying to access a ticket, redirect them
667         if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
668             RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
669         }
670
671         # otherwise, drop the user at the SelfService default page
672         elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
673             RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
674         }
675
676         # if user is in SelfService dir let him do anything
677         else {
678             $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
679         }
680     } else {
681         $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
682     }
683
684 }
685
686 sub AttemptExternalAuth {
687     my $ARGS = shift;
688
689     return unless ( RT->Config->Get('WebRemoteUserAuth') );
690
691     my $user = $ARGS->{user};
692     my $m    = $HTML::Mason::Commands::m;
693
694     my $logged_in_external_user = _UserLoggedIn() && $HTML::Mason::Commands::session{'WebExternallyAuthed'};
695
696     # If RT is configured for external auth, let's go through and get REMOTE_USER
697
698     # Do we actually have a REMOTE_USER or equivalent?  We only check auth if
699     # 1) we have no logged in user, or 2) we have a user who is externally
700     # authed.  If we have a logged in user who is internally authed, don't
701     # check remote user otherwise we may log them out.
702     if (RT::Interface::Web::WebCanonicalizeInfo()
703         and (not _UserLoggedIn() or $logged_in_external_user) )
704     {
705         $user = RT::Interface::Web::WebCanonicalizeInfo();
706         my $load_method = RT->Config->Get('WebRemoteUserGecos') ? 'LoadByGecos' : 'Load';
707
708         my $next = RemoveNextPage($ARGS->{'next'});
709            $next = $next->{'url'} if ref $next;
710         InstantiateNewSession() unless _UserLoggedIn;
711         $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
712         $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
713
714         if ( RT->Config->Get('WebRemoteUserAutocreate') and not _UserLoggedIn() ) {
715
716             # Create users on-the-fly
717             my $UserObj = RT::User->new(RT->SystemUser);
718             my ( $val, $msg ) = $UserObj->Create(
719                 %{ ref RT->Config->Get('UserAutocreateDefaultsOnLogin') ? RT->Config->Get('UserAutocreateDefaultsOnLogin') : {} },
720                 Name  => $user,
721                 Gecos => $user,
722             );
723
724             if ($val) {
725
726                 # now get user specific information, to better create our user.
727                 my $new_user_info = RT::Interface::Web::WebRemoteUserAutocreateInfo($user);
728
729                 # set the attributes that have been defined.
730                 foreach my $attribute ( $UserObj->WritableAttributes, qw(Privileged Disabled) ) {
731                     $m->callback(
732                         Attribute    => $attribute,
733                         User         => $user,
734                         UserInfo     => $new_user_info,
735                         CallbackName => 'NewUser',
736                         CallbackPage => '/autohandler'
737                     );
738                     my $method = "Set$attribute";
739                     $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
740                 }
741                 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
742             } else {
743                 RT->Logger->error("Couldn't auto-create user '$user' when attempting WebRemoteUser: $msg");
744                 AbortExternalAuth( Error => "UserAutocreateDefaultsOnLogin" );
745             }
746         }
747
748         if ( _UserLoggedIn() ) {
749             $HTML::Mason::Commands::session{'WebExternallyAuthed'} = 1;
750             $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
751             # It is possible that we did a redirect to the login page,
752             # if the external auth allows lack of auth through with no
753             # REMOTE_USER set, instead of forcing a "permission
754             # denied" message.  Honor the $next.
755             Redirect($next) if $next;
756             # Unlike AttemptPasswordAuthentication below, we do not
757             # force a redirect to / if $next is not set -- otherwise,
758             # straight-up external auth would always redirect to /
759             # when you first hit it.
760         } else {
761             # Couldn't auth with the REMOTE_USER provided because an RT
762             # user doesn't exist and we're configured not to create one.
763             RT->Logger->error("Couldn't find internal user for '$user' when attempting WebRemoteUser and RT is not configured for auto-creation. Refer to `perldoc $RT::BasePath/docs/authentication.pod` if you want to allow auto-creation.");
764             AbortExternalAuth(
765                 Error => "NoInternalUser",
766                 User  => $user,
767             );
768         }
769     }
770     elsif ($logged_in_external_user) {
771         # The logged in external user was deauthed by the auth system and we
772         # should kick them out.
773         AbortExternalAuth( Error => "Deauthorized" );
774     }
775     elsif (not RT->Config->Get('WebFallbackToRTLogin')) {
776         # Abort if we don't want to fallback internally
777         AbortExternalAuth( Error => "NoRemoteUser" );
778     }
779 }
780
781 sub AbortExternalAuth {
782     my %args  = @_;
783     my $error = $args{Error} ? "/Errors/WebRemoteUser/$args{Error}" : undef;
784     my $m     = $HTML::Mason::Commands::m;
785     my $r     = $HTML::Mason::Commands::r;
786
787     _ForceLogout();
788
789     # Clear the decks, not that we should have partial content.
790     $m->clear_buffer;
791
792     $r->status(403);
793     $m->comp($error, %args)
794         if $error and $m->comp_exists($error);
795
796     # Return a 403 Forbidden or we may fallback to a login page with no form
797     $m->abort(403);
798 }
799
800 sub AttemptPasswordAuthentication {
801     my $ARGS = shift;
802     return unless defined $ARGS->{user} && defined $ARGS->{pass};
803
804     my $user_obj = RT::CurrentUser->new();
805     $user_obj->Load( $ARGS->{user} );
806
807     my $m = $HTML::Mason::Commands::m;
808
809     unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
810         $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
811         $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
812         return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
813     }
814     else {
815         $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
816
817         # It's important to nab the next page from the session before we blow
818         # the session away
819         my $next = RemoveNextPage($ARGS->{'next'});
820            $next = $next->{'url'} if ref $next;
821
822         InstantiateNewSession();
823         $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
824
825         $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler', RedirectTo => \$next );
826
827         # Really the only time we don't want to redirect here is if we were
828         # passed user and pass as query params in the URL.
829         if ($next) {
830             Redirect($next);
831         }
832         elsif ($ARGS->{'next'}) {
833             # Invalid hash, but still wants to go somewhere, take them to /
834             Redirect(RT->Config->Get('WebURL'));
835         }
836
837         return (1, HTML::Mason::Commands::loc('Logged in'));
838     }
839 }
840
841 =head2 LoadSessionFromCookie
842
843 Load or setup a session cookie for the current user.
844
845 =cut
846
847 sub _SessionCookieName {
848     my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
849     $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
850     return $cookiename;
851 }
852
853 sub LoadSessionFromCookie {
854
855     my %cookies       = CGI::Cookie->fetch;
856     my $cookiename    = _SessionCookieName();
857     my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
858     tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
859     unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
860         InstantiateNewSession();
861     }
862     if ( int RT->Config->Get('AutoLogoff') ) {
863         my $now = int( time / 60 );
864         my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
865
866         if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
867             InstantiateNewSession();
868         }
869
870         # save session on each request when AutoLogoff is turned on
871         $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
872     }
873 }
874
875 sub InstantiateNewSession {
876     tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
877     tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
878     SendSessionCookie();
879 }
880
881 sub SendSessionCookie {
882     my $cookie = CGI::Cookie->new(
883         -name     => _SessionCookieName(),
884         -value    => $HTML::Mason::Commands::session{_session_id},
885         -path     => RT->Config->Get('WebPath'),
886         -secure   => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
887         -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
888     );
889
890     $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
891 }
892
893 =head2 GetWebURLFromRequest
894
895 People may use different web urls instead of C<$WebURL> in config.
896 Return the web url current user is using.
897
898 =cut
899
900 sub GetWebURLFromRequest {
901
902     my $uri = URI->new( RT->Config->Get('WebURL') );
903
904     if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
905         $uri->scheme('https');
906     }
907     else {
908         $uri->scheme('http');
909     }
910
911     # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
912     $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'} );
913     $uri->port( $ENV{'SERVER_PORT'} );
914     return "$uri"; # stringify to be consistent with WebURL in config
915 }
916
917 =head2 Redirect URL
918
919 This routine ells the current user's browser to redirect to URL.  
920 Additionally, it unties the user's currently active session, helping to avoid 
921 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use 
922 a cached DBI statement handle twice at the same time.
923
924 =cut
925
926 sub Redirect {
927     my $redir_to = shift;
928     untie $HTML::Mason::Commands::session;
929     my $uri        = URI->new($redir_to);
930     my $server_uri = URI->new( RT->Config->Get('WebURL') );
931     
932     # Make relative URIs absolute from the server host and scheme
933     $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
934     if (not defined $uri->host) {
935         $uri->host($server_uri->host);
936         $uri->port($server_uri->port);
937     }
938
939     # If the user is coming in via a non-canonical
940     # hostname, don't redirect them to the canonical host,
941     # it will just upset them (and invalidate their credentials)
942     # don't do this if $RT::CanonicalizeRedirectURLs is true
943     if (   !RT->Config->Get('CanonicalizeRedirectURLs')
944         && $uri->host eq $server_uri->host
945         && $uri->port eq $server_uri->port )
946     {
947         my $env_uri = URI->new(GetWebURLFromRequest());
948         $uri->scheme($env_uri->scheme);
949         $uri->host($env_uri->host);
950         $uri->port($env_uri->port);
951     }
952
953     # not sure why, but on some systems without this call mason doesn't
954     # set status to 302, but 200 instead and people see blank pages
955     $HTML::Mason::Commands::r->status(302);
956
957     # Perlbal expects a status message, but Mason's default redirect status
958     # doesn't provide one. See also rt.cpan.org #36689.
959     $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
960
961     $HTML::Mason::Commands::m->abort;
962 }
963
964 =head2 GetStaticHeaders
965
966 return an arrayref of Headers (currently, Cache-Control and Expires).
967
968 =cut
969
970 sub GetStaticHeaders {
971     my %args = @_;
972
973     my $Visibility = 'private';
974     if ( ! defined $args{Time} ) {
975         $args{Time} = 0;
976     } elsif ( $args{Time} eq 'no-cache' ) {
977         $args{Time} = 0;
978     } elsif ( $args{Time} eq 'forever' ) {
979         $args{Time} = 30 * 24 * 60 * 60;
980         $Visibility = 'public';
981     }
982
983     my $CacheControl = $args{Time}
984         ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
985         : 'no-cache'
986     ;
987
988     my $expires = RT::Date->new(RT->SystemUser);
989     $expires->SetToNow;
990     $expires->AddSeconds( $args{Time} ) if $args{Time};
991
992     return [
993         Expires => $expires->RFC2616,
994         'Cache-Control' => $CacheControl,
995     ];
996 }
997
998 =head2 CacheControlExpiresHeaders
999
1000 set both Cache-Control and Expires http headers
1001
1002 =cut
1003
1004 sub CacheControlExpiresHeaders {
1005     Plack::Util::header_iter( GetStaticHeaders(@_), sub {
1006         my ( $key, $val ) = @_;
1007         $HTML::Mason::Commands::r->headers_out->{$key} = $val;
1008     } );
1009 }
1010
1011 =head2 StaticFileHeaders 
1012
1013 Send the browser a few headers to try to get it to (somewhat agressively)
1014 cache RT's static Javascript and CSS files.
1015
1016 This routine could really use _accurate_ heuristics. (XXX TODO)
1017
1018 =cut
1019
1020 sub StaticFileHeaders {
1021     # remove any cookie headers -- if it is cached publicly, it
1022     # shouldn't include anyone's cookie!
1023     delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
1024
1025     # Expire things in a month.
1026     CacheControlExpiresHeaders( Time => 'forever' );
1027 }
1028
1029 =head2 ComponentPathIsSafe PATH
1030
1031 Takes C<PATH> and returns a boolean indicating that the user-specified partial
1032 component path is safe.
1033
1034 Currently "safe" means that the path does not start with a dot (C<.>), does
1035 not contain a slash-dot C</.>, and does not contain any nulls.
1036
1037 =cut
1038
1039 sub ComponentPathIsSafe {
1040     my $self = shift;
1041     my $path = shift;
1042     return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
1043 }
1044
1045 =head2 PathIsSafe
1046
1047 Takes a C<< Path => path >> and returns a boolean indicating that
1048 the path is safely within RT's control or not. The path I<must> be
1049 relative.
1050
1051 This function does not consult the filesystem at all; it is merely
1052 a logical sanity checking of the path. This explicitly does not handle
1053 symlinks; if you have symlinks in RT's webroot pointing outside of it,
1054 then we assume you know what you are doing.
1055
1056 =cut
1057
1058 sub PathIsSafe {
1059     my $self = shift;
1060     my %args = @_;
1061     my $path = $args{Path};
1062
1063     # Get File::Spec to clean up extra /s, ./, etc
1064     my $cleaned_up = File::Spec->canonpath($path);
1065
1066     if (!defined($cleaned_up)) {
1067         $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
1068         return 0;
1069     }
1070
1071     # Forbid too many ..s. We can't just sum then check because
1072     # "../foo/bar/baz" should be illegal even though it has more
1073     # downdirs than updirs. So as soon as we get a negative score
1074     # (which means "breaking out" of the top level) we reject the path.
1075
1076     my @components = split '/', $cleaned_up;
1077     my $score = 0;
1078     for my $component (@components) {
1079         if ($component eq '..') {
1080             $score--;
1081             if ($score < 0) {
1082                 $RT::Logger->info("Rejecting unsafe path: $path");
1083                 return 0;
1084             }
1085         }
1086         elsif ($component eq '.' || $component eq '') {
1087             # these two have no effect on $score
1088         }
1089         else {
1090             $score++;
1091         }
1092     }
1093
1094     return 1;
1095 }
1096
1097 =head2 SendStaticFile 
1098
1099 Takes a File => path and a Type => Content-type
1100
1101 If Type isn't provided and File is an image, it will
1102 figure out a sane Content-type, otherwise it will
1103 send application/octet-stream
1104
1105 Will set caching headers using StaticFileHeaders
1106
1107 =cut
1108
1109 sub SendStaticFile {
1110     my $self = shift;
1111     my %args = @_;
1112     my $file = $args{File};
1113     my $type = $args{Type};
1114     my $relfile = $args{RelativeFile};
1115
1116     if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
1117         $HTML::Mason::Commands::r->status(400);
1118         $HTML::Mason::Commands::m->abort;
1119     }
1120
1121     $self->StaticFileHeaders();
1122
1123     unless ($type) {
1124         if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1125             $type = "image/$1";
1126             $type =~ s/jpg/jpeg/gi;
1127         }
1128         $type ||= "application/octet-stream";
1129     }
1130     $HTML::Mason::Commands::r->content_type($type);
1131     open( my $fh, '<', $file ) or die "couldn't open file: $!";
1132     binmode($fh);
1133     {
1134         local $/ = \16384;
1135         $HTML::Mason::Commands::m->out($_) while (<$fh>);
1136         $HTML::Mason::Commands::m->flush_buffer;
1137     }
1138     close $fh;
1139 }
1140
1141
1142
1143 sub MobileClient {
1144     my $self = shift;
1145
1146
1147 if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'})  {
1148     return 1;
1149 } else {
1150     return undef;
1151 }
1152
1153 }
1154
1155
1156 sub StripContent {
1157     my %args    = @_;
1158     my $content = $args{Content};
1159     return '' unless $content;
1160
1161     # Make the content have no 'weird' newlines in it
1162     $content =~ s/\r+\n/\n/g;
1163
1164     my $return_content = $content;
1165
1166     my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1167     my $sigonly = $args{StripSignature};
1168
1169     # massage content to easily detect if there's any real content
1170     $content =~ s/\s+//g; # yes! remove all the spaces
1171     if ( $html ) {
1172         # remove html version of spaces and newlines
1173         $content =~ s!&nbsp;!!g;
1174         $content =~ s!<br/?>!!g;
1175     }
1176
1177     # Filter empty content when type is text/html
1178     return '' if $html && $content !~ /\S/;
1179
1180     # If we aren't supposed to strip the sig, just bail now.
1181     return $return_content unless $sigonly;
1182
1183     # Find the signature
1184     my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1185     $sig =~ s/\s+//g;
1186
1187     # Check for plaintext sig
1188     return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1189
1190     # Check for html-formatted sig; we don't use EscapeHTML here
1191     # because we want to precisely match the escapting that FCKEditor
1192     # uses.
1193     $sig =~ s/&/&amp;/g;
1194     $sig =~ s/</&lt;/g;
1195     $sig =~ s/>/&gt;/g;
1196     $sig =~ s/"/&quot;/g;
1197     $sig =~ s/'/&#39;/g;
1198     return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1199
1200     # Pass it through
1201     return $return_content;
1202 }
1203
1204 sub DecodeARGS {
1205     my $ARGS = shift;
1206
1207     # Later in the code we use
1208     # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1209     # instead of $m->call_next to avoid problems with UTF8 keys in
1210     # arguments.  Specifically, the call_next method pass through
1211     # original arguments, which are still the encoded bytes, not
1212     # characters.  "{ base_comp => $m->request_comp }" is copied from
1213     # mason's source to get the same results as we get from call_next
1214     # method; this feature is not documented.
1215     %{$ARGS} = map {
1216
1217         # if they've passed multiple values, they'll be an array. if they've
1218         # passed just one, a scalar whatever they are, mark them as utf8
1219         my $type = ref($_);
1220         ( !$type )
1221             ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ )
1222             : ( $type eq 'ARRAY' )
1223             ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ]
1224             : ( $type eq 'HASH' )
1225             ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ }
1226             : $_
1227     } %$ARGS;
1228 }
1229
1230 sub PreprocessTimeUpdates {
1231     my $ARGS = shift;
1232
1233     # This code canonicalizes time inputs in hours into minutes
1234     foreach my $field ( keys %$ARGS ) {
1235         next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1236         my $local = $1;
1237         $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1238                       {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1239         if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1240             $ARGS->{$local} *= 60;
1241         }
1242         delete $ARGS->{$field};
1243     }
1244
1245 }
1246
1247 sub MaybeEnableSQLStatementLog {
1248
1249     my $log_sql_statements = RT->Config->Get('StatementLog');
1250
1251     if ($log_sql_statements) {
1252         $RT::Handle->ClearSQLStatementLog;
1253         $RT::Handle->LogSQLStatements(1);
1254     }
1255
1256 }
1257
1258 sub LogRecordedSQLStatements {
1259     my %args = @_;
1260
1261     my $log_sql_statements = RT->Config->Get('StatementLog');
1262
1263     return unless ($log_sql_statements);
1264
1265     my @log = $RT::Handle->SQLStatementLog;
1266     $RT::Handle->ClearSQLStatementLog;
1267
1268     $RT::Handle->AddRequestToHistory({
1269         %{ $args{RequestData} },
1270         Queries => \@log,
1271     });
1272
1273     for my $stmt (@log) {
1274         my ( $time, $sql, $bind, $duration ) = @{$stmt};
1275         my @bind;
1276         if ( ref $bind ) {
1277             @bind = @{$bind};
1278         } else {
1279
1280             # Older DBIx-SB
1281             $duration = $bind;
1282         }
1283         $RT::Logger->log(
1284             level   => $log_sql_statements,
1285             message => "SQL("
1286                 . sprintf( "%.6f", $duration )
1287                 . "s): $sql;"
1288                 . ( @bind ? "  [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1289         );
1290     }
1291
1292 }
1293
1294 my $_has_validated_web_config = 0;
1295 sub ValidateWebConfig {
1296     my $self = shift;
1297
1298     # do this once per server instance, not once per request
1299     return if $_has_validated_web_config;
1300     $_has_validated_web_config = 1;
1301
1302     my $port = $ENV{SERVER_PORT};
1303     my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
1304             || $ENV{HTTP_HOST}             || $ENV{SERVER_NAME};
1305     ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
1306
1307     if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
1308         $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort).  "
1309                          ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
1310                          ."otherwise your internal links may be broken.");
1311     }
1312
1313     if ( $host ne RT->Config->Get('WebDomain') ) {
1314         $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain).  "
1315                          ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
1316                          ."otherwise your internal links may be broken.");
1317     }
1318
1319     # Unfortunately, there is no reliable way to get the _path_ that was
1320     # requested at the proxy level; simply disable this warning if we're
1321     # proxied and there's a mismatch.
1322     my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
1323     if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
1324         $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath).  "
1325                          ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
1326                          ."otherwise your internal links may be broken.");
1327     }
1328 }
1329
1330 sub ComponentRoots {
1331     my $self = shift;
1332     my %args = ( Names => 0, @_ );
1333     my @roots;
1334     if (defined $HTML::Mason::Commands::m) {
1335         @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1336     } else {
1337         @roots = (
1338             [ local    => $RT::MasonLocalComponentRoot ],
1339             (map {[ "plugin-".$_->Name =>  $_->ComponentRoot ]} @{RT->Plugins}),
1340             [ standard => $RT::MasonComponentRoot ]
1341         );
1342     }
1343     @roots = map { $_->[1] } @roots unless $args{Names};
1344     return @roots;
1345 }
1346
1347 sub StaticRoots {
1348     my $self   = shift;
1349     my @static = (
1350         $RT::LocalStaticPath,
1351         (map { $_->StaticDir } @{RT->Plugins}),
1352         $RT::StaticPath,
1353     );
1354     return grep { $_ and -d $_ } @static;
1355 }
1356
1357 our %is_whitelisted_component = (
1358     # The RSS feed embeds an auth token in the path, but query
1359     # information for the search.  Because it's a straight-up read, in
1360     # addition to embedding its own auth, it's fine.
1361     '/NoAuth/rss/dhandler' => 1,
1362
1363     # While these can be used for denial-of-service against RT
1364     # (construct a very inefficient query and trick lots of users into
1365     # running them against RT) it's incredibly useful to be able to link
1366     # to a search result (or chart) or bookmark a result page.
1367     '/Search/Results.html' => 1,
1368     '/Search/Simple.html'  => 1,
1369     '/m/tickets/search'    => 1,
1370     '/Search/Chart.html'   => 1,
1371     '/User/Search.html'    => 1,
1372
1373     # This page takes Attachment and Transaction argument to figure
1374     # out what to show, but it's read only and will deny information if you
1375     # don't have ShowOutgoingEmail.
1376     '/Ticket/ShowEmailRecord.html' => 1,
1377 );
1378
1379 # Components which are blacklisted from automatic, argument-based whitelisting.
1380 # These pages are not idempotent when called with just an id.
1381 our %is_blacklisted_component = (
1382     # Takes only id and toggles bookmark state
1383     '/Helpers/Toggle/TicketBookmark' => 1,
1384 );
1385
1386 sub IsCompCSRFWhitelisted {
1387     my $comp = shift;
1388     my $ARGS = shift;
1389
1390     return 1 if $is_whitelisted_component{$comp};
1391
1392     my %args = %{ $ARGS };
1393
1394     # If the user specifies a *correct* user and pass then they are
1395     # golden.  This acts on the presumption that external forms may
1396     # hardcode a username and password -- if a malicious attacker knew
1397     # both already, CSRF is the least of your problems.
1398     my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1399     if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1400         my $user_obj = RT::CurrentUser->new();
1401         $user_obj->Load($args{user});
1402         return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1403
1404         delete $args{user};
1405         delete $args{pass};
1406     }
1407
1408     # Some pages aren't idempotent even with safe args like id; blacklist
1409     # them from the automatic whitelisting below.
1410     return 0 if $is_blacklisted_component{$comp};
1411
1412     # Eliminate arguments that do not indicate an effectful request.
1413     # For example, "id" is acceptable because that is how RT retrieves a
1414     # record.
1415     delete $args{id};
1416
1417     # If they have a results= from MaybeRedirectForResults, that's also fine.
1418     delete $args{results};
1419
1420     # The homepage refresh, which uses the Refresh header, doesn't send
1421     # a referer in most browsers; whitelist the one parameter it reloads
1422     # with, HomeRefreshInterval, which is safe
1423     delete $args{HomeRefreshInterval};
1424
1425     # The NotMobile flag is fine for any page; it's only used to toggle a flag
1426     # in the session related to which interface you get.
1427     delete $args{NotMobile};
1428
1429     # If there are no arguments, then it's likely to be an idempotent
1430     # request, which are not susceptible to CSRF
1431     return 1 if !%args;
1432
1433     return 0;
1434 }
1435
1436 sub IsRefererCSRFWhitelisted {
1437     my $referer = _NormalizeHost(shift);
1438     my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1439     $base_url = $base_url->host_port;
1440
1441     my $configs;
1442     for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1443         push @$configs,$config;
1444
1445         my $host_port = $referer->host_port;
1446         if ($config =~ /\*/) {
1447             # Turn a literal * into a domain component or partial component match.
1448             # Refer to http://tools.ietf.org/html/rfc2818#page-5
1449             my $regex = join "[a-zA-Z0-9\-]*",
1450                          map { quotemeta($_) }
1451                        split /\*/, $config;
1452
1453             return 1 if $host_port =~ /^$regex$/i;
1454         } else {
1455             return 1 if $host_port eq $config;
1456         }
1457     }
1458
1459     return (0,$referer,$configs);
1460 }
1461
1462 =head3 _NormalizeHost
1463
1464 Takes a URI and creates a URI object that's been normalized
1465 to handle common problems such as localhost vs 127.0.0.1
1466
1467 =cut
1468
1469 sub _NormalizeHost {
1470
1471     my $uri= URI->new(shift);
1472     $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1473
1474     return $uri;
1475
1476 }
1477
1478 sub IsPossibleCSRF {
1479     my $ARGS = shift;
1480
1481     # If first request on this session is to a REST endpoint, then
1482     # whitelist the REST endpoints -- and explicitly deny non-REST
1483     # endpoints.  We do this because using a REST cookie in a browser
1484     # would open the user to CSRF attacks to the REST endpoints.
1485     my $path = $HTML::Mason::Commands::r->path_info;
1486     $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1487         unless defined $HTML::Mason::Commands::session{'REST'};
1488
1489     if ($HTML::Mason::Commands::session{'REST'}) {
1490         return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1491         my $why = <<EOT;
1492 This login session belongs to a REST client, and cannot be used to
1493 access non-REST interfaces of RT for security reasons.
1494 EOT
1495         my $details = <<EOT;
1496 Please log out and back in to obtain a session for normal browsing.  If
1497 you understand the security implications, disabling RT's CSRF protection
1498 will remove this restriction.
1499 EOT
1500         chomp $details;
1501         HTML::Mason::Commands::Abort( $why, Details => $details );
1502     }
1503
1504     return 0 if IsCompCSRFWhitelisted(
1505         $HTML::Mason::Commands::m->request_comp->path,
1506         $ARGS
1507     );
1508
1509     # if there is no Referer header then assume the worst
1510     return (1,
1511             "your browser did not supply a Referrer header", # loc
1512         ) if !$ENV{HTTP_REFERER};
1513
1514     my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1515     return 0 if $whitelisted;
1516
1517     if ( @$configs > 1 ) {
1518         return (1,
1519                 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1520                 $browser->host_port,
1521                 shift @$configs,
1522                 join(', ', @$configs) );
1523     }
1524
1525     return (1,
1526             "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1527             $browser->host_port,
1528             $configs->[0]);
1529 }
1530
1531 sub ExpandCSRFToken {
1532     my $ARGS = shift;
1533
1534     my $token = delete $ARGS->{CSRF_Token};
1535     return unless $token;
1536
1537     my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1538     return unless $data;
1539     return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1540
1541     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1542     return unless $user->ValidateAuthString( $data->{auth}, $token );
1543
1544     %{$ARGS} = %{$data->{args}};
1545     $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1546
1547     # We explicitly stored file attachments with the request, but not in
1548     # the session yet, as that would itself be an attack.  Put them into
1549     # the session now, so they'll be visible.
1550     if ($data->{attach}) {
1551         my $filename = $data->{attach}{filename};
1552         my $mime     = $data->{attach}{mime};
1553         $HTML::Mason::Commands::session{'Attachments'}{$ARGS->{'Token'}||''}{$filename}
1554             = $mime;
1555     }
1556
1557     return 1;
1558 }
1559
1560 sub StoreRequestToken {
1561     my $ARGS = shift;
1562
1563     my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1564     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1565     my $data = {
1566         auth => $user->GenerateAuthString( $token ),
1567         path => $HTML::Mason::Commands::r->path_info,
1568         args => $ARGS,
1569     };
1570     if ($ARGS->{Attach}) {
1571         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1572         my $file_path = delete $ARGS->{'Attach'};
1573
1574         # This needs to be decoded because the value is a reference;
1575         # hence it was not decoded along with all of the standard
1576         # arguments in DecodeARGS
1577         $data->{attach} = {
1578             filename => Encode::decode("UTF-8", "$file_path"),
1579             mime     => $attachment,
1580         };
1581     }
1582
1583     $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1584     $HTML::Mason::Commands::session{'i'}++;
1585     return $token;
1586 }
1587
1588 sub MaybeShowInterstitialCSRFPage {
1589     my $ARGS = shift;
1590
1591     return unless RT->Config->Get('RestrictReferrer');
1592
1593     # Deal with the form token provided by the interstitial, which lets
1594     # browsers which never set referer headers still use RT, if
1595     # painfully.  This blows values into ARGS
1596     return if ExpandCSRFToken($ARGS);
1597
1598     my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1599     return if !$is_csrf;
1600
1601     $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1602
1603     my $token = StoreRequestToken($ARGS);
1604     $HTML::Mason::Commands::m->comp(
1605         '/Elements/CSRF',
1606         OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1607         Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1608         Token => $token,
1609     );
1610     # Calls abort, never gets here
1611 }
1612
1613 our @POTENTIAL_PAGE_ACTIONS = (
1614     qr'/Ticket/Create.html' => "create a ticket",              # loc
1615     qr'/Ticket/'            => "update a ticket",              # loc
1616     qr'/Admin/'             => "modify RT's configuration",    # loc
1617     qr'/Approval/'          => "update an approval",           # loc
1618     qr'/Articles/'          => "update an article",            # loc
1619     qr'/Dashboards/'        => "modify a dashboard",           # loc
1620     qr'/m/ticket/'          => "update a ticket",              # loc
1621     qr'Prefs'               => "modify your preferences",      # loc
1622     qr'/Search/'            => "modify or access a search",    # loc
1623     qr'/SelfService/Create' => "create a ticket",              # loc
1624     qr'/SelfService/'       => "update a ticket",              # loc
1625 );
1626
1627 sub PotentialPageAction {
1628     my $page = shift;
1629     my @potentials = @POTENTIAL_PAGE_ACTIONS;
1630     while (my ($pattern, $result) = splice @potentials, 0, 2) {
1631         return HTML::Mason::Commands::loc($result)
1632             if $page =~ $pattern;
1633     }
1634     return "";
1635 }
1636
1637 =head2 RewriteInlineImages PARAMHASH
1638
1639 Turns C<< <img src="cid:..."> >> elements in HTML into working images pointing
1640 back to RT's stored copy.
1641
1642 Takes the following parameters:
1643
1644 =over 4
1645
1646 =item Content
1647
1648 Scalar ref of the HTML content to rewrite.  Modified in place to support the
1649 most common use-case.
1650
1651 =item Attachment
1652
1653 The L<RT::Attachment> object from which the Content originates.
1654
1655 =item Related (optional)
1656
1657 Array ref of related L<RT::Attachment> objects to use for C<Content-ID> matching.
1658
1659 Defaults to the result of the C<Siblings> method on the passed Attachment.
1660
1661 =item AttachmentPath (optional)
1662
1663 The base path to use when rewriting C<src> attributes.
1664
1665 Defaults to C< $WebPath/Ticket/Attachment >
1666
1667 =back
1668
1669 In scalar context, returns the number of elements rewritten.
1670
1671 In list content, returns the attachments IDs referred to by the rewritten <img>
1672 elements, in the order found.  There may be duplicates.
1673
1674 =cut
1675
1676 sub RewriteInlineImages {
1677     my %args = (
1678         Content         => undef,
1679         Attachment      => undef,
1680         Related         => undef,
1681         AttachmentPath  => RT->Config->Get('WebPath')."/Ticket/Attachment",
1682         @_
1683     );
1684
1685     return unless defined $args{Content}
1686               and ref $args{Content} eq 'SCALAR'
1687               and defined $args{Attachment};
1688
1689     my $related_part = $args{Attachment}->Closest("multipart/related")
1690         or return;
1691
1692     $args{Related} ||= $related_part->Children->ItemsArrayRef;
1693     return unless @{$args{Related}};
1694
1695     my $content = $args{'Content'};
1696     my @rewritten;
1697
1698     require HTML::RewriteAttributes::Resources;
1699     $$content = HTML::RewriteAttributes::Resources->rewrite($$content, sub {
1700         my $cid  = shift;
1701         my %meta = @_;
1702         return $cid unless    lc $meta{tag}  eq 'img'
1703                           and lc $meta{attr} eq 'src'
1704                           and $cid =~ s/^cid://i;
1705
1706         for my $attach (@{$args{Related}}) {
1707             if (($attach->GetHeader('Content-ID') || '') =~ /^(<)?\Q$cid\E(?(1)>)$/) {
1708                 push @rewritten, $attach->Id;
1709                 return "$args{AttachmentPath}/" . $attach->TransactionId . '/' . $attach->Id;
1710             }
1711         }
1712
1713         # No attachments means this is a bogus CID. Just pass it through.
1714         RT->Logger->debug(qq[Found bogus inline image src="cid:$cid"]);
1715         return "cid:$cid";
1716     });
1717     return @rewritten;
1718 }
1719
1720 =head2 GetCustomFieldInputName(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1721
1722 Returns the standard custom field input name; this is complementary to
1723 L</_ParseObjectCustomFieldArgs>.  Takes the following arguments:
1724
1725 =over
1726
1727 =item CustomField => I<L<RT::CustomField> object>
1728
1729 Required.
1730
1731 =item Object => I<object>
1732
1733 The object that the custom field is applied to; optional.  If omitted,
1734 defaults to a new object of the appropriate class for the custom field.
1735
1736 =item Grouping => I<CF grouping>
1737
1738 The grouping that the custom field is being rendered in.  Groupings
1739 allow a custom field to appear in more than one location per form.
1740
1741 =back
1742
1743 =cut
1744
1745 sub GetCustomFieldInputName {
1746     my %args = (
1747         CustomField => undef,
1748         Object      => undef,
1749         Grouping    => undef,
1750         @_,
1751     );
1752
1753     my $name = GetCustomFieldInputNamePrefix(%args);
1754
1755     if ( $args{CustomField}->Type eq 'Select' ) {
1756         if ( $args{CustomField}->RenderType eq 'List' and $args{CustomField}->SingleValue ) {
1757             $name .= 'Value';
1758         }
1759         else {
1760             $name .= 'Values';
1761         }
1762     }
1763     elsif ( $args{CustomField}->Type =~ /^(?:Binary|Image)$/ ) {
1764         $name .= 'Upload';
1765     }
1766     elsif ( $args{CustomField}->Type =~ /^(?:Date|DateTime|Text|Wikitext)$/ ) {
1767         $name .= 'Values';
1768     }
1769     else {
1770         if ( $args{CustomField}->SingleValue ) {
1771             $name .= 'Value';
1772         }
1773         else {
1774             $name .= 'Values';
1775         }
1776     }
1777
1778     return $name;
1779 }
1780
1781 =head2 GetCustomFieldInputNamePrefix(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1782
1783 Returns the standard custom field input name prefix(without "Value" or alike suffix)
1784
1785 =cut
1786
1787 sub GetCustomFieldInputNamePrefix {
1788     my %args = (
1789         CustomField => undef,
1790         Object      => undef,
1791         Grouping    => undef,
1792         @_,
1793     );
1794
1795     my $prefix = join '-', 'Object', ref( $args{Object} ) || $args{CustomField}->ObjectTypeFromLookupType,
1796         ( $args{Object} && $args{Object}->id ? $args{Object}->id : '' ),
1797         'CustomField' . ( $args{Grouping} ? ":$args{Grouping}" : '' ),
1798         $args{CustomField}->id, '';
1799
1800     return $prefix;
1801 }
1802
1803 package HTML::Mason::Commands;
1804
1805 use vars qw/$r $m %session/;
1806
1807 use Scalar::Util qw(blessed);
1808
1809 sub Menu {
1810     return $HTML::Mason::Commands::m->notes('menu');
1811 }
1812
1813 sub PageMenu {
1814     return $HTML::Mason::Commands::m->notes('page-menu');
1815 }
1816
1817 sub PageWidgets {
1818     return $HTML::Mason::Commands::m->notes('page-widgets');
1819 }
1820
1821 sub RenderMenu {
1822     my %args = (toplevel => 1, parent_id => '', depth => 0, @_);
1823     return unless $args{'menu'};
1824
1825     my ($menu, $depth, $toplevel, $id, $parent_id)
1826         = @args{qw(menu depth toplevel id parent_id)};
1827
1828     my $interp = $m->interp;
1829     my $web_path = RT->Config->Get('WebPath');
1830
1831     my $res = '';
1832     $res .= ' ' x $depth;
1833     $res .= '<ul';
1834     $res .= ' id="'. $interp->apply_escapes($id, 'h') .'"'
1835         if $id;
1836     $res .= ' class="toplevel"' if $toplevel;
1837     $res .= ">\n";
1838
1839     for my $child ($menu->children) {
1840         $res .= ' 'x ($depth+1);
1841
1842         my $item_id = lc(($parent_id? "$parent_id-" : "") .$child->key);
1843         $item_id =~ s/\s/-/g;
1844         my $eitem_id = $interp->apply_escapes($item_id, 'h');
1845         $res .= qq{<li id="li-$eitem_id"};
1846
1847         my @classes;
1848         push @classes, 'has-children' if $child->has_children;
1849         push @classes, 'active'       if $child->active;
1850         $res .= ' class="'. join( ' ', @classes ) .'"'
1851             if @classes;
1852
1853         $res .= '>';
1854
1855         if ( my $tmp = $child->raw_html ) {
1856             $res .= $tmp;
1857         } else {
1858             $res .= qq{<a id="$eitem_id" class="menu-item};
1859             if ( $tmp = $child->class ) {
1860                 $res .= ' '. $interp->apply_escapes($tmp, 'h');
1861             }
1862             $res .= '"';
1863
1864             my $path = $child->path;
1865             my $url = (not $path or $path =~ m{^\w+:/}) ? $path : $web_path . $path;
1866             $res .= ' href="'. $interp->apply_escapes($url, 'h') .'"'
1867                 if $url;
1868
1869             if ( $tmp = $child->target ) {
1870                 $res .= ' target="'. $interp->apply_escapes($tmp, 'h') .'"'
1871             }
1872
1873             if ($child->attributes) {
1874                 for my $key (keys %{$child->attributes}) {
1875                     my ($name, $value) = map { $interp->apply_escapes($_, 'h') }
1876                                              $key, $child->attributes->{$key};
1877                     $res .= " $name=\"$value\"";
1878                 }
1879             }
1880             $res .= '>';
1881
1882             if ( $child->escape_title ) {
1883                 $res .= $interp->apply_escapes($child->title, 'h');
1884             } else {
1885                 $res .= $child->title;
1886             }
1887             $res .= '</a>';
1888         }
1889
1890         if ( $child->has_children ) {
1891             $res .= "\n";
1892             $res .= RenderMenu(
1893                 menu => $child,
1894                 toplevel => 0,
1895                 parent_id => $item_id,
1896                 depth => $depth+1,
1897                 return => 1,
1898             );
1899             $res .= "\n";
1900             $res .= ' ' x ($depth+1);
1901         }
1902         $res .= "</li>\n";
1903     }
1904     $res .= ' ' x $depth;
1905     $res .= '</ul>';
1906     return $res if $args{'return'};
1907
1908     $m->print($res);
1909     return '';
1910 }
1911
1912 =head2 loc ARRAY
1913
1914 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1915 with whatever it's called with. If there is no $session{'CurrentUser'}, 
1916 it creates a temporary user, so we have something to get a localisation handle
1917 through
1918
1919 =cut
1920
1921 sub loc {
1922
1923     if ( $session{'CurrentUser'}
1924         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1925     {
1926         return ( $session{'CurrentUser'}->loc(@_) );
1927     } elsif (
1928         my $u = eval {
1929             RT::CurrentUser->new();
1930         }
1931         )
1932     {
1933         return ( $u->loc(@_) );
1934     } else {
1935
1936         # pathetic case -- SystemUser is gone.
1937         return $_[0];
1938     }
1939 }
1940
1941
1942
1943 =head2 loc_fuzzy STRING
1944
1945 loc_fuzzy is for handling localizations of messages that may already
1946 contain interpolated variables, typically returned from libraries
1947 outside RT's control.  It takes the message string and extracts the
1948 variable array automatically by matching against the candidate entries
1949 inside the lexicon file.
1950
1951 =cut
1952
1953 sub loc_fuzzy {
1954     my $msg = shift;
1955
1956     if ( $session{'CurrentUser'}
1957         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1958     {
1959         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1960     } else {
1961         my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1962         return ( $u->loc_fuzzy($msg) );
1963     }
1964 }
1965
1966
1967 # Error - calls Error and aborts
1968 sub Abort {
1969     my $why  = shift;
1970     my %args = @_;
1971
1972     if (   $session{'ErrorDocument'}
1973         && $session{'ErrorDocumentType'} )
1974     {
1975         $r->content_type( $session{'ErrorDocumentType'} );
1976         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1977         $m->abort;
1978     } else {
1979         $m->comp( "/Elements/Error", Why => $why, %args );
1980         $m->abort;
1981     }
1982 }
1983
1984 sub MaybeRedirectForResults {
1985     my %args = (
1986         Path      => $HTML::Mason::Commands::m->request_comp->path,
1987         Arguments => {},
1988         Anchor    => undef,
1989         Actions   => undef,
1990         Force     => 0,
1991         @_
1992     );
1993     my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1994     return unless $has_actions || $args{'Force'};
1995
1996     my %arguments = %{ $args{'Arguments'} };
1997
1998     if ( $has_actions ) {
1999         my $key = Digest::MD5::md5_hex( rand(1024) );
2000         push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
2001         $session{'i'}++;
2002         $arguments{'results'} = $key;
2003     }
2004
2005     $args{'Path'} =~ s!^/+!!;
2006     my $url = RT->Config->Get('WebURL') . $args{Path};
2007
2008     if ( keys %arguments ) {
2009         $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
2010     }
2011     if ( $args{'Anchor'} ) {
2012         $url .= "#". $args{'Anchor'};
2013     }
2014     return RT::Interface::Web::Redirect($url);
2015 }
2016
2017 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
2018
2019 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
2020 redirect to the approvals display page, preserving any arguments.
2021
2022 C<Path>s matching C<Whitelist> are let through.
2023
2024 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
2025
2026 =cut
2027
2028 sub MaybeRedirectToApproval {
2029     my %args = (
2030         Path        => $HTML::Mason::Commands::m->request_comp->path,
2031         ARGSRef     => {},
2032         Whitelist   => undef,
2033         @_
2034     );
2035
2036     return unless $ENV{REQUEST_METHOD} eq 'GET';
2037
2038     my $id = $args{ARGSRef}->{id};
2039
2040     if (    $id
2041         and RT->Config->Get('ForceApprovalsView')
2042         and not $args{Path} =~ /$args{Whitelist}/)
2043     {
2044         my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
2045         $ticket->Load($id);
2046
2047         if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
2048             MaybeRedirectForResults(
2049                 Path      => "/Approvals/Display.html",
2050                 Force     => 1,
2051                 Anchor    => $args{ARGSRef}->{Anchor},
2052                 Arguments => $args{ARGSRef},
2053             );
2054         }
2055     }
2056 }
2057
2058 =head2 CreateTicket ARGS
2059
2060 Create a new ticket, using Mason's %ARGS.  returns @results.
2061
2062 =cut
2063
2064 sub CreateTicket {
2065     my %ARGS = (@_);
2066
2067     my (@Actions);
2068
2069     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
2070
2071     my $Queue = RT::Queue->new( $session{'CurrentUser'} );
2072     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
2073         Abort('Queue not found');
2074     }
2075
2076     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
2077         Abort('You have no permission to create tickets in that queue.');
2078     }
2079
2080     my $due;
2081     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
2082         $due = RT::Date->new( $session{'CurrentUser'} );
2083         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
2084     }
2085     my $starts;
2086     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
2087         $starts = RT::Date->new( $session{'CurrentUser'} );
2088         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
2089     }
2090
2091     my $sigless = RT::Interface::Web::StripContent(
2092         Content        => $ARGS{Content},
2093         ContentType    => $ARGS{ContentType},
2094         StripSignature => 1,
2095         CurrentUser    => $session{'CurrentUser'},
2096     );
2097
2098     my $MIMEObj = MakeMIMEEntity(
2099         Subject => $ARGS{'Subject'},
2100         From    => $ARGS{'From'},
2101         Cc      => $ARGS{'Cc'},
2102         Body    => $sigless,
2103         Type    => $ARGS{'ContentType'},
2104         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2105     );
2106
2107     my @attachments;
2108     if ( my $tmp = $session{'Attachments'}{ $ARGS{'Token'} || '' } ) {
2109         push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2110
2111         delete $session{'Attachments'}{ $ARGS{'Token'} || '' }
2112             unless $ARGS{'KeepAttachments'};
2113         $session{'Attachments'} = $session{'Attachments'}
2114             if @attachments;
2115     }
2116     if ( $ARGS{'Attachments'} ) {
2117         push @attachments, grep $_, map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} };
2118     }
2119     if ( @attachments ) {
2120         $MIMEObj->make_multipart;
2121         $MIMEObj->add_part( $_ ) foreach @attachments;
2122     }
2123
2124     for my $argument (qw(Encrypt Sign)) {
2125         if ( defined $ARGS{ $argument } ) {
2126             $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
2127         }
2128     }
2129
2130     my %create_args = (
2131         Type => $ARGS{'Type'} || 'ticket',
2132         Queue => $ARGS{'Queue'},
2133         Owner => $ARGS{'Owner'},
2134
2135         # note: name change
2136         Requestor       => $ARGS{'Requestors'},
2137         Cc              => $ARGS{'Cc'},
2138         AdminCc         => $ARGS{'AdminCc'},
2139         InitialPriority => $ARGS{'InitialPriority'},
2140         FinalPriority   => $ARGS{'FinalPriority'},
2141         TimeLeft        => $ARGS{'TimeLeft'},
2142         TimeEstimated   => $ARGS{'TimeEstimated'},
2143         TimeWorked      => $ARGS{'TimeWorked'},
2144         Subject         => $ARGS{'Subject'},
2145         Status          => $ARGS{'Status'},
2146         Due             => $due ? $due->ISO : undef,
2147         Starts          => $starts ? $starts->ISO : undef,
2148         MIMEObj         => $MIMEObj,
2149         TransSquelchMailTo => $ARGS{'TransSquelchMailTo'},
2150     );
2151
2152     if ($ARGS{'DryRun'}) {
2153         $create_args{DryRun} = 1;
2154         $create_args{Owner}     ||= $RT::Nobody->Id;
2155         $create_args{Requestor} ||= $session{CurrentUser}->EmailAddress;
2156         $create_args{Subject}   ||= '';
2157         $create_args{Status}    ||= $Queue->Lifecycle->DefaultOnCreate,
2158     } else {
2159         my @txn_squelch;
2160         foreach my $type (qw(Requestor Cc AdminCc)) {
2161             push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
2162                 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
2163         }
2164         push @{$create_args{TransSquelchMailTo}}, @txn_squelch;
2165     }
2166
2167     if ( $ARGS{'AttachTickets'} ) {
2168         require RT::Action::SendEmail;
2169         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2170             ref $ARGS{'AttachTickets'}
2171             ? @{ $ARGS{'AttachTickets'} }
2172             : ( $ARGS{'AttachTickets'} ) );
2173     }
2174
2175     my %cfs = ProcessObjectCustomFieldUpdatesForCreate(
2176         ARGSRef         => \%ARGS,
2177         ContextObject   => $Queue,
2178     );
2179
2180     my %links = ProcessLinksForCreate( ARGSRef => \%ARGS );
2181
2182     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args, %links, %cfs);
2183     return $Trans if $ARGS{DryRun};
2184
2185     unless ($id) {
2186         Abort($ErrMsg);
2187     }
2188
2189     push( @Actions, split( "\n", $ErrMsg ) );
2190     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
2191         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
2192     }
2193     return ( $Ticket, @Actions );
2194
2195 }
2196
2197
2198
2199 =head2  LoadTicket id
2200
2201 Takes a ticket id as its only variable. if it's handed an array, it takes
2202 the first value.
2203
2204 Returns an RT::Ticket object as the current user.
2205
2206 =cut
2207
2208 sub LoadTicket {
2209     my $id = shift;
2210
2211     if ( ref($id) eq "ARRAY" ) {
2212         $id = $id->[0];
2213     }
2214
2215     unless ($id) {
2216         Abort("No ticket specified");
2217     }
2218
2219     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
2220     $Ticket->Load($id);
2221     unless ( $Ticket->id ) {
2222         Abort("Could not load ticket $id");
2223     }
2224     return $Ticket;
2225 }
2226
2227
2228
2229 =head2 ProcessUpdateMessage
2230
2231 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
2232
2233 Don't write message if it only contains current user's signature and
2234 SkipSignatureOnly argument is true. Function anyway adds attachments
2235 and updates time worked field even if skips message. The default value
2236 is true.
2237
2238 =cut
2239
2240 sub ProcessUpdateMessage {
2241
2242     my %args = (
2243         ARGSRef           => undef,
2244         TicketObj         => undef,
2245         SkipSignatureOnly => 1,
2246         @_
2247     );
2248
2249     my @attachments;
2250     if ( my $tmp = $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' } ) {
2251         push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2252
2253         delete $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' }
2254             unless $args{'KeepAttachments'};
2255         $session{'Attachments'} = $session{'Attachments'}
2256             if @attachments;
2257     }
2258     if ( $args{ARGSRef}{'UpdateAttachments'} ) {
2259         push @attachments, grep $_, map $args{ARGSRef}->{UpdateAttachments}{$_},
2260                                    sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2261     }
2262
2263     # Strip the signature
2264     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
2265         Content        => $args{ARGSRef}->{UpdateContent},
2266         ContentType    => $args{ARGSRef}->{UpdateContentType},
2267         StripSignature => $args{SkipSignatureOnly},
2268         CurrentUser    => $args{'TicketObj'}->CurrentUser,
2269     );
2270
2271     # If, after stripping the signature, we have no message, move the
2272     # UpdateTimeWorked into adjusted TimeWorked, so that a later
2273     # ProcessBasics can deal -- then bail out.
2274     if (    not @attachments
2275         and not length $args{ARGSRef}->{'UpdateContent'} )
2276     {
2277         if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
2278             $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
2279         }
2280         return;
2281     }
2282
2283     if ( ($args{ARGSRef}->{'UpdateSubject'}||'') eq ($args{'TicketObj'}->Subject || '') ) {
2284         $args{ARGSRef}->{'UpdateSubject'} = undef;
2285     }
2286
2287     my $Message = MakeMIMEEntity(
2288         Subject => $args{ARGSRef}->{'UpdateSubject'},
2289         Body    => $args{ARGSRef}->{'UpdateContent'},
2290         Type    => $args{ARGSRef}->{'UpdateContentType'},
2291         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2292     );
2293
2294     $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
2295         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2296     ) );
2297     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2298     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2299         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2300     } else {
2301         $old_txn = $args{TicketObj}->Transactions->First();
2302     }
2303
2304     if ( my $msg = $old_txn->Message->First ) {
2305         RT::Interface::Email::SetInReplyTo(
2306             Message   => $Message,
2307             InReplyTo => $msg,
2308             Ticket    => $args{'TicketObj'},
2309         );
2310     }
2311
2312     if ( @attachments ) {
2313         $Message->make_multipart;
2314         $Message->add_part( $_ ) foreach @attachments;
2315     }
2316
2317     if ( $args{ARGSRef}->{'AttachTickets'} ) {
2318         require RT::Action::SendEmail;
2319         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2320             ref $args{ARGSRef}->{'AttachTickets'}
2321             ? @{ $args{ARGSRef}->{'AttachTickets'} }
2322             : ( $args{ARGSRef}->{'AttachTickets'} ) );
2323     }
2324
2325     my %message_args = (
2326         Sign         => $args{ARGSRef}->{'Sign'},
2327         Encrypt      => $args{ARGSRef}->{'Encrypt'},
2328         MIMEObj      => $Message,
2329         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'}
2330     );
2331
2332     _ProcessUpdateMessageRecipients(
2333         MessageArgs => \%message_args,
2334         %args,
2335     );
2336
2337     my @results;
2338     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2339         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2340         push( @results, $Description );
2341         $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2342     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2343         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2344         push( @results, $Description );
2345         $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2346     } else {
2347         push( @results,
2348             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2349     }
2350     return @results;
2351 }
2352
2353 sub _ProcessUpdateMessageRecipients {
2354     my %args = (
2355         ARGSRef           => undef,
2356         TicketObj         => undef,
2357         MessageArgs       => undef,
2358         @_,
2359     );
2360
2361     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2362     my $cc  = $args{ARGSRef}->{'UpdateCc'};
2363
2364     my $message_args = $args{MessageArgs};
2365
2366     $message_args->{CcMessageTo} = $cc;
2367     $message_args->{BccMessageTo} = $bcc;
2368
2369     my @txn_squelch;
2370     foreach my $type (qw(Cc AdminCc)) {
2371         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2372             push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2373             push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2374             push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2375         }
2376     }
2377     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2378         push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2379         push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2380     }
2381
2382     push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2383     $message_args->{SquelchMailTo} = \@txn_squelch
2384         if @txn_squelch;
2385
2386     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2387         foreach my $key ( keys %{ $args{ARGSRef} } ) {
2388             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2389
2390             my $var   = ucfirst($1) . 'MessageTo';
2391             my $value = $2;
2392             if ( $message_args->{$var} ) {
2393                 $message_args->{$var} .= ", $value";
2394             } else {
2395                 $message_args->{$var} = $value;
2396             }
2397         }
2398     }
2399 }
2400
2401 sub ProcessAttachments {
2402     my %args = (
2403         ARGSRef => {},
2404         Token   => '',
2405         @_
2406     );
2407
2408     my $token = $args{'ARGSRef'}{'Token'}
2409         ||= $args{'Token'} ||= Digest::MD5::md5_hex( rand(1024) );
2410
2411     my $update_session = 0;
2412
2413     # deal with deleting uploaded attachments
2414     if ( my $del = $args{'ARGSRef'}{'DeleteAttach'} ) {
2415         delete $session{'Attachments'}{ $token }{ $_ }
2416             foreach ref $del? @$del : ($del);
2417
2418         $update_session = 1;
2419     }
2420
2421     # store the uploaded attachment in session
2422     my $new = $args{'ARGSRef'}{'Attach'};
2423     if ( defined $new && length $new ) {
2424         my $attachment = MakeMIMEEntity(
2425             AttachmentFieldName => 'Attach'
2426         );
2427
2428         # This needs to be decoded because the value is a reference;
2429         # hence it was not decoded along with all of the standard
2430         # arguments in DecodeARGS
2431         my $file_path = Encode::decode( "UTF-8", "$new");
2432         $session{'Attachments'}{ $token }{ $file_path } = $attachment;
2433
2434         $update_session = 1;
2435     }
2436     $session{'Attachments'} = $session{'Attachments'} if $update_session;
2437 }
2438
2439
2440 =head2 MakeMIMEEntity PARAMHASH
2441
2442 Takes a paramhash Subject, Body and AttachmentFieldName.
2443
2444 Also takes Form, Cc and Type as optional paramhash keys.
2445
2446   Returns a MIME::Entity.
2447
2448 =cut
2449
2450 sub MakeMIMEEntity {
2451
2452     #TODO document what else this takes.
2453     my %args = (
2454         Subject             => undef,
2455         From                => undef,
2456         Cc                  => undef,
2457         Body                => undef,
2458         AttachmentFieldName => undef,
2459         Type                => undef,
2460         Interface           => 'API',
2461         @_,
2462     );
2463     my $Message = MIME::Entity->build(
2464         Type    => 'multipart/mixed',
2465         "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
2466         "X-RT-Interface" => $args{Interface},
2467         map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
2468             grep defined $args{$_}, qw(Subject From Cc)
2469     );
2470
2471     if ( defined $args{'Body'} && length $args{'Body'} ) {
2472
2473         # Make the update content have no 'weird' newlines in it
2474         $args{'Body'} =~ s/\r\n/\n/gs;
2475
2476         $Message->attach(
2477             Type    => $args{'Type'} || 'text/plain',
2478             Charset => 'UTF-8',
2479             Data    => Encode::encode( "UTF-8", $args{'Body'} ),
2480         );
2481     }
2482
2483     if ( $args{'AttachmentFieldName'} ) {
2484
2485         my $cgi_object = $m->cgi_object;
2486         my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2487         if ( defined $filehandle && length $filehandle ) {
2488
2489             my ( @content, $buffer );
2490             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2491                 push @content, $buffer;
2492             }
2493
2494             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2495
2496             my $filename = Encode::decode("UTF-8","$filehandle");
2497             $filename =~ s{^.*[\\/]}{};
2498
2499             $Message->attach(
2500                 Type     => $uploadinfo->{'Content-Type'},
2501                 Filename => Encode::encode("UTF-8",$filename),
2502                 Data     => \@content, # Bytes, as read directly from the file, above
2503             );
2504             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2505                 $Message->head->replace( 'Subject' => Encode::encode( "UTF-8", $filename ) );
2506             }
2507
2508             # Attachment parts really shouldn't get a Message-ID or "interface"
2509             $Message->head->delete('Message-ID');
2510             $Message->head->delete('X-RT-Interface');
2511         }
2512     }
2513
2514     $Message->make_singlepart;
2515
2516     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
2517
2518     return ($Message);
2519
2520 }
2521
2522
2523
2524 =head2 ParseDateToISO
2525
2526 Takes a date in an arbitrary format.
2527 Returns an ISO date and time in GMT
2528
2529 =cut
2530
2531 sub ParseDateToISO {
2532     my $date = shift;
2533
2534     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2535     $date_obj->Set(
2536         Format => 'unknown',
2537         Value  => $date
2538     );
2539     return ( $date_obj->ISO );
2540 }
2541
2542
2543
2544 sub ProcessACLChanges {
2545     my $ARGSref = shift;
2546
2547     #XXX: why don't we get ARGSref like in other Process* subs?
2548
2549     my @results;
2550
2551     foreach my $arg ( keys %$ARGSref ) {
2552         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2553
2554         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2555
2556         my @rights;
2557         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2558             @rights = @{ $ARGSref->{$arg} };
2559         } else {
2560             @rights = $ARGSref->{$arg};
2561         }
2562         @rights = grep $_, @rights;
2563         next unless @rights;
2564
2565         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2566         $principal->Load($principal_id);
2567
2568         my $obj;
2569         if ( $object_type eq 'RT::System' ) {
2570             $obj = $RT::System;
2571         } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2572             $obj = $object_type->new( $session{'CurrentUser'} );
2573             $obj->Load($object_id);
2574             unless ( $obj->id ) {
2575                 $RT::Logger->error("couldn't load $object_type #$object_id");
2576                 next;
2577             }
2578         } else {
2579             $RT::Logger->error("object type '$object_type' is incorrect");
2580             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2581             next;
2582         }
2583
2584         foreach my $right (@rights) {
2585             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2586             push( @results, $msg );
2587         }
2588     }
2589
2590     return (@results);
2591 }
2592
2593
2594 =head2 ProcessACLs
2595
2596 ProcessACLs expects values from a series of checkboxes that describe the full
2597 set of rights a principal should have on an object.
2598
2599 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2600 instead of with the prefixes Grant/RevokeRight.  Each input should be an array
2601 listing the rights the principal should have, and ProcessACLs will modify the
2602 current rights to match.  Additionally, the previously unused CheckACL input
2603 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2604 rights are removed from a principal and as such no SetRights input is
2605 submitted.
2606
2607 =cut
2608
2609 sub ProcessACLs {
2610     my $ARGSref = shift;
2611     my (%state, @results);
2612
2613     my $CheckACL = $ARGSref->{'CheckACL'};
2614     my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2615
2616     # Check if we want to grant rights to a previously rights-less user
2617     for my $type (qw(user group)) {
2618         my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2619             or next;
2620
2621         unless ($principal->PrincipalId) {
2622             push @results, loc("Couldn't load the specified principal");
2623             next;
2624         }
2625
2626         my $principal_id = $principal->PrincipalId;
2627
2628         # Turn our addprincipal rights spec into a real one
2629         for my $arg (keys %$ARGSref) {
2630             next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2631
2632             my $tuple = "$principal_id-$1";
2633             my $key   = "SetRights-$tuple";
2634
2635             # If we have it already, that's odd, but merge them
2636             if (grep { $_ eq $tuple } @check) {
2637                 $ARGSref->{$key} = [
2638                     (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2639                     (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2640                 ];
2641             } else {
2642                 $ARGSref->{$key} = $ARGSref->{$arg};
2643                 push @check, $tuple;
2644             }
2645         }
2646     }
2647
2648     # Build our rights state for each Principal-Object tuple
2649     foreach my $arg ( keys %$ARGSref ) {
2650         next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2651
2652         my $tuple  = $1;
2653         my $value  = $ARGSref->{$arg};
2654         my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2655         next unless @rights;
2656
2657         $state{$tuple} = { map { $_ => 1 } @rights };
2658     }
2659
2660     foreach my $tuple (List::MoreUtils::uniq @check) {
2661         next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2662
2663         my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2664
2665         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2666         $principal->Load($principal_id);
2667
2668         my $obj;
2669         if ( $object_type eq 'RT::System' ) {
2670             $obj = $RT::System;
2671         } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2672             $obj = $object_type->new( $session{'CurrentUser'} );
2673             $obj->Load($object_id);
2674             unless ( $obj->id ) {
2675                 $RT::Logger->error("couldn't load $object_type #$object_id");
2676                 next;
2677             }
2678         } else {
2679             $RT::Logger->error("object type '$object_type' is incorrect");
2680             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2681             next;
2682         }
2683
2684         my $acls = RT::ACL->new($session{'CurrentUser'});
2685         $acls->LimitToObject( $obj );
2686         $acls->LimitToPrincipal( Id => $principal_id );
2687
2688         while ( my $ace = $acls->Next ) {
2689             my $right = $ace->RightName;
2690
2691             # Has right and should have right
2692             next if delete $state{$tuple}->{$right};
2693
2694             # Has right and shouldn't have right
2695             my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2696             push @results, $msg;
2697         }
2698
2699         # For everything left, they don't have the right but they should
2700         for my $right (keys %{ $state{$tuple} || {} }) {
2701             delete $state{$tuple}->{$right};
2702             my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2703             push @results, $msg;
2704         }
2705
2706         # Check our state for leftovers
2707         if ( keys %{ $state{$tuple} || {} } ) {
2708             my $missed = join '|', %{$state{$tuple} || {}};
2709             $RT::Logger->warn(
2710                "Uh-oh, it looks like we somehow missed a right in "
2711               ."ProcessACLs.  Here's what was leftover: $missed"
2712             );
2713         }
2714     }
2715
2716     return (@results);
2717 }
2718
2719 =head2 _ParseACLNewPrincipal
2720
2721 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>).  Looks
2722 for the presence of rights being added on a principal of the specified type,
2723 and returns undef if no new principal is being granted rights.  Otherwise loads
2724 up an L<RT::User> or L<RT::Group> object and returns it.  Note that the object
2725 may not be successfully loaded, and you should check C<->id> yourself.
2726
2727 =cut
2728
2729 sub _ParseACLNewPrincipal {
2730     my $ARGSref = shift;
2731     my $type    = lc shift;
2732     my $key     = "AddPrincipalForRights-$type";
2733
2734     return unless $ARGSref->{$key};
2735
2736     my $principal;
2737     if ( $type eq 'user' ) {
2738         $principal = RT::User->new( $session{'CurrentUser'} );
2739         $principal->LoadByCol( Name => $ARGSref->{$key} );
2740     }
2741     elsif ( $type eq 'group' ) {
2742         $principal = RT::Group->new( $session{'CurrentUser'} );
2743         $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2744     }
2745     return $principal;
2746 }
2747
2748
2749 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2750
2751 @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.
2752
2753 Returns an array of success/failure messages
2754
2755 =cut
2756
2757 sub UpdateRecordObject {
2758     my %args = (
2759         ARGSRef         => undef,
2760         AttributesRef   => undef,
2761         Object          => undef,
2762         AttributePrefix => undef,
2763         @_
2764     );
2765
2766     my $Object  = $args{'Object'};
2767     my @results = $Object->Update(
2768         AttributesRef   => $args{'AttributesRef'},
2769         ARGSRef         => $args{'ARGSRef'},
2770         AttributePrefix => $args{'AttributePrefix'},
2771     );
2772
2773     return (@results);
2774 }
2775
2776
2777
2778 sub ProcessCustomFieldUpdates {
2779     my %args = (
2780         CustomFieldObj => undef,
2781         ARGSRef        => undef,
2782         @_
2783     );
2784
2785     my $Object  = $args{'CustomFieldObj'};
2786     my $ARGSRef = $args{'ARGSRef'};
2787
2788     my @attribs = qw(Name Type Description Queue SortOrder);
2789     my @results = UpdateRecordObject(
2790         AttributesRef => \@attribs,
2791         Object        => $Object,
2792         ARGSRef       => $ARGSRef
2793     );
2794
2795     my $prefix = "CustomField-" . $Object->Id;
2796     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2797         my ( $addval, $addmsg ) = $Object->AddValue(
2798             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2799             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2800             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2801         );
2802         push( @results, $addmsg );
2803     }
2804
2805     my @delete_values
2806         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2807         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2808         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2809
2810     foreach my $id (@delete_values) {
2811         next unless defined $id;
2812         my ( $err, $msg ) = $Object->DeleteValue($id);
2813         push( @results, $msg );
2814     }
2815
2816     my $vals = $Object->Values();
2817     while ( my $cfv = $vals->Next() ) {
2818         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2819             if ( $cfv->SortOrder != $so ) {
2820                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2821                 push( @results, $msg );
2822             }
2823         }
2824     }
2825
2826     return (@results);
2827 }
2828
2829
2830
2831 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2832
2833 Returns an array of results messages.
2834
2835 =cut
2836
2837 sub ProcessTicketBasics {
2838
2839     my %args = (
2840         TicketObj => undef,
2841         ARGSRef   => undef,
2842         @_
2843     );
2844
2845     my $TicketObj = $args{'TicketObj'};
2846     my $ARGSRef   = $args{'ARGSRef'};
2847
2848     my $OrigOwner = $TicketObj->Owner;
2849
2850     # Set basic fields
2851     my @attribs = qw(
2852         Subject
2853         FinalPriority
2854         Priority
2855         TimeEstimated
2856         TimeWorked
2857         TimeLeft
2858         Type
2859         Status
2860         Queue
2861     );
2862
2863     # Canonicalize Queue and Owner to their IDs if they aren't numeric
2864     for my $field (qw(Queue Owner)) {
2865         if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2866             my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2867             my $temp = $class->new(RT->SystemUser);
2868             $temp->Load( $ARGSRef->{$field} );
2869             if ( $temp->id ) {
2870                 $ARGSRef->{$field} = $temp->id;
2871             }
2872         }
2873     }
2874
2875     # Status isn't a field that can be set to a null value.
2876     # RT core complains if you try
2877     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2878
2879     my @results = UpdateRecordObject(
2880         AttributesRef => \@attribs,
2881         Object        => $TicketObj,
2882         ARGSRef       => $ARGSRef,
2883     );
2884
2885     # We special case owner changing, so we can use ForceOwnerChange
2886     if ( $ARGSRef->{'Owner'}
2887       && $ARGSRef->{'Owner'} !~ /\D/
2888       && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2889         my ($ChownType);
2890         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2891             $ChownType = "Force";
2892         }
2893         else {
2894             $ChownType = "Set";
2895         }
2896
2897         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2898         push( @results, $msg );
2899     }
2900
2901     # }}}
2902
2903     return (@results);
2904 }
2905
2906 sub ProcessTicketReminders {
2907     my %args = (
2908         TicketObj => undef,
2909         ARGSRef   => undef,
2910         @_
2911     );
2912
2913     my $Ticket = $args{'TicketObj'};
2914     my $args   = $args{'ARGSRef'};
2915     my @results;
2916
2917     my $reminder_collection = $Ticket->Reminders->Collection;
2918
2919     if ( $args->{'update-reminders'} ) {
2920         while ( my $reminder = $reminder_collection->Next ) {
2921             my $resolve_status = $reminder->LifecycleObj->ReminderStatusOnResolve;
2922             my ( $status, $msg, $old_subject, @subresults );
2923             if (   $reminder->Status ne $resolve_status
2924                 && $args->{ 'Complete-Reminder-' . $reminder->id } )
2925             {
2926                 ( $status, $msg ) = $Ticket->Reminders->Resolve($reminder);
2927                 push @subresults, $msg;
2928             }
2929             elsif ( $reminder->Status eq $resolve_status
2930                 && !$args->{ 'Complete-Reminder-' . $reminder->id } )
2931             {
2932                 ( $status, $msg ) = $Ticket->Reminders->Open($reminder);
2933                 push @subresults, $msg;
2934             }
2935
2936             if (
2937                 exists( $args->{ 'Reminder-Subject-' . $reminder->id } )
2938                 && ( $reminder->Subject ne
2939                     $args->{ 'Reminder-Subject-' . $reminder->id } )
2940               )
2941             {
2942                 $old_subject = $reminder->Subject;
2943                 ( $status, $msg ) =
2944                   $reminder->SetSubject(
2945                     $args->{ 'Reminder-Subject-' . $reminder->id } );
2946                 push @subresults, $msg;
2947             }
2948
2949             if (
2950                 exists( $args->{ 'Reminder-Owner-' . $reminder->id } )
2951                 && ( $reminder->Owner !=
2952                     $args->{ 'Reminder-Owner-' . $reminder->id } )
2953               )
2954             {
2955                 ( $status, $msg ) =
2956                   $reminder->SetOwner(
2957                     $args->{ 'Reminder-Owner-' . $reminder->id }, "Force" );
2958                 push @subresults, $msg;
2959             }
2960
2961             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } )
2962                 && $args->{ 'Reminder-Due-' . $reminder->id } ne '' )
2963             {
2964                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2965                 my $due     = $args->{ 'Reminder-Due-' . $reminder->id };
2966
2967                 $DateObj->Set(
2968                     Format => 'unknown',
2969                     Value  => $due,
2970                 );
2971                 if ( $DateObj->Unix != $reminder->DueObj->Unix ) {
2972                     ( $status, $msg ) = $reminder->SetDue( $DateObj->ISO );
2973                 }
2974                 else {
2975                     $msg = loc( "invalid due date: [_1]", $due );
2976                 }
2977
2978                 push @subresults, $msg;
2979             }
2980
2981             push @results, map {
2982                 loc( "Reminder '[_1]': [_2]", $old_subject || $reminder->Subject, $_ )
2983             } @subresults;
2984         }
2985     }
2986
2987     if ( $args->{'NewReminder-Subject'} ) {
2988         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2989         $due_obj->Set(
2990           Format => 'unknown',
2991           Value => $args->{'NewReminder-Due'}
2992         );
2993         my ( $status, $msg ) = $Ticket->Reminders->Add(
2994             Subject => $args->{'NewReminder-Subject'},
2995             Owner   => $args->{'NewReminder-Owner'},
2996             Due     => $due_obj->ISO
2997         );
2998         if ( $status ) {
2999             push @results,
3000               loc( "Reminder '[_1]': [_2]", $args->{'NewReminder-Subject'}, loc("Created") )
3001         }
3002         else {
3003             push @results, $msg;
3004         }
3005     }
3006     return @results;
3007 }
3008
3009 sub ProcessObjectCustomFieldUpdates {
3010     my %args    = @_;
3011     my $ARGSRef = $args{'ARGSRef'};
3012     my @results;
3013
3014     # Build up a list of objects that we want to work with
3015     my %custom_fields_to_mod = _ParseObjectCustomFieldArgs($ARGSRef);
3016
3017     # For each of those objects
3018     foreach my $class ( keys %custom_fields_to_mod ) {
3019         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
3020             my $Object = $args{'Object'};
3021             $Object = $class->new( $session{'CurrentUser'} )
3022                 unless $Object && ref $Object eq $class;
3023
3024             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
3025             unless ( $Object->id ) {
3026                 $RT::Logger->warning("Couldn't load object $class #$id");
3027                 next;
3028             }
3029
3030             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
3031                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
3032                 $CustomFieldObj->SetContextObject($Object);
3033                 $CustomFieldObj->LoadById($cf);
3034                 unless ( $CustomFieldObj->id ) {
3035                     $RT::Logger->warning("Couldn't load custom field #$cf");
3036                     next;
3037                 }
3038                 my @groupings = sort keys %{ $custom_fields_to_mod{$class}{$id}{$cf} };
3039                 if (@groupings > 1) {
3040                     # Check for consistency, in case of JS fail
3041                     for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3042                         my $base = $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]}{$key};
3043                         $base = [ $base ] unless ref $base;
3044                         for my $grouping (@groupings[1..$#groupings]) {
3045                             my $other = $custom_fields_to_mod{$class}{$id}{$cf}{$grouping}{$key};
3046                             $other = [ $other ] unless ref $other;
3047                             warn "CF $cf submitted with multiple differing values"
3048                                 if grep {$_} List::MoreUtils::pairwise {
3049                                     no warnings qw(uninitialized);
3050                                     $a ne $b
3051                                 } @{$base}, @{$other};
3052                         }
3053                     }
3054                     # We'll just be picking the 1st grouping in the hash, alphabetically
3055                 }
3056                 push @results,
3057                     _ProcessObjectCustomFieldUpdates(
3058                         Prefix => GetCustomFieldInputNamePrefix(
3059                             Object      => $Object,
3060                             CustomField => $CustomFieldObj,
3061                             Grouping    => $groupings[0],
3062                         ),
3063                         Object      => $Object,
3064                         CustomField => $CustomFieldObj,
3065                         ARGS        => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] },
3066                     );
3067             }
3068         }
3069     }
3070     return @results;
3071 }
3072
3073 sub _ParseObjectCustomFieldArgs {
3074     my $ARGSRef = shift || {};
3075     my %custom_fields_to_mod;
3076
3077     foreach my $arg ( keys %$ARGSRef ) {
3078
3079         # format: Object-<object class>-<object id>-CustomField[:<grouping>]-<CF id>-<commands>
3080         # you can use GetCustomFieldInputName to generate the complement input name
3081         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField(?::(\w+))?-(\d+)-(.*)$/;
3082
3083         # For each of those objects, find out what custom fields we want to work with.
3084         #                   Class     ID     CF  grouping command
3085         $custom_fields_to_mod{$1}{ $2 || 0 }{$4}{$3 || ''}{$5} = $ARGSRef->{$arg};
3086     }
3087
3088     return wantarray ? %custom_fields_to_mod : \%custom_fields_to_mod;
3089 }
3090
3091 sub _ProcessObjectCustomFieldUpdates {
3092     my %args    = @_;
3093     my $cf      = $args{'CustomField'};
3094     my $cf_type = $cf->Type || '';
3095
3096     # Remove blank Values since the magic field will take care of this. Sometimes
3097     # the browser gives you a blank value which causes CFs to be processed twice
3098     if (   defined $args{'ARGS'}->{'Values'}
3099         && !length $args{'ARGS'}->{'Values'}
3100         && ($args{'ARGS'}->{'Values-Magic'}) )
3101     {
3102         delete $args{'ARGS'}->{'Values'};
3103     }
3104
3105     my @results;
3106     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
3107
3108         # skip category argument
3109         next if $arg =~ /-Category$/;
3110
3111         # since http won't pass in a form element with a null value, we need
3112         # to fake it
3113         if ( $arg =~ /-Magic$/ ) {
3114
3115             # We don't care about the magic, if there's really a values element;
3116             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
3117             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
3118
3119             # "Empty" values does not mean anything for Image and Binary fields
3120             next if $cf_type =~ /^(?:Image|Binary)$/;
3121
3122             $arg = 'Values';
3123             $args{'ARGS'}->{'Values'} = undef;
3124         }
3125
3126         my @values = _NormalizeObjectCustomFieldValue(
3127             CustomField => $cf,
3128             Param       => $args{'Prefix'} . $arg,
3129             Value       => $args{'ARGS'}->{$arg}
3130         );
3131
3132         # "Empty" values still don't mean anything for Image and Binary fields
3133         next if $cf_type =~ /^(?:Image|Binary)$/ and not @values;
3134
3135         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
3136             foreach my $value (@values) {
3137                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3138                     Field => $cf->id,
3139                     Value => $value
3140                 );
3141                 push( @results, $msg );
3142             }
3143         } elsif ( $arg eq 'Upload' ) {
3144             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %{$values[0]}, Field => $cf, );
3145             push( @results, $msg );
3146         } elsif ( $arg eq 'DeleteValues' ) {
3147             foreach my $value (@values) {
3148                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3149                     Field => $cf,
3150                     Value => $value,
3151                 );
3152                 push( @results, $msg );
3153             }
3154         } elsif ( $arg eq 'DeleteValueIds' ) {
3155             foreach my $value (@values) {
3156                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3157                     Field   => $cf,
3158                     ValueId => $value,
3159                 );
3160                 push( @results, $msg );
3161             }
3162         } elsif ( $arg eq 'Values' ) {
3163             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
3164
3165             my %values_hash;
3166             foreach my $value (@values) {
3167                 if ( my $entry = $cf_values->HasEntry($value) ) {
3168                     $values_hash{ $entry->id } = 1;
3169                     next;
3170                 }
3171
3172                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3173                     Field => $cf,
3174                     Value => $value
3175                 );
3176                 push( @results, $msg );
3177                 $values_hash{$val} = 1 if $val;
3178             }
3179
3180             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3181             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
3182
3183             $cf_values->RedoSearch;
3184             while ( my $cf_value = $cf_values->Next ) {
3185                 next if $values_hash{ $cf_value->id };
3186
3187                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3188                     Field   => $cf,
3189                     ValueId => $cf_value->id
3190                 );
3191                 push( @results, $msg );
3192             }
3193         } else {
3194             push(
3195                 @results,
3196                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
3197                     $cf->Name, ref $args{'Object'},
3198                     $args{'Object'}->id
3199                 )
3200             );
3201         }
3202     }
3203     return @results;
3204 }
3205
3206 sub ProcessObjectCustomFieldUpdatesForCreate {
3207     my %args = (
3208         ARGSRef         => {},
3209         ContextObject   => undef,
3210         @_
3211     );
3212     my $context = $args{'ContextObject'};
3213     my %parsed;
3214     my %custom_fields = _ParseObjectCustomFieldArgs( $args{'ARGSRef'} );
3215
3216     for my $class (keys %custom_fields) {
3217         # we're only interested in new objects, so only look at $id == 0
3218         for my $cfid (keys %{ $custom_fields{$class}{0} || {} }) {
3219             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3220             if ($context) {
3221                 my $system_cf = RT::CustomField->new( RT->SystemUser );
3222                 $system_cf->LoadById($cfid);
3223                 if ($system_cf->ValidateContextObject($context)) {
3224                     $cf->SetContextObject($context);
3225                 } else {
3226                     RT->Logger->error(
3227                         sprintf "Invalid context object %s (%d) for CF %d; skipping CF",
3228                                 ref $context, $context->id, $system_cf->id
3229                     );
3230                     next;
3231                 }
3232             }
3233             $cf->LoadById($cfid);
3234
3235             unless ($cf->id) {
3236                 RT->Logger->warning("Couldn't load custom field #$cfid");
3237                 next;
3238             }
3239
3240             my @groupings = sort keys %{ $custom_fields{$class}{0}{$cfid} };
3241             if (@groupings > 1) {
3242                 # Check for consistency, in case of JS fail
3243                 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3244                     warn "CF $cfid submitted with multiple differing $key"
3245                         if grep {($custom_fields{$class}{0}{$cfid}{$_}{$key} || '')
3246                              ne  ($custom_fields{$class}{0}{$cfid}{$groupings[0]}{$key} || '')}
3247                             @groupings;
3248                 }
3249                 # We'll just be picking the 1st grouping in the hash, alphabetically
3250             }
3251
3252             my @values;
3253             my $name_prefix = GetCustomFieldInputNamePrefix(
3254                 CustomField => $cf,
3255                 Grouping    => $groupings[0],
3256             );
3257             while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) {
3258                 # Values-Magic doesn't matter on create; no previous values are being removed
3259                 # Category is irrelevant for the actual value
3260                 next if $arg =~ /-Magic$/ or $arg =~ /-Category$/;
3261
3262                 push @values,
3263                     _NormalizeObjectCustomFieldValue(
3264                     CustomField => $cf,
3265                     Param       => $name_prefix . $arg,
3266                     Value       => $value,
3267                     );
3268             }
3269
3270             $parsed{"CustomField-$cfid"} = \@values if @values;
3271         }
3272     }
3273
3274     return wantarray ? %parsed : \%parsed;
3275 }
3276
3277 sub _NormalizeObjectCustomFieldValue {
3278     my %args    = (
3279         Param   => "",
3280         @_
3281     );
3282     my $cf_type = $args{CustomField}->Type;
3283     my @values  = ();
3284
3285     if ( ref $args{'Value'} eq 'ARRAY' ) {
3286         @values = @{ $args{'Value'} };
3287     } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
3288         @values = ( $args{'Value'} );
3289     } else {
3290         @values = split /\r*\n/, $args{'Value'}
3291             if defined $args{'Value'};
3292     }
3293     @values = grep length, map {
3294         s/\r+\n/\n/g;
3295         s/^\s+//;
3296         s/\s+$//;
3297         $_;
3298         }
3299         grep defined, @values;
3300
3301     if ($args{'Param'} =~ /-Upload$/ and $cf_type =~ /^(Image|Binary)$/) {
3302         @values = _UploadedFile( $args{'Param'} ) || ();
3303     }
3304
3305     return @values;
3306 }
3307
3308 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3309
3310 Returns an array of results messages.
3311
3312 =cut
3313
3314 sub ProcessTicketWatchers {
3315     my %args = (
3316         TicketObj => undef,
3317         ARGSRef   => undef,
3318         @_
3319     );
3320     my (@results);
3321
3322     my $Ticket  = $args{'TicketObj'};
3323     my $ARGSRef = $args{'ARGSRef'};
3324
3325     # Munge watchers
3326
3327     foreach my $key ( keys %$ARGSRef ) {
3328
3329         # Delete deletable watchers
3330         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
3331             my ( $code, $msg ) = $Ticket->DeleteWatcher(
3332                 PrincipalId => $2,
3333                 Type        => $1
3334             );
3335             push @results, $msg;
3336         }
3337
3338         # Delete watchers in the simple style demanded by the bulk manipulator
3339         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
3340             my ( $code, $msg ) = $Ticket->DeleteWatcher(
3341                 Email => $ARGSRef->{$key},
3342                 Type  => $1
3343             );
3344             push @results, $msg;
3345         }
3346
3347         # Add new wathchers by email address
3348         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
3349             and $key =~ /^WatcherTypeEmail(\d*)$/ )
3350         {
3351
3352             #They're in this order because otherwise $1 gets clobbered :/
3353             my ( $code, $msg ) = $Ticket->AddWatcher(
3354                 Type  => $ARGSRef->{$key},
3355                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
3356             );
3357             push @results, $msg;
3358         }
3359
3360         #Add requestors in the simple style demanded by the bulk manipulator
3361         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
3362             my ( $code, $msg ) = $Ticket->AddWatcher(
3363                 Type  => $1,
3364                 Email => $ARGSRef->{$key}
3365             );
3366             push @results, $msg;
3367         }
3368
3369         # Add new  watchers by owner
3370         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
3371             my $principal_id = $1;
3372             my $form         = $ARGSRef->{$key};
3373             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
3374                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
3375
3376                 my ( $code, $msg ) = $Ticket->AddWatcher(
3377                     Type        => $value,
3378                     PrincipalId => $principal_id
3379                 );
3380                 push @results, $msg;
3381             }
3382         }
3383
3384     }
3385     return (@results);
3386 }
3387
3388
3389
3390 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3391
3392 Returns an array of results messages.
3393
3394 =cut
3395
3396 sub ProcessTicketDates {
3397     my %args = (
3398         TicketObj => undef,
3399         ARGSRef   => undef,
3400         @_
3401     );
3402
3403     my $Ticket  = $args{'TicketObj'};
3404     my $ARGSRef = $args{'ARGSRef'};
3405
3406     my (@results);
3407
3408     # Set date fields
3409     my @date_fields = qw(
3410         Told
3411         Starts
3412         Started
3413         Due
3414     );
3415
3416     #Run through each field in this list. update the value if apropriate
3417     foreach my $field (@date_fields) {
3418         next unless exists $ARGSRef->{ $field . '_Date' };
3419         next if $ARGSRef->{ $field . '_Date' } eq '';
3420
3421         my ( $code, $msg );
3422
3423         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3424         $DateObj->Set(
3425             Format => 'unknown',
3426             Value  => $ARGSRef->{ $field . '_Date' }
3427         );
3428
3429         my $obj = $field . "Obj";
3430         if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) {
3431             my $method = "Set$field";
3432             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3433             push @results, "$msg";
3434         }
3435     }
3436
3437     # }}}
3438     return (@results);
3439 }
3440
3441
3442
3443 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3444
3445 Returns an array of results messages.
3446
3447 =cut
3448
3449 sub ProcessTicketLinks {
3450     my %args = (
3451         TicketObj => undef,
3452         TicketId  => undef,
3453         ARGSRef   => undef,
3454         @_
3455     );
3456
3457     my $Ticket  = $args{'TicketObj'};
3458     my $TicketId = $args{'TicketId'} || $Ticket->Id;
3459     my $ARGSRef = $args{'ARGSRef'};
3460
3461     my (@results) = ProcessRecordLinks(
3462         %args, RecordObj => $Ticket, RecordId => $TicketId, ARGSRef => $ARGSRef,
3463     );
3464
3465     #Merge if we need to
3466     my $input = $TicketId .'-MergeInto';
3467     if ( $ARGSRef->{ $input } ) {
3468         $ARGSRef->{ $input } =~ s/\s+//g;
3469         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $input } );
3470         push @results, $msg;
3471     }
3472
3473     return (@results);
3474 }
3475
3476
3477 sub ProcessRecordLinks {
3478     my %args = (
3479         RecordObj => undef,
3480         RecordId  => undef,
3481         ARGSRef   => undef,
3482         @_
3483     );
3484
3485     my $Record  = $args{'RecordObj'};
3486     my $RecordId = $args{'RecordId'} || $Record->Id;
3487     my $ARGSRef = $args{'ARGSRef'};
3488
3489     my (@results);
3490
3491     # Delete links that are gone gone gone.
3492     foreach my $arg ( keys %$ARGSRef ) {
3493         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3494             my $base   = $1;
3495             my $type   = $2;
3496             my $target = $3;
3497
3498             my ( $val, $msg ) = $Record->DeleteLink(
3499                 Base   => $base,
3500                 Type   => $type,
3501                 Target => $target
3502             );
3503
3504             push @results, $msg;
3505
3506         }
3507
3508     }
3509
3510     my @linktypes = qw( DependsOn MemberOf RefersTo );
3511
3512     foreach my $linktype (@linktypes) {
3513         my $input = $RecordId .'-'. $linktype;
3514         if ( $ARGSRef->{ $input } ) {
3515             $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3516                 if ref $ARGSRef->{ $input };
3517
3518             for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3519                 next unless $luri;
3520                 $luri =~ s/\s+$//;    # Strip trailing whitespace
3521                 my ( $val, $msg ) = $Record->AddLink(
3522                     Target => $luri,
3523                     Type   => $linktype
3524                 );
3525                 push @results, $msg;
3526             }
3527         }
3528         $input = $linktype .'-'. $RecordId;
3529         if ( $ARGSRef->{ $input } ) {
3530             $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3531                 if ref $ARGSRef->{ $input };
3532
3533             for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3534                 next unless $luri;
3535                 my ( $val, $msg ) = $Record->AddLink(
3536                     Base => $luri,
3537                     Type => $linktype
3538                 );
3539
3540                 push @results, $msg;
3541             }
3542         }
3543     }
3544
3545     return (@results);
3546 }
3547
3548 =head2 ProcessLinksForCreate
3549
3550 Takes a hash with a single key, C<ARGSRef>, the value of which is a hashref to
3551 C<%ARGS>.
3552
3553 Converts and returns submitted args in the form of C<new-LINKTYPE> and
3554 C<LINKTYPE-new> into their appropriate directional link types.  For example,
3555 C<new-DependsOn> becomes C<DependsOn> and C<DependsOn-new> becomes
3556 C<DependedOnBy>.  The incoming arg values are split on whitespace and
3557 normalized into arrayrefs before being returned.
3558
3559 Primarily used by object creation pages for transforming incoming form inputs
3560 from F</Elements/EditLinks> into arguments appropriate for individual record
3561 Create methods.
3562
3563 Returns a hashref in scalar context and a hash in list context.
3564
3565 =cut
3566
3567 sub ProcessLinksForCreate {
3568     my %args = @_;
3569     my %links;
3570
3571     foreach my $type ( keys %RT::Link::DIRMAP ) {
3572         for ([Base => "new-$type"], [Target => "$type-new"]) {
3573             my ($direction, $key) = @$_;
3574             next unless $args{ARGSRef}->{$key};
3575             $links{ $RT::Link::DIRMAP{$type}->{$direction} } = [
3576                 grep $_, split ' ', $args{ARGSRef}->{$key}
3577             ];
3578         }
3579     }
3580     return wantarray ? %links : \%links;
3581 }
3582
3583 =head2 ProcessTransactionSquelching
3584
3585 Takes a hashref of the submitted form arguments, C<%ARGS>.
3586
3587 Returns a hash of squelched addresses.
3588
3589 =cut
3590
3591 sub ProcessTransactionSquelching {
3592     my $args    = shift;
3593     my %checked = map { $_ => 1 } grep { defined }
3594         (    ref $args->{'TxnSendMailTo'} eq "ARRAY"  ? @{$args->{'TxnSendMailTo'}} :
3595          defined $args->{'TxnSendMailTo'}             ?  ($args->{'TxnSendMailTo'}) :
3596                                                                              () );
3597     my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3598     return %squelched;
3599 }
3600
3601 sub ProcessRecordBulkCustomFields {
3602     my %args = (RecordObj => undef, ARGSRef => {}, @_);
3603
3604     my $ARGSRef = $args{'ARGSRef'};
3605
3606     my %data;
3607
3608     my @results;
3609     foreach my $key ( keys %$ARGSRef ) {
3610         next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/;
3611         my ($op, $cfid, $rest) = ($1, $2, $3);
3612         next if $rest =~ /-Category$/;
3613
3614         my $res = $data{$cfid} ||= {};
3615         unless (keys %$res) {
3616             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3617             $cf->Load( $cfid );
3618             next unless $cf->Id;
3619
3620             $res->{'cf'} = $cf;
3621         }
3622