rt/lib/RT/Interface/Web.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2017 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_blessed => 1, 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       unless $HTML::Mason::Commands::r->content_type
 379                =~ qr<^(text|application)/(x-)?(css|javascript)>;
 380 }
 381
 382 sub _ForceLogout {
 383
 384     delete $HTML::Mason::Commands::session{'CurrentUser'};
 385 }
 386
 387 sub _UserLoggedIn {
 388     if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
 389         return 1;
 390     } else {
 391         return undef;
 392     }
 393
 394 }
 395
 396 =head2 LoginError ERROR
 397
 398 Pushes a login error into the Actions session store and returns the hash key.
 399
 400 =cut
 401
 402 sub LoginError {
 403     my $new = shift;
 404     my $key = Digest::MD5::md5_hex( rand(1024) );
 405     push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
 406     $HTML::Mason::Commands::session{'i'}++;
 407     return $key;
 408 }
 409
 410 =head2 SetNextPage ARGSRef [PATH]
 411
 412 Intuits and stashes the next page in the sesssion hash.  If PATH is
 413 specified, uses that instead of the value of L<IntuitNextPage()>.  Returns
 414 the hash value.
 415
 416 =cut
 417
 418 sub SetNextPage {
 419     my $ARGS = shift;
 420     my $next = $_[0] ? $_[0] : IntuitNextPage();
 421     my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
 422     my $page = { url => $next };
 423
 424     # If an explicit URL was passed and we didn't IntuitNextPage, then
 425     # IsPossibleCSRF below is almost certainly unrelated to the actual
 426     # destination.  Currently explicit next pages aren't used in RT, but the
 427     # API is available.
 428     if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
 429         # This isn't really CSRF, but the CSRF heuristics are useful for catching
 430         # requests which may have unintended side-effects.
 431         my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
 432         if ($is_csrf) {
 433             RT->Logger->notice(
 434                 "Marking original destination as having side-effects before redirecting for login.\n"
 435                ."Request: $next\n"
 436                ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
 437             );
 438             $page->{'HasSideEffects'} = [$msg, @loc];
 439         }
 440     }
 441
 442     $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
 443     $HTML::Mason::Commands::session{'i'}++;
 444     return $hash;
 445 }
 446
 447 =head2 FetchNextPage HASHKEY
 448
 449 Returns the stashed next page hashref for the given hash.
 450
 451 =cut
 452
 453 sub FetchNextPage {
 454     my $hash = shift || "";
 455     return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
 456 }
 457
 458 =head2 RemoveNextPage HASHKEY
 459
 460 Removes the stashed next page for the given hash and returns it.
 461
 462 =cut
 463
 464 sub RemoveNextPage {
 465     my $hash = shift || "";
 466     return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
 467 }
 468
 469 =head2 TangentForLogin ARGSRef [HASH]
 470
 471 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
 472 the next page.  Takes a hashref of request %ARGS as the first parameter.
 473 Optionally takes all other parameters as a hash which is dumped into query
 474 params.
 475
 476 =cut
 477
 478 sub TangentForLogin {
 479     my $login = TangentForLoginURL(@_);
 480     Redirect( RT->Config->Get('WebBaseURL') . $login );
 481 }
 482
 483 =head2 TangentForLoginURL [HASH]
 484
 485 Returns a URL suitable for tangenting for login.  Optionally takes a hash which
 486 is dumped into query params.
 487
 488 =cut
 489
 490 sub TangentForLoginURL {
 491     my $ARGS  = shift;
 492     my $hash  = SetNextPage($ARGS);
 493     my %query = (@_, next => $hash);
 494
 495     $query{mobile} = 1
 496         if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
 497
 498     my $login = RT->Config->Get('WebPath') . '/NoAuth/Login.html?';
 499     $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
 500     return $login;
 501 }
 502
 503 =head2 TangentForLoginWithError ERROR
 504
 505 Localizes the passed error message, stashes it with L<LoginError> and then
 506 calls L<TangentForLogin> with the appropriate results key.
 507
 508 =cut
 509
 510 sub TangentForLoginWithError {
 511     my $ARGS = shift;
 512     my $key  = LoginError(HTML::Mason::Commands::loc(@_));
 513     TangentForLogin( $ARGS, results => $key );
 514 }
 515
 516 =head2 IntuitNextPage
 517
 518 Attempt to figure out the path to which we should return the user after a
 519 tangent.  The current request URL is used, or failing that, the C<WebURL>
 520 configuration variable.
 521
 522 =cut
 523
 524 sub IntuitNextPage {
 525     my $req_uri;
 526
 527     # This includes any query parameters.  Redirect will take care of making
 528     # it an absolute URL.
 529     if ($ENV{'REQUEST_URI'}) {
 530         $req_uri = $ENV{'REQUEST_URI'};
 531
 532         # collapse multiple leading slashes so the first part doesn't look like
 533         # a hostname of a schema-less URI
 534         $req_uri =~ s{^/+}{/};
 535     }
 536
 537     my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
 538
 539     # sanitize $next
 540     my $uri = URI->new($next);
 541
 542     # You get undef scheme with a relative uri like "/Search/Build.html"
 543     unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
 544         $next = RT->Config->Get('WebURL');
 545     }
 546
 547     # Make sure we're logging in to the same domain
 548     # You can get an undef authority with a relative uri like "index.html"
 549     my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
 550     unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
 551         $next = RT->Config->Get('WebURL');
 552     }
 553
 554     return $next;
 555 }
 556
 557 =head2 MaybeShowInstallModePage
 558
 559 This function, called exclusively by RT's autohandler, dispatches
 560 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
 561
 562 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
 563
 564 =cut
 565
 566 sub MaybeShowInstallModePage {
 567     return unless RT->InstallMode;
 568
 569     my $m = $HTML::Mason::Commands::m;
 570     if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
 571         $m->call_next();
 572     } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
 573         RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
 574     } else {
 575         $m->call_next();
 576     }
 577     $m->abort();
 578 }
 579
 580 =head2 MaybeShowNoAuthPage  \%ARGS
 581
 582 This function, called exclusively by RT's autohandler, dispatches
 583 a request to the page a user requested (but only if it matches the "noauth" regex.
 584
 585 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
 586
 587 =cut
 588
 589 sub MaybeShowNoAuthPage {
 590     my $ARGS = shift;
 591
 592     my $m = $HTML::Mason::Commands::m;
 593
 594     return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
 595
 596     # Don't show the login page to logged in users
 597     Redirect(RT->Config->Get('WebURL'))
 598         if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
 599
 600     # If it's a noauth file, don't ask for auth.
 601     $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
 602     $m->abort;
 603 }
 604
 605 =head2 MaybeRejectPrivateComponentRequest
 606
 607 This function will reject calls to private components, like those under
 608 C</Elements>. If the requested path is a private component then we will
 609 abort with a C<403> error.
 610
 611 =cut
 612
 613 sub MaybeRejectPrivateComponentRequest {
 614     my $m = $HTML::Mason::Commands::m;
 615     my $path = $m->request_comp->path;
 616
 617     # We do not check for dhandler here, because requesting our dhandlers
 618     # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
 619     # 'dhandler'.
 620
 621     if ($path =~ m{
 622             / # leading slash
 623             ( Elements    |
 624               _elements   | # mobile UI
 625               Callbacks   |
 626               Widgets     |
 627               autohandler | # requesting this directly is suspicious
 628               l (_unsafe)? ) # loc component
 629             ( $ | / ) # trailing slash or end of path
 630         }xi
 631         && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
 632       )
 633     {
 634             warn "rejecting private component $path\n";
 635             $m->abort(403);
 636     }
 637
 638     return;
 639 }
 640
 641 sub InitializeMenu {
 642     $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
 643     $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
 644     $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
 645
 646 }
 647
 648
 649 =head2 ShowRequestedPage  \%ARGS
 650
 651 This function, called exclusively by RT's autohandler, dispatches
 652 a request to the page a user requested (making sure that unpriviled users
 653 can only see self-service pages.
 654
 655 =cut
 656
 657 sub ShowRequestedPage {
 658     my $ARGS = shift;
 659
 660     my $m = $HTML::Mason::Commands::m;
 661
 662     # Ensure that the cookie that we send is up-to-date, in case the
 663     # session-id has been modified in any way
 664     SendSessionCookie();
 665
 666     # precache all system level rights for the current user
 667     $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
 668
 669     # If the user isn't privileged, they can only see SelfService
 670     unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
 671
 672         # if the user is trying to access a ticket, redirect them
 673         if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
 674             RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
 675         }
 676
 677         # otherwise, drop the user at the SelfService default page
 678         elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
 679             RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
 680         }
 681
 682         # if user is in SelfService dir let him do anything
 683         else {
 684             $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
 685         }
 686     } else {
 687         $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
 688     }
 689
 690 }
 691
 692 sub AttemptExternalAuth {
 693     my $ARGS = shift;
 694
 695     return unless ( RT->Config->Get('WebRemoteUserAuth') );
 696
 697     my $user = $ARGS->{user};
 698     my $m    = $HTML::Mason::Commands::m;
 699
 700     my $logged_in_external_user = _UserLoggedIn() && $HTML::Mason::Commands::session{'WebExternallyAuthed'};
 701
 702     # If RT is configured for external auth, let's go through and get REMOTE_USER
 703
 704     # Do we actually have a REMOTE_USER or equivalent?  We only check auth if
 705     # 1) we have no logged in user, or 2) we have a user who is externally
 706     # authed.  If we have a logged in user who is internally authed, don't
 707     # check remote user otherwise we may log them out.
 708     if (RT::Interface::Web::WebCanonicalizeInfo()
 709         and (not _UserLoggedIn() or $logged_in_external_user) )
 710     {
 711         $user = RT::Interface::Web::WebCanonicalizeInfo();
 712         my $load_method = RT->Config->Get('WebRemoteUserGecos') ? 'LoadByGecos' : 'Load';
 713
 714         my $next = RemoveNextPage($ARGS->{'next'});
 715            $next = $next->{'url'} if ref $next;
 716         InstantiateNewSession() unless _UserLoggedIn;
 717         $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
 718         $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
 719
 720         if ( RT->Config->Get('WebRemoteUserAutocreate') and not _UserLoggedIn() ) {
 721
 722             # Create users on-the-fly
 723             my $UserObj = RT::User->new(RT->SystemUser);
 724             my ( $val, $msg ) = $UserObj->Create(
 725                 %{ ref RT->Config->Get('UserAutocreateDefaultsOnLogin') ? RT->Config->Get('UserAutocreateDefaultsOnLogin') : {} },
 726                 Name  => $user,
 727                 Gecos => $user,
 728             );
 729
 730             if ($val) {
 731
 732                 # now get user specific information, to better create our user.
 733                 my $new_user_info = RT::Interface::Web::WebRemoteUserAutocreateInfo($user);
 734
 735                 # set the attributes that have been defined.
 736                 foreach my $attribute ( $UserObj->WritableAttributes, qw(Privileged Disabled) ) {
 737                     $m->callback(
 738                         Attribute    => $attribute,
 739                         User         => $user,
 740                         UserInfo     => $new_user_info,
 741                         CallbackName => 'NewUser',
 742                         CallbackPage => '/autohandler'
 743                     );
 744                     my $method = "Set$attribute";
 745                     $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
 746                 }
 747                 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
 748             } else {
 749                 RT->Logger->error("Couldn't auto-create user '$user' when attempting WebRemoteUser: $msg");
 750                 AbortExternalAuth( Error => "UserAutocreateDefaultsOnLogin" );
 751             }
 752         }
 753
 754         if ( _UserLoggedIn() ) {
 755             $HTML::Mason::Commands::session{'WebExternallyAuthed'} = 1;
 756             $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
 757             # It is possible that we did a redirect to the login page,
 758             # if the external auth allows lack of auth through with no
 759             # REMOTE_USER set, instead of forcing a "permission
 760             # denied" message.  Honor the $next.
 761             Redirect($next) if $next;
 762             # Unlike AttemptPasswordAuthentication below, we do not
 763             # force a redirect to / if $next is not set -- otherwise,
 764             # straight-up external auth would always redirect to /
 765             # when you first hit it.
 766         } else {
 767             # Couldn't auth with the REMOTE_USER provided because an RT
 768             # user doesn't exist and we're configured not to create one.
 769             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.");
 770             AbortExternalAuth(
 771                 Error => "NoInternalUser",
 772                 User  => $user,
 773             );
 774         }
 775     }
 776     elsif ($logged_in_external_user) {
 777         # The logged in external user was deauthed by the auth system and we
 778         # should kick them out.
 779         AbortExternalAuth( Error => "Deauthorized" );
 780     }
 781     elsif (not RT->Config->Get('WebFallbackToRTLogin')) {
 782         # Abort if we don't want to fallback internally
 783         AbortExternalAuth( Error => "NoRemoteUser" );
 784     }
 785 }
 786
 787 sub AbortExternalAuth {
 788     my %args  = @_;
 789     my $error = $args{Error} ? "/Errors/WebRemoteUser/$args{Error}" : undef;
 790     my $m     = $HTML::Mason::Commands::m;
 791     my $r     = $HTML::Mason::Commands::r;
 792
 793     _ForceLogout();
 794
 795     # Clear the decks, not that we should have partial content.
 796     $m->clear_buffer;
 797
 798     $r->status(403);
 799     $m->comp($error, %args)
 800         if $error and $m->comp_exists($error);
 801
 802     # Return a 403 Forbidden or we may fallback to a login page with no form
 803     $m->abort(403);
 804 }
 805
 806 sub AttemptPasswordAuthentication {
 807     my $ARGS = shift;
 808     return unless defined $ARGS->{user} && defined $ARGS->{pass};
 809
 810     my $user_obj = RT::CurrentUser->new();
 811     $user_obj->Load( $ARGS->{user} );
 812
 813     my $m = $HTML::Mason::Commands::m;
 814
 815     unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
 816         $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
 817         $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
 818         return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
 819     }
 820     else {
 821         $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
 822
 823         # It's important to nab the next page from the session before we blow
 824         # the session away
 825         my $next = RemoveNextPage($ARGS->{'next'});
 826            $next = $next->{'url'} if ref $next;
 827
 828         InstantiateNewSession();
 829         $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
 830
 831         $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler', RedirectTo => \$next );
 832
 833         # Really the only time we don't want to redirect here is if we were
 834         # passed user and pass as query params in the URL.
 835         if ($next) {
 836             Redirect($next);
 837         }
 838         elsif ($ARGS->{'next'}) {
 839             # Invalid hash, but still wants to go somewhere, take them to /
 840             Redirect(RT->Config->Get('WebURL'));
 841         }
 842
 843         return (1, HTML::Mason::Commands::loc('Logged in'));
 844     }
 845 }
 846
 847 =head2 LoadSessionFromCookie
 848
 849 Load or setup a session cookie for the current user.
 850
 851 =cut
 852
 853 sub _SessionCookieName {
 854     my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
 855     $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
 856     return $cookiename;
 857 }
 858
 859 sub LoadSessionFromCookie {
 860
 861     my %cookies       = CGI::Cookie->fetch;
 862     my $cookiename    = _SessionCookieName();
 863     my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
 864     tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
 865     unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
 866         InstantiateNewSession();
 867     }
 868     if ( int RT->Config->Get('AutoLogoff') ) {
 869         my $now = int( time / 60 );
 870         my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
 871
 872         if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
 873             InstantiateNewSession();
 874         }
 875
 876         # save session on each request when AutoLogoff is turned on
 877         $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
 878     }
 879 }
 880
 881 sub InstantiateNewSession {
 882     tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
 883     tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
 884     SendSessionCookie();
 885 }
 886
 887 sub SendSessionCookie {
 888     my $cookie = CGI::Cookie->new(
 889         -name     => _SessionCookieName(),
 890         -value    => $HTML::Mason::Commands::session{_session_id},
 891         -path     => RT->Config->Get('WebPath'),
 892         -secure   => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
 893         -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
 894     );
 895
 896     $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
 897 }
 898
 899 =head2 GetWebURLFromRequest
 900
 901 People may use different web urls instead of C<$WebURL> in config.
 902 Return the web url current user is using.
 903
 904 =cut
 905
 906 sub GetWebURLFromRequest {
 907
 908     my $uri = URI->new( RT->Config->Get('WebURL') );
 909
 910     if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
 911         $uri->scheme('https');
 912     }
 913     else {
 914         $uri->scheme('http');
 915     }
 916
 917     # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
 918     $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'} );
 919     $uri->port( $ENV{'SERVER_PORT'} );
 920     return "$uri"; # stringify to be consistent with WebURL in config
 921 }
 922
 923 =head2 Redirect URL
 924
 925 This routine ells the current user's browser to redirect to URL.
 926 Additionally, it unties the user's currently active session, helping to avoid
 927 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
 928 a cached DBI statement handle twice at the same time.
 929
 930 =cut
 931
 932 sub Redirect {
 933     my $redir_to = shift;
 934     untie $HTML::Mason::Commands::session;
 935     my $uri        = URI->new($redir_to);
 936     my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
 937
 938     # Make relative URIs absolute from the server host and scheme
 939     $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
 940     if (not defined $uri->host) {
 941         $uri->host($server_uri->host);
 942         $uri->port($server_uri->port);
 943     }
 944
 945     # If the user is coming in via a non-canonical
 946     # hostname, don't redirect them to the canonical host,
 947     # it will just upset them (and invalidate their credentials)
 948     # don't do this if $RT::CanonicalizeRedirectURLs is true
 949     if (   !RT->Config->Get('CanonicalizeRedirectURLs')
 950         && $uri->host eq $server_uri->host
 951         && $uri->port eq $server_uri->port )
 952     {
 953         my $env_uri = URI->new(GetWebURLFromRequest());
 954         $uri->scheme($env_uri->scheme);
 955         $uri->host($env_uri->host);
 956         $uri->port($env_uri->port);
 957     }
 958
 959     # not sure why, but on some systems without this call mason doesn't
 960     # set status to 302, but 200 instead and people see blank pages
 961     $HTML::Mason::Commands::r->status(302);
 962
 963     # Perlbal expects a status message, but Mason's default redirect status
 964     # doesn't provide one. See also rt.cpan.org #36689.
 965     $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
 966
 967     $HTML::Mason::Commands::m->abort;
 968 }
 969
 970 =head2 GetStaticHeaders
 971
 972 return an arrayref of Headers (currently, Cache-Control and Expires).
 973
 974 =cut
 975
 976 sub GetStaticHeaders {
 977     my %args = @_;
 978
 979     my $Visibility = 'private';
 980     if ( ! defined $args{Time} ) {
 981         $args{Time} = 0;
 982     } elsif ( $args{Time} eq 'no-cache' ) {
 983         $args{Time} = 0;
 984     } elsif ( $args{Time} eq 'forever' ) {
 985         $args{Time} = 30 * 24 * 60 * 60;
 986         $Visibility = 'public';
 987     }
 988
 989     my $CacheControl = $args{Time}
 990         ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
 991         : 'no-cache'
 992     ;
 993
 994     my $expires = RT::Date->new(RT->SystemUser);
 995     $expires->SetToNow;
 996     $expires->AddSeconds( $args{Time} ) if $args{Time};
 997
 998     return [
 999         Expires => $expires->RFC2616,
1000         'Cache-Control' => $CacheControl,
1001     ];
1002 }
1003
1004 =head2 CacheControlExpiresHeaders
1005
1006 set both Cache-Control and Expires http headers
1007
1008 =cut
1009
1010 sub CacheControlExpiresHeaders {
1011     Plack::Util::header_iter( GetStaticHeaders(@_), sub {
1012         my ( $key, $val ) = @_;
1013         $HTML::Mason::Commands::r->headers_out->{$key} = $val;
1014     } );
1015 }
1016
1017 =head2 StaticFileHeaders
1018
1019 Send the browser a few headers to try to get it to (somewhat agressively)
1020 cache RT's static Javascript and CSS files.
1021
1022 This routine could really use _accurate_ heuristics. (XXX TODO)
1023
1024 =cut
1025
1026 sub StaticFileHeaders {
1027     # remove any cookie headers -- if it is cached publicly, it
1028     # shouldn't include anyone's cookie!
1029     delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
1030
1031     # Expire things in a month.
1032     CacheControlExpiresHeaders( Time => 'forever' );
1033 }
1034
1035 =head2 ComponentPathIsSafe PATH
1036
1037 Takes C<PATH> and returns a boolean indicating that the user-specified partial
1038 component path is safe.
1039
1040 Currently "safe" means that the path does not start with a dot (C<.>), does
1041 not contain a slash-dot C</.>, and does not contain any nulls.
1042
1043 =cut
1044
1045 sub ComponentPathIsSafe {
1046     my $self = shift;
1047     my $path = shift;
1048     return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
1049 }
1050
1051 =head2 PathIsSafe
1052
1053 Takes a C<< Path => path >> and returns a boolean indicating that
1054 the path is safely within RT's control or not. The path I<must> be
1055 relative.
1056
1057 This function does not consult the filesystem at all; it is merely
1058 a logical sanity checking of the path. This explicitly does not handle
1059 symlinks; if you have symlinks in RT's webroot pointing outside of it,
1060 then we assume you know what you are doing.
1061
1062 =cut
1063
1064 sub PathIsSafe {
1065     my $self = shift;
1066     my %args = @_;
1067     my $path = $args{Path};
1068
1069     # Get File::Spec to clean up extra /s, ./, etc
1070     my $cleaned_up = File::Spec->canonpath($path);
1071
1072     if (!defined($cleaned_up)) {
1073         $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
1074         return 0;
1075     }
1076
1077     # Forbid too many ..s. We can't just sum then check because
1078     # "../foo/bar/baz" should be illegal even though it has more
1079     # downdirs than updirs. So as soon as we get a negative score
1080     # (which means "breaking out" of the top level) we reject the path.
1081
1082     my @components = split '/', $cleaned_up;
1083     my $score = 0;
1084     for my $component (@components) {
1085         if ($component eq '..') {
1086             $score--;
1087             if ($score < 0) {
1088                 $RT::Logger->info("Rejecting unsafe path: $path");
1089                 return 0;
1090             }
1091         }
1092         elsif ($component eq '.' || $component eq '') {
1093             # these two have no effect on $score
1094         }
1095         else {
1096             $score++;
1097         }
1098     }
1099
1100     return 1;
1101 }
1102
1103 =head2 SendStaticFile
1104
1105 Takes a File => path and a Type => Content-type
1106
1107 If Type isn't provided and File is an image, it will
1108 figure out a sane Content-type, otherwise it will
1109 send application/octet-stream
1110
1111 Will set caching headers using StaticFileHeaders
1112
1113 =cut
1114
1115 sub SendStaticFile {
1116     my $self = shift;
1117     my %args = @_;
1118     my $file = $args{File};
1119     my $type = $args{Type};
1120     my $relfile = $args{RelativeFile};
1121
1122     if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
1123         $HTML::Mason::Commands::r->status(400);
1124         $HTML::Mason::Commands::m->abort;
1125     }
1126
1127     $self->StaticFileHeaders();
1128
1129     unless ($type) {
1130         if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1131             $type = "image/$1";
1132             $type =~ s/jpg/jpeg/gi;
1133         }
1134         $type ||= "application/octet-stream";
1135     }
1136     $HTML::Mason::Commands::r->content_type($type);
1137     open( my $fh, '<', $file ) or die "couldn't open file: $!";
1138     binmode($fh);
1139     {
1140         local $/ = \16384;
1141         $HTML::Mason::Commands::m->out($_) while (<$fh>);
1142         $HTML::Mason::Commands::m->flush_buffer;
1143     }
1144     close $fh;
1145 }
1146
1147
1148
1149 sub MobileClient {
1150     my $self = shift;
1151
1152
1153 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'})  {
1154     return 1;
1155 } else {
1156     return undef;
1157 }
1158
1159 }
1160
1161
1162 sub StripContent {
1163     my %args    = @_;
1164     my $content = $args{Content};
1165     return '' unless $content;
1166
1167     # Make the content have no 'weird' newlines in it
1168     $content =~ s/\r+\n/\n/g;
1169
1170     my $return_content = $content;
1171
1172     my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1173     my $sigonly = $args{StripSignature};
1174
1175     # massage content to easily detect if there's any real content
1176     $content =~ s/\s+//g; # yes! remove all the spaces
1177     if ( $html ) {
1178         # remove html version of spaces and newlines
1179         $content =~ s!&nbsp;!!g;
1180         $content =~ s!<br/?>!!g;
1181     }
1182
1183     # Filter empty content when type is text/html
1184     return '' if $html && $content !~ /\S/;
1185
1186     # If we aren't supposed to strip the sig, just bail now.
1187     return $return_content unless $sigonly;
1188
1189     # Find the signature
1190     my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1191     $sig =~ s/\s+//g;
1192
1193     # Check for plaintext sig
1194     return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1195
1196     # Check for html-formatted sig; we don't use EscapeHTML here
1197     # because we want to precisely match the escapting that FCKEditor
1198     # uses.
1199     $sig =~ s/&/&amp;/g;
1200     $sig =~ s/</&lt;/g;
1201     $sig =~ s/>/&gt;/g;
1202     $sig =~ s/"/&quot;/g;
1203     $sig =~ s/'/&#39;/g;
1204     return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1205
1206     # Pass it through
1207     return $return_content;
1208 }
1209
1210 sub DecodeARGS {
1211     my $ARGS = shift;
1212
1213     # Later in the code we use
1214     # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1215     # instead of $m->call_next to avoid problems with UTF8 keys in
1216     # arguments.  Specifically, the call_next method pass through
1217     # original arguments, which are still the encoded bytes, not
1218     # characters.  "{ base_comp => $m->request_comp }" is copied from
1219     # mason's source to get the same results as we get from call_next
1220     # method; this feature is not documented.
1221     %{$ARGS} = map {
1222
1223         # if they've passed multiple values, they'll be an array. if they've
1224         # passed just one, a scalar whatever they are, mark them as utf8
1225         my $type = ref($_);
1226         ( !$type )
1227             ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ )
1228             : ( $type eq 'ARRAY' )
1229             ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ]
1230             : ( $type eq 'HASH' )
1231             ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ }
1232             : $_
1233     } %$ARGS;
1234 }
1235
1236 sub PreprocessTimeUpdates {
1237     my $ARGS = shift;
1238
1239     # This code canonicalizes time inputs in hours into minutes
1240     foreach my $field ( keys %$ARGS ) {
1241         next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1242         my $local = $1;
1243         $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1244                       {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1245         if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1246             $ARGS->{$local} *= 60;
1247         }
1248         delete $ARGS->{$field};
1249     }
1250
1251 }
1252
1253 sub MaybeEnableSQLStatementLog {
1254
1255     my $log_sql_statements = RT->Config->Get('StatementLog');
1256
1257     if ($log_sql_statements) {
1258         $RT::Handle->ClearSQLStatementLog;
1259         $RT::Handle->LogSQLStatements(1);
1260     }
1261
1262 }
1263
1264 sub LogRecordedSQLStatements {
1265     my %args = @_;
1266
1267     my $log_sql_statements = RT->Config->Get('StatementLog');
1268
1269     return unless ($log_sql_statements);
1270
1271     my @log = $RT::Handle->SQLStatementLog;
1272     $RT::Handle->ClearSQLStatementLog;
1273
1274     $RT::Handle->AddRequestToHistory({
1275         %{ $args{RequestData} },
1276         Queries => \@log,
1277     });
1278
1279     for my $stmt (@log) {
1280         my ( $time, $sql, $bind, $duration ) = @{$stmt};
1281         my @bind;
1282         if ( ref $bind ) {
1283             @bind = @{$bind};
1284         } else {
1285
1286             # Older DBIx-SB
1287             $duration = $bind;
1288         }
1289         $RT::Logger->log(
1290             level   => $log_sql_statements,
1291             message => "SQL("
1292                 . sprintf( "%.6f", $duration )
1293                 . "s): $sql;"
1294                 . ( @bind ? "  [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1295         );
1296     }
1297
1298 }
1299
1300 my $_has_validated_web_config = 0;
1301 sub ValidateWebConfig {
1302     my $self = shift;
1303
1304     # do this once per server instance, not once per request
1305     return if $_has_validated_web_config;
1306     $_has_validated_web_config = 1;
1307
1308     my $port = $ENV{SERVER_PORT};
1309     my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
1310             || $ENV{HTTP_HOST}             || $ENV{SERVER_NAME};
1311     ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
1312
1313     if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
1314         $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort).  "
1315                          ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
1316                          ."otherwise your internal hyperlinks may be broken.");
1317     }
1318
1319     if ( $host ne RT->Config->Get('WebDomain') ) {
1320         $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain).  "
1321                          ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
1322                          ."otherwise your internal hyperlinks may be broken.");
1323     }
1324
1325     return; #next warning flooding our logs, doesn't seem applicable to our use
1326             # (SCRIPT_NAME is the full path, WebPath is just the beginning)
1327             #in vanilla RT does something eat the local part of SCRIPT_NAME 1st?
1328
1329     # Unfortunately, there is no reliable way to get the _path_ that was
1330     # requested at the proxy level; simply disable this warning if we're
1331     # proxied and there's a mismatch.
1332     my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
1333     if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
1334         $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath).  "
1335                          ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
1336                          ."otherwise your internal hyperlinks may be broken.");
1337     }
1338 }
1339
1340 sub ComponentRoots {
1341     my $self = shift;
1342     my %args = ( Names => 0, @_ );
1343     my @roots;
1344     if (defined $HTML::Mason::Commands::m) {
1345         @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1346     } else {
1347         @roots = (
1348             [ local    => $RT::MasonLocalComponentRoot ],
1349             (map {[ "plugin-".$_->Name =>  $_->ComponentRoot ]} @{RT->Plugins}),
1350             [ standard => $RT::MasonComponentRoot ]
1351         );
1352     }
1353     @roots = map { $_->[1] } @roots unless $args{Names};
1354     return @roots;
1355 }
1356
1357 sub StaticRoots {
1358     my $self   = shift;
1359     my @static = (
1360         $RT::LocalStaticPath,
1361         (map { $_->StaticDir } @{RT->Plugins}),
1362         $RT::StaticPath,
1363     );
1364     return grep { $_ and -d $_ } @static;
1365 }
1366
1367 our %IS_WHITELISTED_COMPONENT = (
1368     # The RSS feed embeds an auth token in the path, but query
1369     # information for the search.  Because it's a straight-up read, in
1370     # addition to embedding its own auth, it's fine.
1371     '/NoAuth/rss/dhandler' => 1,
1372
1373     # While these can be used for denial-of-service against RT
1374     # (construct a very inefficient query and trick lots of users into
1375     # running them against RT) it's incredibly useful to be able to link
1376     # to a search result (or chart) or bookmark a result page.
1377     '/Search/Results.html' => 1,
1378     '/Search/Simple.html'  => 1,
1379     '/m/tickets/search'    => 1,
1380     '/Search/Chart.html'   => 1,
1381     '/User/Search.html'    => 1,
1382
1383     # This page takes Attachment and Transaction argument to figure
1384     # out what to show, but it's read only and will deny information if you
1385     # don't have ShowOutgoingEmail.
1386     '/Ticket/ShowEmailRecord.html' => 1,
1387 );
1388
1389 # Whitelist arguments that do not indicate an effectful request.
1390 our @GLOBAL_WHITELISTED_ARGS = (
1391     # For example, "id" is acceptable because that is how RT retrieves a
1392     # record.
1393     'id',
1394
1395     # If they have a results= from MaybeRedirectForResults, that's also fine.
1396     'results',
1397
1398     # The homepage refresh, which uses the Refresh header, doesn't send
1399     # a referer in most browsers; whitelist the one parameter it reloads
1400     # with, HomeRefreshInterval, which is safe
1401     'HomeRefreshInterval',
1402
1403     # The NotMobile flag is fine for any page; it's only used to toggle a flag
1404     # in the session related to which interface you get.
1405     'NotMobile',
1406 );
1407
1408 our %WHITELISTED_COMPONENT_ARGS = (
1409     # SavedSearchLoad - This happens when you middle-(or ⌘ )-click "Edit" for a saved search on
1410     # the homepage. It's not going to do any damage
1411     # NewQuery - This is simply to clear the search query
1412     '/Search/Build.html' => ['SavedSearchLoad','NewQuery'],
1413     # Happens if you try and reply to a message in the ticket history or click a number
1414     # of options on a tickets Action menu
1415     '/Ticket/Update.html' => ['QuoteTransaction', 'Action', 'DefaultStatus'],
1416     # Action->Extract Article on a ticket's menu
1417     '/Articles/Article/ExtractIntoClass.html' => ['Ticket'],
1418 );
1419
1420 # Components which are blacklisted from automatic, argument-based whitelisting.
1421 # These pages are not idempotent when called with just an id.
1422 our %IS_BLACKLISTED_COMPONENT = (
1423     # Takes only id and toggles bookmark state
1424     '/Helpers/Toggle/TicketBookmark' => 1,
1425 );
1426
1427 sub IsCompCSRFWhitelisted {
1428     my $comp = shift;
1429     my $ARGS = shift;
1430
1431     return 1 if $IS_WHITELISTED_COMPONENT{$comp};
1432
1433     my %args = %{ $ARGS };
1434
1435     # If the user specifies a *correct* user and pass then they are
1436     # golden.  This acts on the presumption that external forms may
1437     # hardcode a username and password -- if a malicious attacker knew
1438     # both already, CSRF is the least of your problems.
1439     my $AllowLoginCSRF = not RT->Config->Get('RestrictLoginReferrer');
1440     if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1441         my $user_obj = RT::CurrentUser->new();
1442         $user_obj->Load($args{user});
1443         return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1444
1445         delete $args{user};
1446         delete $args{pass};
1447     }
1448
1449     # Some pages aren't idempotent even with safe args like id; blacklist
1450     # them from the automatic whitelisting below.
1451     return 0 if $IS_BLACKLISTED_COMPONENT{$comp};
1452
1453     if ( my %csrf_config = RT->Config->Get('ReferrerComponents') ) {
1454         my $value = $csrf_config{$comp};
1455         if ( ref $value eq 'ARRAY' ) {
1456             delete $args{$_} for @$value;
1457             return %args ? 0 : 1;
1458         }
1459         else {
1460             return $value ? 1 : 0;
1461         }
1462     }
1463
1464     return AreCompCSRFParametersWhitelisted($comp, \%args);
1465 }
1466
1467 sub AreCompCSRFParametersWhitelisted {
1468     my $sub = shift;
1469     my $ARGS = shift;
1470
1471     my %leftover_args = %{ $ARGS };
1472
1473     # Join global whitelist and component-specific whitelist
1474     my @whitelisted_args = (@GLOBAL_WHITELISTED_ARGS, @{ $WHITELISTED_COMPONENT_ARGS{$sub} || [] });
1475
1476     for my $arg (@whitelisted_args) {
1477         delete $leftover_args{$arg};
1478     }
1479
1480     # If there are no arguments, then it's likely to be an idempotent
1481     # request, which are not susceptible to CSRF
1482     return !%leftover_args;
1483 }
1484
1485 sub IsRefererCSRFWhitelisted {
1486     my $referer = _NormalizeHost(shift);
1487     my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1488     $base_url = $base_url->host_port;
1489
1490     my $configs;
1491     for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1492         push @$configs,$config;
1493
1494         my $host_port = $referer->host_port;
1495         if ($config =~ /\*/) {
1496             # Turn a literal * into a domain component or partial component match.
1497             # Refer to http://tools.ietf.org/html/rfc2818#page-5
1498             my $regex = join "[a-zA-Z0-9\-]*",
1499                          map { quotemeta($_) }
1500                        split /\*/, $config;
1501
1502             return 1 if $host_port =~ /^$regex$/i;
1503         } else {
1504             return 1 if $host_port eq $config;
1505         }
1506     }
1507
1508     return (0,$referer,$configs);
1509 }
1510
1511 =head3 _NormalizeHost
1512
1513 Takes a URI and creates a URI object that's been normalized
1514 to handle common problems such as localhost vs 127.0.0.1
1515
1516 =cut
1517
1518 sub _NormalizeHost {
1519     my $s = shift;
1520     $s = "http://$s" unless $s =~ /^http/i;
1521     my $uri= URI->new($s);
1522     $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1523
1524     return $uri;
1525
1526 }
1527
1528 sub IsPossibleCSRF {
1529     my $ARGS = shift;
1530
1531     # If first request on this session is to a REST endpoint, then
1532     # whitelist the REST endpoints -- and explicitly deny non-REST
1533     # endpoints.  We do this because using a REST cookie in a browser
1534     # would open the user to CSRF attacks to the REST endpoints.
1535     my $path = $HTML::Mason::Commands::r->path_info;
1536     $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1537         unless defined $HTML::Mason::Commands::session{'REST'};
1538
1539     if ($HTML::Mason::Commands::session{'REST'}) {
1540         return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1541         my $why = <<EOT;
1542 This login session belongs to a REST client, and cannot be used to
1543 access non-REST interfaces of RT for security reasons.
1544 EOT
1545         my $details = <<EOT;
1546 Please log out and back in to obtain a session for normal browsing.  If
1547 you understand the security implications, disabling RT's CSRF protection
1548 will remove this restriction.
1549 EOT
1550         chomp $details;
1551         HTML::Mason::Commands::Abort( $why, Details => $details );
1552     }
1553
1554     return 0 if IsCompCSRFWhitelisted(
1555         $HTML::Mason::Commands::m->request_comp->path,
1556         $ARGS
1557     );
1558
1559     # if there is no Referer header then assume the worst
1560     return (1,
1561             "your browser did not supply a Referrer header", # loc
1562         ) if !$ENV{HTTP_REFERER};
1563
1564     my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1565     return 0 if $whitelisted;
1566
1567     if ( @$configs > 1 ) {
1568         return (1,
1569                 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1570                 $browser->host_port,
1571                 shift @$configs,
1572                 join(', ', @$configs) );
1573     }
1574
1575     return (1,
1576             "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1577             $browser->host_port,
1578             $configs->[0]);
1579 }
1580
1581 sub ExpandCSRFToken {
1582     my $ARGS = shift;
1583
1584     my $token = delete $ARGS->{CSRF_Token};
1585     return unless $token;
1586
1587     my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1588     return unless $data;
1589     return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1590
1591     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1592     return unless $user->ValidateAuthString( $data->{auth}, $token );
1593
1594     %{$ARGS} = %{$data->{args}};
1595     $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1596
1597     # We explicitly stored file attachments with the request, but not in
1598     # the session yet, as that would itself be an attack.  Put them into
1599     # the session now, so they'll be visible.
1600     if ($data->{attach}) {
1601         my $filename = $data->{attach}{filename};
1602         my $mime     = $data->{attach}{mime};
1603         $HTML::Mason::Commands::session{'Attachments'}{$ARGS->{'Token'}||''}{$filename}
1604             = $mime;
1605     }
1606
1607     return 1;
1608 }
1609
1610 sub StoreRequestToken {
1611     my $ARGS = shift;
1612
1613     my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1614     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1615     my $data = {
1616         auth => $user->GenerateAuthString( $token ),
1617         path => $HTML::Mason::Commands::r->path_info,
1618         args => $ARGS,
1619     };
1620     if ($ARGS->{Attach}) {
1621         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1622         my $file_path = delete $ARGS->{'Attach'};
1623
1624         # This needs to be decoded because the value is a reference;
1625         # hence it was not decoded along with all of the standard
1626         # arguments in DecodeARGS
1627         $data->{attach} = {
1628             filename => Encode::decode("UTF-8", "$file_path"),
1629             mime     => $attachment,
1630         };
1631     }
1632
1633     $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1634     $HTML::Mason::Commands::session{'i'}++;
1635     return $token;
1636 }
1637
1638 sub MaybeShowInterstitialCSRFPage {
1639     my $ARGS = shift;
1640
1641     return unless RT->Config->Get('RestrictReferrer');
1642
1643     # Deal with the form token provided by the interstitial, which lets
1644     # browsers which never set referer headers still use RT, if
1645     # painfully.  This blows values into ARGS
1646     return if ExpandCSRFToken($ARGS);
1647
1648     my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1649     return if !$is_csrf;
1650
1651     $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1652
1653     my $token = StoreRequestToken($ARGS);
1654     $HTML::Mason::Commands::m->comp(
1655         '/Elements/CSRF',
1656         OriginalURL => RT->Config->Get('WebBaseURL') . RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1657         Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1658         Token => $token,
1659     );
1660     # Calls abort, never gets here
1661 }
1662
1663 our @POTENTIAL_PAGE_ACTIONS = (
1664     qr'/Ticket/Create.html' => "create a ticket",              # loc
1665     qr'/Ticket/'            => "update a ticket",              # loc
1666     qr'/Admin/'             => "modify RT's configuration",    # loc
1667     qr'/Approval/'          => "update an approval",           # loc
1668     qr'/Articles/'          => "update an article",            # loc
1669     qr'/Dashboards/'        => "modify a dashboard",           # loc
1670     qr'/m/ticket/'          => "update a ticket",              # loc
1671     qr'Prefs'               => "modify your preferences",      # loc
1672     qr'/Search/'            => "modify or access a search",    # loc
1673     qr'/SelfService/Create' => "create a ticket",              # loc
1674     qr'/SelfService/'       => "update a ticket",              # loc
1675 );
1676
1677 sub PotentialPageAction {
1678     my $page = shift;
1679     my @potentials = @POTENTIAL_PAGE_ACTIONS;
1680     while (my ($pattern, $result) = splice @potentials, 0, 2) {
1681         return HTML::Mason::Commands::loc($result)
1682             if $page =~ $pattern;
1683     }
1684     return "";
1685 }
1686
1687 =head2 RewriteInlineImages PARAMHASH
1688
1689 Turns C<< <img src="cid:..."> >> elements in HTML into working images pointing
1690 back to RT's stored copy.
1691
1692 Takes the following parameters:
1693
1694 =over 4
1695
1696 =item Content
1697
1698 Scalar ref of the HTML content to rewrite.  Modified in place to support the
1699 most common use-case.
1700
1701 =item Attachment
1702
1703 The L<RT::Attachment> object from which the Content originates.
1704
1705 =item Related (optional)
1706
1707 Array ref of related L<RT::Attachment> objects to use for C<Content-ID> matching.
1708
1709 Defaults to the result of the C<Siblings> method on the passed Attachment.
1710
1711 =item AttachmentPath (optional)
1712
1713 The base path to use when rewriting C<src> attributes.
1714
1715 Defaults to C< $WebPath/Ticket/Attachment >
1716
1717 =back
1718
1719 In scalar context, returns the number of elements rewritten.
1720
1721 In list content, returns the attachments IDs referred to by the rewritten <img>
1722 elements, in the order found.  There may be duplicates.
1723
1724 =cut
1725
1726 sub RewriteInlineImages {
1727     my %args = (
1728         Content         => undef,
1729         Attachment      => undef,
1730         Related         => undef,
1731         AttachmentPath  => RT->Config->Get('WebPath')."/Ticket/Attachment",
1732         @_
1733     );
1734
1735     return unless defined $args{Content}
1736               and ref $args{Content} eq 'SCALAR'
1737               and defined $args{Attachment};
1738
1739     my $related_part = $args{Attachment}->Closest("multipart/related")
1740         or return;
1741
1742     $args{Related} ||= $related_part->Children->ItemsArrayRef;
1743     return unless @{$args{Related}};
1744
1745     my $content = $args{'Content'};
1746     my @rewritten;
1747
1748     require HTML::RewriteAttributes::Resources;
1749     $$content = HTML::RewriteAttributes::Resources->rewrite($$content, sub {
1750         my $cid  = shift;
1751         my %meta = @_;
1752         return $cid unless    lc $meta{tag}  eq 'img'
1753                           and lc $meta{attr} eq 'src'
1754                           and $cid =~ s/^cid://i;
1755
1756         for my $attach (@{$args{Related}}) {
1757             if (($attach->GetHeader('Content-ID') || '') =~ /^(<)?\Q$cid\E(?(1)>)$/) {
1758                 push @rewritten, $attach->Id;
1759                 return "$args{AttachmentPath}/" . $attach->TransactionId . '/' . $attach->Id;
1760             }
1761         }
1762
1763         # No attachments means this is a bogus CID. Just pass it through.
1764         RT->Logger->debug(qq[Found bogus inline image src="cid:$cid"]);
1765         return "cid:$cid";
1766     });
1767     return @rewritten;
1768 }
1769
1770 =head2 GetCustomFieldInputName(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1771
1772 Returns the standard custom field input name; this is complementary to
1773 L</_ParseObjectCustomFieldArgs>.  Takes the following arguments:
1774
1775 =over
1776
1777 =item CustomField => I<L<RT::CustomField> object>
1778
1779 Required.
1780
1781 =item Object => I<object>
1782
1783 The object that the custom field is applied to; optional.  If omitted,
1784 defaults to a new object of the appropriate class for the custom field.
1785
1786 =item Grouping => I<CF grouping>
1787
1788 The grouping that the custom field is being rendered in.  Groupings
1789 allow a custom field to appear in more than one location per form.
1790
1791 =back
1792
1793 =cut
1794
1795 sub GetCustomFieldInputName {
1796     my %args = (
1797         CustomField => undef,
1798         Object      => undef,
1799         Grouping    => undef,
1800         @_,
1801     );
1802
1803     my $name = GetCustomFieldInputNamePrefix(%args);
1804
1805     if ( $args{CustomField}->Type eq 'Select' ) {
1806         if ( $args{CustomField}->RenderType eq 'List' and $args{CustomField}->SingleValue ) {
1807             $name .= 'Value';
1808         }
1809         else {
1810             $name .= 'Values';
1811         }
1812     }
1813     elsif ( $args{CustomField}->Type =~ /^(?:Binary|Image)$/ ) {
1814         $name .= 'Upload';
1815     }
1816     elsif ( $args{CustomField}->Type =~ /^(?:Date|DateTime|Text|Wikitext)$/ ) {
1817         $name .= 'Values';
1818     }
1819     else {
1820         if ( $args{CustomField}->SingleValue ) {
1821             $name .= 'Value';
1822         }
1823         else {
1824             $name .= 'Values';
1825         }
1826     }
1827
1828     return $name;
1829 }
1830
1831 =head2 GetCustomFieldInputNamePrefix(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1832
1833 Returns the standard custom field input name prefix(without "Value" or alike suffix)
1834
1835 =cut
1836
1837 sub GetCustomFieldInputNamePrefix {
1838     my %args = (
1839         CustomField => undef,
1840         Object      => undef,
1841         Grouping    => undef,
1842         @_,
1843     );
1844
1845     my $prefix = join '-', 'Object', ref( $args{Object} ) || $args{CustomField}->ObjectTypeFromLookupType,
1846         ( $args{Object} && $args{Object}->id ? $args{Object}->id : '' ),
1847         'CustomField' . ( $args{Grouping} ? ":$args{Grouping}" : '' ),
1848         $args{CustomField}->id, '';
1849
1850     return $prefix;
1851 }
1852
1853 package HTML::Mason::Commands;
1854
1855 use vars qw/$r $m %session/;
1856
1857 use Scalar::Util qw(blessed);
1858
1859 sub Menu {
1860     return $HTML::Mason::Commands::m->notes('menu');
1861 }
1862
1863 sub PageMenu {
1864     return $HTML::Mason::Commands::m->notes('page-menu');
1865 }
1866
1867 sub PageWidgets {
1868     return $HTML::Mason::Commands::m->notes('page-widgets');
1869 }
1870
1871 sub RenderMenu {
1872     my %args = (toplevel => 1, parent_id => '', depth => 0, @_);
1873     return unless $args{'menu'};
1874
1875     my ($menu, $depth, $toplevel, $id, $parent_id)
1876         = @args{qw(menu depth toplevel id parent_id)};
1877
1878     my $interp = $m->interp;
1879     my $web_path = RT->Config->Get('WebPath');
1880
1881     my $res = '';
1882     $res .= ' ' x $depth;
1883     $res .= '<ul';
1884     $res .= ' id="'. $interp->apply_escapes($id, 'h') .'"'
1885         if $id;
1886     $res .= ' class="toplevel"' if $toplevel;
1887     $res .= ">\n";
1888
1889     for my $child ($menu->children) {
1890         $res .= ' 'x ($depth+1);
1891
1892         my $item_id = lc(($parent_id? "$parent_id-" : "") .$child->key);
1893         $item_id =~ s/\s/-/g;
1894         my $eitem_id = $interp->apply_escapes($item_id, 'h');
1895         $res .= qq{<li id="li-$eitem_id"};
1896
1897         my @classes;
1898         push @classes, 'has-children' if $child->has_children;
1899         push @classes, 'active'       if $child->active;
1900         $res .= ' class="'. join( ' ', @classes ) .'"'
1901             if @classes;
1902
1903         $res .= '>';
1904
1905         if ( my $tmp = $child->raw_html ) {
1906             $res .= $tmp;
1907         } else {
1908             $res .= qq{<a id="$eitem_id" class="menu-item};
1909             if ( $tmp = $child->class ) {
1910                 $res .= ' '. $interp->apply_escapes($tmp, 'h');
1911             }
1912             $res .= '"';
1913
1914             my $path = $child->path;
1915             my $url = (not $path or $path =~ m{^\w+:/}) ? $path : $web_path . $path;
1916             $url ||= "#";
1917             $res .= ' href="'. $interp->apply_escapes($url, 'h') .'"';
1918
1919             if ( $tmp = $child->target ) {
1920                 $res .= ' target="'. $interp->apply_escapes($tmp, 'h') .'"'
1921             }
1922
1923             if ($child->attributes) {
1924                 for my $key (keys %{$child->attributes}) {
1925                     my ($name, $value) = map { $interp->apply_escapes($_, 'h') }
1926                                              $key, $child->attributes->{$key};
1927                     $res .= " $name=\"$value\"";
1928                 }
1929             }
1930             $res .= '>';
1931
1932             if ( $child->escape_title ) {
1933                 $res .= $interp->apply_escapes($child->title, 'h');
1934             } else {
1935                 $res .= $child->title;
1936             }
1937             $res .= '</a>';
1938         }
1939
1940         if ( $child->has_children ) {
1941             $res .= "\n";
1942             $res .= RenderMenu(
1943                 menu => $child,
1944                 toplevel => 0,
1945                 parent_id => $item_id,
1946                 depth => $depth+1,
1947                 return => 1,
1948             );
1949             $res .= "\n";
1950             $res .= ' ' x ($depth+1);
1951         }
1952         $res .= "</li>\n";
1953     }
1954     $res .= ' ' x $depth;
1955     $res .= '</ul>';
1956     return $res if $args{'return'};
1957
1958     $m->print($res);
1959     return '';
1960 }
1961
1962 =head2 loc ARRAY
1963
1964 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1965 with whatever it's called with. If there is no $session{'CurrentUser'},
1966 it creates a temporary user, so we have something to get a localisation handle
1967 through
1968
1969 =cut
1970
1971 sub loc {
1972
1973     if ( $session{'CurrentUser'}
1974         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1975     {
1976         return ( $session{'CurrentUser'}->loc(@_) );
1977     } elsif (
1978         my $u = eval {
1979             RT::CurrentUser->new();
1980         }
1981         )
1982     {
1983         return ( $u->loc(@_) );
1984     } else {
1985
1986         # pathetic case -- SystemUser is gone.
1987         return $_[0];
1988     }
1989 }
1990
1991
1992
1993 =head2 loc_fuzzy STRING
1994
1995 loc_fuzzy is for handling localizations of messages that may already
1996 contain interpolated variables, typically returned from libraries
1997 outside RT's control.  It takes the message string and extracts the
1998 variable array automatically by matching against the candidate entries
1999 inside the lexicon file.
2000
2001 =cut
2002
2003 sub loc_fuzzy {
2004     my $msg = shift;
2005
2006     if ( $session{'CurrentUser'}
2007         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
2008     {
2009         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
2010     } else {
2011         my $u = RT::CurrentUser->new( RT->SystemUser->Id );
2012         return ( $u->loc_fuzzy($msg) );
2013     }
2014 }
2015
2016
2017 # Error - calls Error and aborts
2018 sub Abort {
2019     my $why  = shift;
2020     my %args = @_;
2021
2022     if (   $session{'ErrorDocument'}
2023         && $session{'ErrorDocumentType'} )
2024     {
2025         $r->content_type( $session{'ErrorDocumentType'} );
2026         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
2027         $m->abort;
2028     } else {
2029         $m->comp( "/Elements/Error", Why => $why, %args );
2030         $m->abort;
2031     }
2032 }
2033
2034 sub MaybeRedirectForResults {
2035     my %args = (
2036         Path      => $HTML::Mason::Commands::m->request_comp->path,
2037         Arguments => {},
2038         Anchor    => undef,
2039         Actions   => undef,
2040         Force     => 0,
2041         @_
2042     );
2043     my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
2044     return unless $has_actions || $args{'Force'};
2045
2046     my %arguments = %{ $args{'Arguments'} };
2047
2048     if ( $has_actions ) {
2049         my $key = Digest::MD5::md5_hex( rand(1024) );
2050         push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
2051         $session{'i'}++;
2052         $arguments{'results'} = $key;
2053     }
2054
2055     $args{'Path'} =~ s!^/+!!;
2056     my $url = RT->Config->Get('WebURL') . $args{Path};
2057
2058     if ( keys %arguments ) {
2059         $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
2060     }
2061     if ( $args{'Anchor'} ) {
2062         $url .= "#". $args{'Anchor'};
2063     }
2064     return RT::Interface::Web::Redirect($url);
2065 }
2066
2067 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
2068
2069 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
2070 redirect to the approvals display page, preserving any arguments.
2071
2072 C<Path>s matching C<Whitelist> are let through.
2073
2074 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
2075
2076 =cut
2077
2078 sub MaybeRedirectToApproval {
2079     my %args = (
2080         Path        => $HTML::Mason::Commands::m->request_comp->path,
2081         ARGSRef     => {},
2082         Whitelist   => undef,
2083         @_
2084     );
2085
2086     return unless $ENV{REQUEST_METHOD} eq 'GET';
2087
2088     my $id = $args{ARGSRef}->{id};
2089
2090     if (    $id
2091         and RT->Config->Get('ForceApprovalsView')
2092         and not $args{Path} =~ /$args{Whitelist}/)
2093     {
2094         my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
2095         $ticket->Load($id);
2096
2097         if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
2098             MaybeRedirectForResults(
2099                 Path      => "/Approvals/Display.html",
2100                 Force     => 1,
2101                 Anchor    => $args{ARGSRef}->{Anchor},
2102                 Arguments => $args{ARGSRef},
2103             );
2104         }
2105     }
2106 }
2107
2108 =head2 CreateTicket ARGS
2109
2110 Create a new ticket, using Mason's %ARGS.  returns @results.
2111
2112 =cut
2113
2114 sub CreateTicket {
2115     my %ARGS = (@_);
2116
2117     my (@Actions);
2118
2119     my $current_user = $session{'CurrentUser'};
2120     my $Ticket = RT::Ticket->new( $current_user );
2121
2122     my $Queue = RT::Queue->new( $current_user );
2123     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
2124         Abort('Queue not found');
2125     }
2126
2127     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
2128         Abort('You have no permission to create tickets in that queue.');
2129     }
2130
2131     my $due;
2132     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
2133         $due = RT::Date->new( $current_user );
2134         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
2135     }
2136     my $starts;
2137     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
2138         $starts = RT::Date->new( $current_user );
2139         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
2140     }
2141
2142     my $sigless = RT::Interface::Web::StripContent(
2143         Content        => $ARGS{Content},
2144         ContentType    => $ARGS{ContentType},
2145         StripSignature => 1,
2146         CurrentUser    => $current_user,
2147     );
2148
2149     my $date_now = RT::Date->new( $current_user );
2150     $date_now->SetToNow;
2151     my $MIMEObj = MakeMIMEEntity(
2152         Subject => $ARGS{'Subject'},
2153         From    => $ARGS{'From'} || $current_user->EmailAddress,
2154         To      => $ARGS{'To'} || $Queue->CorrespondAddress
2155                                || RT->Config->Get('CorrespondAddress'),
2156         Cc      => $ARGS{'Cc'},
2157         Date    => $date_now->RFC2822(Timezone => 'user'),
2158         Body    => $sigless,
2159         Type    => $ARGS{'ContentType'},
2160         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2161     );
2162
2163     my @attachments;
2164     if ( my $tmp = $session{'Attachments'}{ $ARGS{'Token'} || '' } ) {
2165         push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2166
2167         delete $session{'Attachments'}{ $ARGS{'Token'} || '' }
2168             unless $ARGS{'KeepAttachments'};
2169         $session{'Attachments'} = $session{'Attachments'}
2170             if @attachments;
2171     }
2172     if ( $ARGS{'Attachments'} ) {
2173         push @attachments, grep $_, map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} };
2174     }
2175     if ( @attachments ) {
2176         $MIMEObj->make_multipart;
2177         $MIMEObj->add_part( $_ ) foreach @attachments;
2178     }
2179
2180     for my $argument (qw(Encrypt Sign)) {
2181         if ( defined $ARGS{ $argument } ) {
2182             $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
2183         }
2184     }
2185
2186     my %create_args = (
2187         Type => $ARGS{'Type'} || 'ticket',
2188         Queue => $ARGS{'Queue'},
2189         Owner => $ARGS{'Owner'},
2190
2191         # note: name change
2192         Requestor       => $ARGS{'Requestors'},
2193         Cc              => $ARGS{'Cc'},
2194         AdminCc         => $ARGS{'AdminCc'},
2195         InitialPriority => $ARGS{'InitialPriority'},
2196         FinalPriority   => $ARGS{'FinalPriority'},
2197         TimeLeft        => $ARGS{'TimeLeft'},
2198         TimeEstimated   => $ARGS{'TimeEstimated'},
2199         TimeWorked      => $ARGS{'TimeWorked'},
2200         Subject         => $ARGS{'Subject'},
2201         Status          => $ARGS{'Status'},
2202         Due             => $due ? $due->ISO : undef,
2203         Starts          => $starts ? $starts->ISO : undef,
2204         MIMEObj         => $MIMEObj,
2205         SquelchMailTo   => $ARGS{'SquelchMailTo'},
2206         TransSquelchMailTo => $ARGS{'TransSquelchMailTo'},
2207     );
2208
2209     if ($ARGS{'DryRun'}) {
2210         $create_args{DryRun} = 1;
2211         $create_args{Owner}     ||= $RT::Nobody->Id;
2212         $create_args{Requestor} ||= $session{CurrentUser}->EmailAddress;
2213         $create_args{Subject}   ||= '';
2214         $create_args{Status}    ||= $Queue->Lifecycle->DefaultOnCreate,
2215     } else {
2216         my @txn_squelch;
2217         foreach my $type (qw(Requestor Cc AdminCc)) {
2218             push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
2219                 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
2220         }
2221         push @{$create_args{TransSquelchMailTo}}, @txn_squelch;
2222     }
2223
2224     if ( $ARGS{'AttachTickets'} ) {
2225         require RT::Action::SendEmail;
2226         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2227             ref $ARGS{'AttachTickets'}
2228             ? @{ $ARGS{'AttachTickets'} }
2229             : ( $ARGS{'AttachTickets'} ) );
2230     }
2231
2232     my %cfs = ProcessObjectCustomFieldUpdatesForCreate(
2233         ARGSRef         => \%ARGS,
2234         ContextObject   => $Queue,
2235     );
2236
2237     my %links = ProcessLinksForCreate( ARGSRef => \%ARGS );
2238
2239     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args, %links, %cfs);
2240     return $Trans if $ARGS{DryRun};
2241
2242     unless ($id) {
2243         Abort($ErrMsg);
2244     }
2245
2246     push( @Actions, split( "\n", $ErrMsg ) );
2247     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
2248         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
2249     }
2250     return ( $Ticket, @Actions );
2251
2252 }
2253
2254
2255
2256 =head2  LoadTicket id
2257
2258 Takes a ticket id as its only variable. if it's handed an array, it takes
2259 the first value.
2260
2261 Returns an RT::Ticket object as the current user.
2262
2263 =cut
2264
2265 sub LoadTicket {
2266     my $id = shift;
2267
2268     if ( ref($id) eq "ARRAY" ) {
2269         $id = $id->[0];
2270     }
2271
2272     unless ($id) {
2273         Abort("No ticket specified");
2274     }
2275
2276     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
2277     $Ticket->Load($id);
2278     unless ( $Ticket->id ) {
2279         Abort("Could not load ticket $id");
2280     }
2281     return $Ticket;
2282 }
2283
2284
2285
2286 =head2 ProcessUpdateMessage
2287
2288 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
2289
2290 Don't write message if it only contains current user's signature and
2291 SkipSignatureOnly argument is true. Function anyway adds attachments
2292 and updates time worked field even if skips message. The default value
2293 is true.
2294
2295 =cut
2296
2297 # change from stock: if txn custom fields are set but there's no content
2298 # or attachment, create a Touch txn instead of doing nothing
2299
2300 sub ProcessUpdateMessage {
2301
2302     my %args = (
2303         ARGSRef           => undef,
2304         TicketObj         => undef,
2305         SkipSignatureOnly => 1,
2306         @_
2307     );
2308
2309     my @attachments;
2310     if ( my $tmp = $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' } ) {
2311         push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2312
2313         delete $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' }
2314             unless $args{'KeepAttachments'};
2315         $session{'Attachments'} = $session{'Attachments'}
2316             if @attachments;
2317     }
2318     if ( $args{ARGSRef}{'UpdateAttachments'} ) {
2319         push @attachments, grep $_, map $args{ARGSRef}->{UpdateAttachments}{$_},
2320                                    sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2321     }
2322
2323     # Strip the signature
2324     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
2325         Content        => $args{ARGSRef}->{UpdateContent},
2326         ContentType    => $args{ARGSRef}->{UpdateContentType},
2327         StripSignature => $args{SkipSignatureOnly},
2328         CurrentUser    => $args{'TicketObj'}->CurrentUser,
2329     );
2330
2331     my %txn_customfields;
2332
2333     foreach my $key ( keys %{ $args{ARGSRef} } ) {
2334       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
2335         next if $key =~ /(TimeUnits|Magic)$/;
2336         $txn_customfields{$key} = $args{ARGSRef}->{$key};
2337       }
2338     }
2339
2340     # If, after stripping the signature, we have no message, create a
2341     # Touch transaction if necessary
2342     if (    not @attachments
2343         and not length $args{ARGSRef}->{'UpdateContent'} )
2344     {
2345         #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
2346         #      $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
2347         #          delete $args{ARGSRef}->{'UpdateTimeWorked'};
2348         #  }
2349
2350         my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
2351         if ( $timetaken or grep {length $_} values %txn_customfields ) {
2352             my ( $Transaction, $Description, $Object ) =
2353                 $args{TicketObj}->Touch(
2354                   CustomFields => \%txn_customfields,
2355                   TimeTaken => $timetaken
2356                 );
2357             return $Description;
2358         }
2359         return;
2360     }
2361
2362     if ( ($args{ARGSRef}->{'UpdateSubject'}||'') eq ($args{'TicketObj'}->Subject || '') ) {
2363         $args{ARGSRef}->{'UpdateSubject'} = undef;
2364     }
2365
2366     my $Message = MakeMIMEEntity(
2367         Subject => $args{ARGSRef}->{'UpdateSubject'},
2368         Body    => $args{ARGSRef}->{'UpdateContent'},
2369         Type    => $args{ARGSRef}->{'UpdateContentType'},
2370         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2371     );
2372
2373     $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
2374         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2375     ) );
2376     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2377     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2378         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2379     } else {
2380         $old_txn = $args{TicketObj}->Transactions->First();
2381     }
2382
2383     if ( my $msg = $old_txn->Message->First ) {
2384         RT::Interface::Email::SetInReplyTo(
2385             Message   => $Message,
2386             InReplyTo => $msg,
2387             Ticket    => $args{'TicketObj'},
2388         );
2389     }
2390
2391     if ( @attachments ) {
2392         $Message->make_multipart;
2393         $Message->add_part( $_ ) foreach @attachments;
2394     }
2395
2396     if ( $args{ARGSRef}->{'AttachTickets'} ) {
2397         require RT::Action::SendEmail;
2398         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2399             ref $args{ARGSRef}->{'AttachTickets'}
2400             ? @{ $args{ARGSRef}->{'AttachTickets'} }
2401             : ( $args{ARGSRef}->{'AttachTickets'} ) );
2402     }
2403
2404     my %message_args = (
2405         Sign         => $args{ARGSRef}->{'Sign'},
2406         Encrypt      => $args{ARGSRef}->{'Encrypt'},
2407         MIMEObj      => $Message,
2408         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
2409         CustomFields => \%txn_customfields,
2410     );
2411
2412     _ProcessUpdateMessageRecipients(
2413         MessageArgs => \%message_args,
2414         %args,
2415     );
2416
2417     my @results;
2418     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2419         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2420         push( @results, $Description );
2421         $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2422     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2423         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2424         push( @results, $Description );
2425         $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2426     } else {
2427         push( @results,
2428             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2429     }
2430     return @results;
2431 }
2432
2433 sub _ProcessUpdateMessageRecipients {
2434     my %args = (
2435         ARGSRef           => undef,
2436         TicketObj         => undef,
2437         MessageArgs       => undef,
2438         @_,
2439     );
2440
2441     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2442     my $cc  = $args{ARGSRef}->{'UpdateCc'};
2443
2444     my $message_args = $args{MessageArgs};
2445
2446     $message_args->{CcMessageTo} = $cc;
2447     $message_args->{BccMessageTo} = $bcc;
2448
2449     my @txn_squelch;
2450     foreach my $type (qw(Cc AdminCc)) {
2451         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2452             push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2453             push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2454             push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2455         }
2456     }
2457     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2458         push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2459         push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2460     }
2461
2462     push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2463     $message_args->{SquelchMailTo} = \@txn_squelch
2464         if @txn_squelch;
2465
2466     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2467         foreach my $key ( keys %{ $args{ARGSRef} } ) {
2468             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2469
2470             my $var   = ucfirst($1) . 'MessageTo';
2471             my $value = $2;
2472             if ( $message_args->{$var} ) {
2473                 $message_args->{$var} .= ", $value";
2474             } else {
2475                 $message_args->{$var} = $value;
2476             }
2477         }
2478     }
2479 }
2480
2481 sub ProcessAttachments {
2482     my %args = (
2483         ARGSRef => {},
2484         Token   => '',
2485         @_
2486     );
2487
2488     my $token = $args{'ARGSRef'}{'Token'}
2489         ||= $args{'Token'} ||= Digest::MD5::md5_hex( rand(1024) );
2490
2491     my $update_session = 0;
2492
2493     # deal with deleting uploaded attachments
2494     if ( my $del = $args{'ARGSRef'}{'DeleteAttach'} ) {
2495         delete $session{'Attachments'}{ $token }{ $_ }
2496             foreach ref $del? @$del : ($del);
2497
2498         $update_session = 1;
2499     }
2500
2501     # store the uploaded attachment in session
2502     my $new = $args{'ARGSRef'}{'Attach'};
2503     if ( defined $new && length $new ) {
2504         my $attachment = MakeMIMEEntity(
2505             AttachmentFieldName => 'Attach'
2506         );
2507
2508         # This needs to be decoded because the value is a reference;
2509         # hence it was not decoded along with all of the standard
2510         # arguments in DecodeARGS
2511         my $file_path = Encode::decode( "UTF-8", "$new");
2512         $session{'Attachments'}{ $token }{ $file_path } = $attachment;
2513
2514         $update_session = 1;
2515     }
2516     $session{'Attachments'} = $session{'Attachments'} if $update_session;
2517 }
2518
2519
2520 =head2 MakeMIMEEntity PARAMHASH
2521
2522 Takes a paramhash Subject, Body and AttachmentFieldName.
2523
2524 Also takes Form, Cc and Type as optional paramhash keys.
2525
2526   Returns a MIME::Entity.
2527
2528 =cut
2529
2530 sub MakeMIMEEntity {
2531
2532     #TODO document what else this takes.
2533     my %args = (
2534         Subject             => undef,
2535         From                => undef,
2536         Cc                  => undef,
2537         Body                => undef,
2538         AttachmentFieldName => undef,
2539         Type                => undef,
2540         Interface           => 'API',
2541         @_,
2542     );
2543     my $Message = MIME::Entity->build(
2544         Type    => 'multipart/mixed',
2545         "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
2546         "X-RT-Interface" => $args{Interface},
2547         map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
2548             grep defined $args{$_}, qw(Subject From Cc To Date)
2549     );
2550
2551     if ( defined $args{'Body'} && length $args{'Body'} ) {
2552
2553         # Make the update content have no 'weird' newlines in it
2554         $args{'Body'} =~ s/\r\n/\n/gs;
2555
2556         $Message->attach(
2557             Type    => $args{'Type'} || 'text/plain',
2558             Charset => 'UTF-8',
2559             Data    => Encode::encode( "UTF-8", $args{'Body'} ),
2560         );
2561     }
2562
2563     if ( $args{'AttachmentFieldName'} ) {
2564
2565         my $cgi_object = $m->cgi_object;
2566         my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2567         if ( defined $filehandle && length $filehandle ) {
2568
2569             my ( @content, $buffer );
2570             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2571                 push @content, $buffer;
2572             }
2573
2574             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2575
2576             my $filename = Encode::decode("UTF-8","$filehandle");
2577             $filename =~ s{^.*[\\/]}{};
2578
2579             $Message->attach(
2580                 Type     => $uploadinfo->{'Content-Type'},
2581                 Filename => Encode::encode("UTF-8",$filename),
2582                 Data     => \@content, # Bytes, as read directly from the file, above
2583             );
2584             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2585                 $Message->head->replace( 'Subject' => Encode::encode( "UTF-8", $filename ) );
2586             }
2587
2588             # Attachment parts really shouldn't get a Message-ID or "interface"
2589             $Message->head->delete('Message-ID');
2590             $Message->head->delete('X-RT-Interface');
2591         }
2592     }
2593
2594     $Message->make_singlepart;
2595
2596     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
2597
2598     return ($Message);
2599
2600 }
2601
2602
2603
2604 =head2 ParseDateToISO
2605
2606 Takes a date in an arbitrary format.
2607 Returns an ISO date and time in GMT
2608
2609 =cut
2610
2611 sub ParseDateToISO {
2612     my $date = shift;
2613
2614     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2615     $date_obj->Set(
2616         Format => 'unknown',
2617         Value  => $date
2618     );
2619     return ( $date_obj->ISO );
2620 }
2621
2622
2623
2624 sub ProcessACLChanges {
2625     my $ARGSref = shift;
2626
2627     my @results;
2628
2629     foreach my $arg ( keys %$ARGSref ) {
2630         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2631
2632         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2633
2634         my @rights;
2635         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2636             @rights = @{ $ARGSref->{$arg} };
2637         } else {
2638             @rights = $ARGSref->{$arg};
2639         }
2640         @rights = grep $_, @rights;
2641         next unless @rights;
2642
2643         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2644         $principal->Load($principal_id);
2645
2646         my $obj;
2647         if ( $object_type eq 'RT::System' ) {
2648             $obj = $RT::System;
2649         } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2650             $obj = $object_type->new( $session{'CurrentUser'} );
2651             $obj->Load($object_id);
2652             unless ( $obj->id ) {
2653                 $RT::Logger->error("couldn't load $object_type #$object_id");
2654                 next;
2655             }
2656         } else {
2657             $RT::Logger->error("object type '$object_type' is incorrect");
2658             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2659             next;
2660         }
2661
2662         foreach my $right (@rights) {
2663             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2664             push( @results, $msg );
2665         }
2666     }
2667
2668     return (@results);
2669 }
2670
2671
2672 =head2 ProcessACLs
2673
2674 ProcessACLs expects values from a series of checkboxes that describe the full
2675 set of rights a principal should have on an object.
2676
2677 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2678 instead of with the prefixes Grant/RevokeRight.  Each input should be an array
2679 listing the rights the principal should have, and ProcessACLs will modify the
2680 current rights to match.  Additionally, the previously unused CheckACL input
2681 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2682 rights are removed from a principal and as such no SetRights input is
2683 submitted.
2684
2685 =cut
2686
2687 sub ProcessACLs {
2688     my $ARGSref = shift;
2689     my (%state, @results);
2690
2691     my $CheckACL = $ARGSref->{'CheckACL'};
2692     my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2693
2694     # Check if we want to grant rights to a previously rights-less user
2695     for my $type (qw(user group)) {
2696         my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2697             or next;
2698
2699         unless ($principal->PrincipalId) {
2700             push @results, loc("Couldn't load the specified principal");
2701             next;
2702         }
2703
2704         my $principal_id = $principal->PrincipalId;
2705
2706         # Turn our addprincipal rights spec into a real one
2707         for my $arg (keys %$ARGSref) {
2708             next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2709
2710             my $tuple = "$principal_id-$1";
2711             my $key   = "SetRights-$tuple";
2712
2713             # If we have it already, that's odd, but merge them
2714             if (grep { $_ eq $tuple } @check) {
2715                 $ARGSref->{$key} = [
2716                     (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2717                     (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2718                 ];
2719             } else {
2720                 $ARGSref->{$key} = $ARGSref->{$arg};
2721                 push @check, $tuple;
2722             }
2723         }
2724     }
2725
2726     # Build our rights state for each Principal-Object tuple
2727     foreach my $arg ( keys %$ARGSref ) {
2728         next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2729
2730         my $tuple  = $1;
2731         my $value  = $ARGSref->{$arg};
2732         my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2733         next unless @rights;
2734
2735         $state{$tuple} = { map { $_ => 1 } @rights };
2736     }
2737
2738     foreach my $tuple (List::MoreUtils::uniq @check) {
2739         next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2740
2741         my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2742
2743         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2744         $principal->Load($principal_id);
2745
2746         my $obj;
2747         if ( $object_type eq 'RT::System' ) {
2748             $obj = $RT::System;
2749         } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2750             $obj = $object_type->new( $session{'CurrentUser'} );
2751             $obj->Load($object_id);
2752             unless ( $obj->id ) {
2753                 $RT::Logger->error("couldn't load $object_type #$object_id");
2754                 next;
2755             }
2756         } else {
2757             $RT::Logger->error("object type '$object_type' is incorrect");
2758             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2759             next;
2760         }
2761
2762         my $acls = RT::ACL->new($session{'CurrentUser'});
2763         $acls->LimitToObject( $obj );
2764         $acls->LimitToPrincipal( Id => $principal_id );
2765
2766         while ( my $ace = $acls->Next ) {
2767             my $right = $ace->RightName;
2768
2769             # Has right and should have right
2770             next if delete $state{$tuple}->{$right};
2771
2772             # Has right and shouldn't have right
2773             my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2774             push @results, $msg;
2775         }
2776
2777         # For everything left, they don't have the right but they should
2778         for my $right (keys %{ $state{$tuple} || {} }) {
2779             delete $state{$tuple}->{$right};
2780             my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2781             push @results, $msg;
2782         }
2783
2784         # Check our state for leftovers
2785         if ( keys %{ $state{$tuple} || {} } ) {
2786             my $missed = join '|', %{$state{$tuple} || {}};
2787             $RT::Logger->warn(
2788                "Uh-oh, it looks like we somehow missed a right in "
2789               ."ProcessACLs.  Here's what was leftover: $missed"
2790             );
2791         }
2792     }
2793
2794     return (@results);
2795 }
2796
2797 =head2 _ParseACLNewPrincipal
2798
2799 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>).  Looks
2800 for the presence of rights being added on a principal of the specified type,
2801 and returns undef if no new principal is being granted rights.  Otherwise loads
2802 up an L<RT::User> or L<RT::Group> object and returns it.  Note that the object
2803 may not be successfully loaded, and you should check C<->id> yourself.
2804
2805 =cut
2806
2807 sub _ParseACLNewPrincipal {
2808     my $ARGSref = shift;
2809     my $type    = lc shift;
2810     my $key     = "AddPrincipalForRights-$type";
2811
2812     return unless $ARGSref->{$key};
2813
2814     my $principal;
2815     if ( $type eq 'user' ) {
2816         $principal = RT::User->new( $session{'CurrentUser'} );
2817         $principal->LoadByCol( Name => $ARGSref->{$key} );
2818     }
2819     elsif ( $type eq 'group' ) {
2820         $principal = RT::Group->new( $session{'CurrentUser'} );
2821         $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2822     }
2823     return $principal;
2824 }
2825
2826
2827 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2828
2829 @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.
2830
2831 Returns an array of success/failure messages
2832
2833 =cut
2834
2835 sub UpdateRecordObject {
2836     my %args = (
2837         ARGSRef         => undef,
2838         AttributesRef   => undef,
2839         Object          => undef,
2840         AttributePrefix => undef,
2841         @_
2842     );
2843
2844     my $Object  = $args{'Object'};
2845     my @results = $Object->Update(
2846         AttributesRef   => $args{'AttributesRef'},
2847         ARGSRef         => $args{'ARGSRef'},
2848         AttributePrefix => $args{'AttributePrefix'},
2849     );
2850
2851     return (@results);
2852 }
2853
2854
2855
2856 sub ProcessCustomFieldUpdates {
2857     my %args = (
2858         CustomFieldObj => undef,
2859         ARGSRef        => undef,
2860         @_
2861     );
2862
2863     my $Object  = $args{'CustomFieldObj'};
2864     my $ARGSRef = $args{'ARGSRef'};
2865
2866     my @attribs = qw(Name Type Description Queue SortOrder);
2867     my @results = UpdateRecordObject(
2868         AttributesRef => \@attribs,
2869         Object        => $Object,
2870         ARGSRef       => $ARGSRef
2871     );
2872
2873     my $prefix = "CustomField-" . $Object->Id;
2874     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2875         my ( $addval, $addmsg ) = $Object->AddValue(
2876             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2877             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2878             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2879         );
2880         push( @results, $addmsg );
2881     }
2882
2883     my @delete_values
2884         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2885         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2886         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2887
2888     foreach my $id (@delete_values) {
2889         next unless defined $id;
2890         my ( $err, $msg ) = $Object->DeleteValue($id);
2891         push( @results, $msg );
2892     }
2893
2894     my $vals = $Object->Values();
2895     while ( my $cfv = $vals->Next() ) {
2896         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2897             if ( $cfv->SortOrder != $so ) {
2898                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2899                 push( @results, $msg );
2900             }
2901         }
2902     }
2903
2904     return (@results);
2905 }
2906
2907
2908
2909 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2910
2911 Returns an array of results messages.
2912
2913 =cut
2914
2915 sub ProcessTicketBasics {
2916
2917     my %args = (
2918         TicketObj => undef,
2919         ARGSRef   => undef,
2920         @_
2921     );
2922
2923     my $TicketObj = $args{'TicketObj'};
2924     my $ARGSRef   = $args{'ARGSRef'};
2925
2926     my $OrigOwner = $TicketObj->Owner;
2927
2928     # Set basic fields
2929     my @attribs = qw(
2930         Subject
2931         FinalPriority
2932         Priority
2933         TimeEstimated
2934         TimeWorked
2935         TimeLeft
2936         Type
2937         Status
2938         Queue
2939     );
2940
2941     # Canonicalize Queue and Owner to their IDs if they aren't numeric
2942     for my $field (qw(Queue Owner)) {
2943         if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2944             my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2945             my $temp = $class->new(RT->SystemUser);
2946             $temp->Load( $ARGSRef->{$field} );
2947             if ( $temp->id ) {
2948                 $ARGSRef->{$field} = $temp->id;
2949             }
2950         }
2951     }
2952
2953     # Status isn't a field that can be set to a null value.
2954     # RT core complains if you try
2955     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2956
2957     my @results = UpdateRecordObject(
2958         AttributesRef => \@attribs,
2959         Object        => $TicketObj,
2960         ARGSRef       => $ARGSRef,
2961     );
2962
2963     # We special case owner changing, so we can use ForceOwnerChange
2964     if ( $ARGSRef->{'Owner'}
2965       && $ARGSRef->{'Owner'} !~ /\D/
2966       && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2967         my ($ChownType);
2968         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2969             $ChownType = "Force";
2970         }
2971         else {
2972             $ChownType = "Set";
2973         }
2974
2975         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2976         push( @results, $msg );
2977     }
2978
2979     # }}}
2980
2981     return (@results);
2982 }
2983
2984 sub ProcessTicketReminders {
2985     my %args = (
2986         TicketObj => undef,
2987         ARGSRef   => undef,
2988         @_
2989     );
2990
2991     my $Ticket = $args{'TicketObj'};
2992     my $args   = $args{'ARGSRef'};
2993     my @results;
2994
2995     my $reminder_collection = $Ticket->Reminders->Collection;
2996
2997     if ( $args->{'update-reminders'} ) {
2998         while ( my $reminder = $reminder_collection->Next ) {
2999             my $resolve_status = $reminder->LifecycleObj->ReminderStatusOnResolve;
3000             my ( $status, $msg, $old_subject, @subresults );
3001             if (   $reminder->Status ne $resolve_status
3002                 && $args->{ 'Complete-Reminder-' . $reminder->id } )
3003             {
3004                 ( $status, $msg ) = $Ticket->Reminders->Resolve($reminder);
3005                 push @subresults, $msg;
3006             }
3007             elsif ( $reminder->Status eq $resolve_status
3008                 && !$args->{ 'Complete-Reminder-' . $reminder->id } )
3009             {
3010                 ( $status, $msg ) = $Ticket->Reminders->Open($reminder);
3011                 push @subresults, $msg;
3012             }
3013
3014             if (
3015                 exists( $args->{ 'Reminder-Subject-' . $reminder->id } )
3016                 && ( $reminder->Subject ne
3017                     $args->{ 'Reminder-Subject-' . $reminder->id } )
3018               )
3019             {
3020                 $old_subject = $reminder->Subject;
3021                 ( $status, $msg ) =
3022                   $reminder->SetSubject(
3023                     $args->{ 'Reminder-Subject-' . $reminder->id } );
3024                 push @subresults, $msg;
3025             }
3026
3027             if (
3028                 exists( $args->{ 'Reminder-Owner-' . $reminder->id } )
3029                 && ( $reminder->Owner !=
3030                     $args->{ 'Reminder-Owner-' . $reminder->id } )
3031               )
3032             {
3033                 ( $status, $msg ) =
3034                   $reminder->SetOwner(
3035                     $args->{ 'Reminder-Owner-' . $reminder->id }, "Force" );
3036                 push @subresults, $msg;
3037             }
3038
3039             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } )
3040                 && $args->{ 'Reminder-Due-' . $reminder->id } ne '' )
3041             {
3042                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3043                 my $due     = $args->{ 'Reminder-Due-' . $reminder->id };
3044
3045                 $DateObj->Set(
3046                     Format => 'unknown',
3047                     Value  => $due,
3048                 );
3049                 if ( $DateObj->Unix != $reminder->DueObj->Unix ) {
3050                     ( $status, $msg ) = $reminder->SetDue( $DateObj->ISO );
3051                 }
3052                 else {
3053                     $msg = loc( "invalid due date: [_1]", $due );
3054                 }
3055
3056                 push @subresults, $msg;
3057             }
3058
3059             push @results, map {
3060                 loc( "Reminder '[_1]': [_2]", $old_subject || $reminder->Subject, $_ )
3061             } @subresults;
3062         }
3063     }
3064
3065     if ( $args->{'NewReminder-Subject'} ) {
3066         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
3067         $due_obj->Set(
3068           Format => 'unknown',
3069           Value => $args->{'NewReminder-Due'}
3070         );
3071         my ( $status, $msg ) = $Ticket->Reminders->Add(
3072             Subject => $args->{'NewReminder-Subject'},
3073             Owner   => $args->{'NewReminder-Owner'},
3074             Due     => $due_obj->ISO
3075         );
3076         if ( $status ) {
3077             push @results,
3078               loc( "Reminder '[_1]': [_2]", $args->{'NewReminder-Subject'}, loc("Created") )
3079         }
3080         else {
3081             push @results, $msg;
3082         }
3083     }
3084     return @results;
3085 }
3086
3087 sub ProcessObjectCustomFieldUpdates {
3088     my %args    = @_;
3089     my $ARGSRef = $args{'ARGSRef'};
3090     my @results;
3091
3092     # Build up a list of objects that we want to work with
3093     my %custom_fields_to_mod = _ParseObjectCustomFieldArgs($ARGSRef);
3094
3095     # For each of those objects
3096     foreach my $class ( keys %custom_fields_to_mod ) {
3097         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
3098             my $Object = $args{'Object'};
3099             $Object = $class->new( $session{'CurrentUser'} )
3100                 unless $Object && ref $Object eq $class;
3101
3102             # skip if we have no object to update
3103             next unless $id || $Object->id;
3104
3105             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
3106             unless ( $Object->id ) {
3107                 $RT::Logger->warning("Couldn't load object $class #$id");
3108                 next;
3109             }
3110
3111             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
3112                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
3113                 $CustomFieldObj->SetContextObject($Object);
3114                 $CustomFieldObj->LoadById($cf);
3115                 unless ( $CustomFieldObj->id ) {
3116                     $RT::Logger->warning("Couldn't load custom field #$cf");
3117                     next;
3118                 }
3119                 my @groupings = sort keys %{ $custom_fields_to_mod{$class}{$id}{$cf} };
3120                 if (@groupings > 1) {
3121                     # Check for consistency, in case of JS fail
3122                     for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3123                         my $base = $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]}{$key};
3124                         $base = [ $base ] unless ref $base;
3125                         for my $grouping (@groupings[1..$#groupings]) {
3126                             my $other = $custom_fields_to_mod{$class}{$id}{$cf}{$grouping}{$key};
3127                             $other = [ $other ] unless ref $other;
3128                             warn "CF $cf submitted with multiple differing values"
3129                                 if grep {$_} List::MoreUtils::pairwise {
3130                                     no warnings qw(uninitialized);
3131                                     $a ne $b
3132                                 } @{$base}, @{$other};
3133                         }
3134                     }
3135                     # We'll just be picking the 1st grouping in the hash, alphabetically
3136                 }
3137                 push @results,
3138                     _ProcessObjectCustomFieldUpdates(
3139                         Prefix => GetCustomFieldInputNamePrefix(
3140                             Object      => $Object,
3141                             CustomField => $CustomFieldObj,
3142                             Grouping    => $groupings[0],
3143                         ),
3144                         Object      => $Object,
3145                         CustomField => $CustomFieldObj,
3146                         ARGS        => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] },
3147                     );
3148             }
3149         }
3150     }
3151     return @results;
3152 }
3153
3154 sub _ParseObjectCustomFieldArgs {
3155     my $ARGSRef = shift || {};
3156     my %args = (
3157         IncludeBulkUpdate => 0,
3158         @_,
3159     );
3160     my %custom_fields_to_mod;
3161
3162     foreach my $arg ( keys %$ARGSRef ) {
3163
3164         # format: Object-<object class>-<object id>-CustomField[:<grouping>]-<CF id>-<commands>
3165         # you can use GetCustomFieldInputName to generate the complement input name
3166         # or if IncludeBulkUpdate: Bulk-<Add or Delete>-CustomField[:<grouping>]-<CF id>-<commands>
3167         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField(?::(\w+))?-(\d+)-(.*)$/
3168                  || ($args{IncludeBulkUpdate} && $arg =~ /^Bulk-(?:Add|Delete)-()()CustomField(?::(\w+))?-(\d+)-(.*)$/);
3169         # need two empty groups because we must consume $1 and $2 with empty
3170         # class and ID
3171
3172         next if $1 eq 'RT::Transaction';# don't try to update transaction fields
3173
3174         # For each of those objects, find out what custom fields we want to work with.
3175         #                   Class     ID     CF  grouping command
3176         $custom_fields_to_mod{$1}{ $2 || 0 }{$4}{$3 || ''}{$5} = $ARGSRef->{$arg};
3177     }
3178
3179     return wantarray ? %custom_fields_to_mod : \%custom_fields_to_mod;
3180 }
3181
3182 sub _ProcessObjectCustomFieldUpdates {
3183     my %args    = @_;
3184     my $cf      = $args{'CustomField'};
3185     my $cf_type = $cf->Type || '';
3186
3187     # Remove blank Values since the magic field will take care of this. Sometimes
3188     # the browser gives you a blank value which causes CFs to be processed twice
3189     if (   defined $args{'ARGS'}->{'Values'}
3190         && !length $args{'ARGS'}->{'Values'}
3191         && ($args{'ARGS'}->{'Values-Magic'}) )
3192     {
3193         delete $args{'ARGS'}->{'Values'};
3194     }
3195
3196     my @results;
3197     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
3198
3199         # skip category argument
3200         next if $arg =~ /-Category$/;
3201
3202         # and TimeUnits
3203         next if $arg eq 'Value-TimeUnits';
3204
3205         # since http won't pass in a form element with a null value, we need
3206         # to fake it
3207         if ( $arg =~ /-Magic$/ ) {
3208
3209             # We don't care about the magic, if there's really a values element;
3210             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
3211             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
3212
3213             # "Empty" values does not mean anything for Image and Binary fields
3214             next if $cf_type =~ /^(?:Image|Binary)$/;
3215
3216             $arg = 'Values';
3217             $args{'ARGS'}->{'Values'} = undef;
3218         }
3219
3220         my @values = _NormalizeObjectCustomFieldValue(
3221             CustomField => $cf,
3222             Param       => $args{'Prefix'} . $arg,
3223             Value       => $args{'ARGS'}->{$arg}
3224         );
3225
3226         # "Empty" values still don't mean anything for Image and Binary fields
3227         next if $cf_type =~ /^(?:Image|Binary)$/ and not @values;
3228
3229         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
3230             foreach my $value (@values) {
3231                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3232                     Field => $cf->id,
3233                     Value => $value
3234                 );
3235                 push( @results, $msg );
3236             }
3237         } elsif ( $arg eq 'Upload' ) {
3238             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %{$values[0]}, Field => $cf, );
3239             push( @results, $msg );
3240         } elsif ( $arg eq 'DeleteValues' ) {
3241             foreach my $value (@values) {
3242                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3243                     Field => $cf,
3244                     Value => $value,
3245                 );
3246                 push( @results, $msg );
3247             }
3248         } elsif ( $arg eq 'DeleteValueIds' ) {
3249             foreach my $value (@values) {
3250                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3251                     Field   => $cf,
3252                     ValueId => $value,
3253                 );
3254                 push( @results, $msg );
3255             }
3256         } elsif ( $arg eq 'Values' ) {
3257             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
3258
3259             my %values_hash;
3260             foreach my $value (@values) {
3261                 if ( my $entry = $cf_values->HasEntry($value) ) {
3262                     $values_hash{ $entry->id } = 1;
3263                     next;
3264                 }
3265
3266                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3267                     Field => $cf,
3268                     Value => $value
3269                 );
3270                 push( @results, $msg );
3271                 $values_hash{$val} = 1 if $val;
3272             }
3273
3274             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3275             return @results if ( $cf->Type eq 'Date' && ! @values );
3276
3277             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3278             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
3279
3280             $cf_values->RedoSearch;
3281             while ( my $cf_value = $cf_values->Next ) {
3282                 next if $values_hash{ $cf_value->id };
3283
3284                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3285                     Field   => $cf,
3286                     ValueId => $cf_value->id
3287                 );
3288                 push( @results, $msg );
3289             }
3290         } else {
3291             push(
3292                 @results,
3293                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
3294                     $cf->Name, ref $args{'Object'},
3295                     $args{'Object'}->id
3296                 )
3297             );
3298         }
3299     }
3300     return @results;
3301 }
3302
3303 sub ProcessObjectCustomFieldUpdatesForCreate {
3304     my %args = (
3305         ARGSRef         => {},
3306         ContextObject   => undef,
3307         @_
3308     );
3309     my $context = $args{'ContextObject'};
3310     my %parsed;
3311     my %custom_fields = _ParseObjectCustomFieldArgs( $args{'ARGSRef'} );
3312
3313     for my $class (keys %custom_fields) {
3314         # we're only interested in new objects, so only look at $id == 0
3315         for my $cfid (keys %{ $custom_fields{$class}{0} || {} }) {
3316             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3317             if ($context) {
3318                 my $system_cf = RT::CustomField->new( RT->SystemUser );
3319                 $system_cf->LoadById($cfid);
3320                 if ($system_cf->ValidateContextObject($context)) {
3321                     $cf->SetContextObject($context);
3322                 } else {
3323                     RT->Logger->error(
3324                         sprintf "Invalid context object %s (%d) for CF %d; skipping CF",
3325                                 ref $context, $context->id, $system_cf->id
3326                     );
3327                     next;
3328                 }
3329             }
3330             $cf->LoadById($cfid);
3331
3332             unless ($cf->id) {
3333                 RT->Logger->warning("Couldn't load custom field #$cfid");
3334                 next;
3335             }
3336
3337             my @groupings = sort keys %{ $custom_fields{$class}{0}{$cfid} };
3338             if (@groupings > 1) {
3339                 # Check for consistency, in case of JS fail
3340                 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3341                     warn "CF $cfid submitted with multiple differing $key"
3342                         if grep {($custom_fields{$class}{0}{$cfid}{$_}{$key} || '')
3343                              ne  ($custom_fields{$class}{0}{$cfid}{$groupings[0]}{$key} || '')}
3344                             @groupings;
3345                 }
3346                 # We'll just be picking the 1st grouping in the hash, alphabetically
3347             }
3348
3349             my @values;
3350             my $name_prefix = GetCustomFieldInputNamePrefix(
3351                 CustomField => $cf,
3352                 Grouping    => $groupings[0],
3353             );
3354             while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) {
3355                 # Values-Magic doesn't matter on create; no previous values are being removed
3356                 # Category is irrelevant for the actual value
3357                 next if $arg =~ /-Magic$/ or $arg =~ /-Category$/;
3358
3359                 push @values,
3360                     _NormalizeObjectCustomFieldValue(
3361                     CustomField => $cf,
3362                     Param       => $name_prefix . $arg,
3363                     Value       => $value,
3364                     );
3365             }
3366
3367             $parsed{"CustomField-$cfid"} = \@values if @values;
3368         }
3369     }
3370
3371     return wantarray ? %parsed : \%parsed;
3372 }
3373
3374 sub _NormalizeObjectCustomFieldValue {
3375     my %args    = (
3376         Param   => "",
3377         @_
3378     );
3379     my $cf_type = $args{CustomField}->Type;
3380     my @values  = ();
3381
3382     if ( ref $args{'Value'} eq 'ARRAY' ) {
3383         @values = @{ $args{'Value'} };
3384     } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
3385         @values = ( $args{'Value'} );
3386     } else {
3387         @values = split /\r*\n/, $args{'Value'}
3388             if defined $args{'Value'};
3389     }
3390     @values = grep length, map {
3391         s/\r+\n/\n/g;
3392         s/^\s+//;
3393         s/\s+$//;
3394         $_;
3395         }
3396         grep defined, @values;
3397
3398     if ($args{'Param'} =~ /-Upload$/ and $cf_type =~ /^(Image|Binary)$/) {
3399         @values = _UploadedFile( $args{'Param'} ) || ();
3400     }
3401
3402     return @values;
3403 }
3404
3405 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3406
3407 Returns an array of results messages.
3408
3409 =cut
3410
3411 sub ProcessTicketWatchers {
3412     my %args = (
3413         TicketObj => undef,
3414         ARGSRef   => undef,
3415         @_
3416     );
3417     my (@results);
3418
3419     my $Ticket  = $args{'TicketObj'};
3420     my $ARGSRef = $args{'ARGSRef'};
3421
3422     # Munge watchers
3423
3424     foreach my $key ( keys %$ARGSRef ) {
3425
3426         # Delete deletable watchers
3427         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
3428             my ( $code, $msg ) = $Ticket->DeleteWatcher(
3429                 PrincipalId => $2,
3430                 Type        => $1
3431             );
3432             push @results, $msg;
3433         }
3434
3435         # Delete watchers in the simple style demanded by the bulk manipulator
3436         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
3437             my ( $code, $msg ) = $Ticket->DeleteWatcher(
3438                 Email => $ARGSRef->{$key},
3439                 Type  => $1
3440             );
3441             push @results, $msg;
3442         }
3443
3444         # Add new wathchers by email address
3445         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
3446             and $key =~ /^WatcherTypeEmail(\d*)$/ )
3447         {
3448
3449             #They're in this order because otherwise $1 gets clobbered :/
3450             my ( $code, $msg ) = $Ticket->AddWatcher(
3451                 Type  => $ARGSRef->{$key},
3452                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
3453             );
3454             push @results, $msg;
3455         }
3456
3457         #Add requestors in the simple style demanded by the bulk manipulator
3458         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
3459             my ( $code, $msg ) = $Ticket->AddWatcher(
3460                 Type  => $1,
3461                 Email => $ARGSRef->{$key}
3462             );
3463             push @results, $msg;
3464         }
3465
3466         # Add new  watchers by owner
3467         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
3468             my $principal_id = $1;
3469             my $form         = $ARGSRef->{$key};
3470             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
3471                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
3472
3473                 my ( $code, $msg ) = $Ticket->AddWatcher(
3474                     Type        => $value,
3475                     PrincipalId => $principal_id
3476                 );
3477                 push @results, $msg;
3478             }
3479         }
3480
3481     }
3482     return (@results);
3483 }
3484
3485
3486
3487 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3488
3489 Returns an array of results messages.
3490
3491 =cut
3492
3493 sub ProcessTicketDates {
3494     my %args = (
3495         TicketObj => undef,
3496         ARGSRef   => undef,
3497         @_
3498     );
3499
3500     my $Ticket  = $args{'TicketObj'};
3501     my $ARGSRef = $args{'ARGSRef'};
3502
3503     my (@results);
3504
3505     # Set date fields
3506     my @date_fields = qw(
3507         Told
3508         Starts
3509         Started
3510         Due
3511         WillResolve
3512     );
3513
3514     #Run through each field in this list. update the value if apropriate
3515     foreach my $field (@date_fields) {
3516         next unless exists $ARGSRef->{ $field . '_Date' };
3517         next if $ARGSRef->{ $field . '_Date' } eq '';
3518
3519         my ( $code, $msg );
3520
3521         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3522         $DateObj->Set(
3523             Format => 'unknown',
3524             Value  => $ARGSRef->{ $field . '_Date' }
3525         );
3526
3527         my $obj = $field . "Obj";
3528         if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) {
3529             my $method = "Set$field";
3530             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3531             push @results, "$msg";
3532         }
3533     }
3534
3535     # }}}
3536     return (@results);
3537 }
3538
3539
3540
3541 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3542
3543 Returns an array of results messages.
3544
3545 =cut
3546
3547 sub ProcessTicketLinks {
3548     my %args = (
3549         TicketObj => undef,
3550         TicketId  => undef,
3551         ARGSRef   => undef,
3552         @_
3553     );
3554
3555     my $Ticket  = $args{'TicketObj'};
3556     my $TicketId = $args{'TicketId'} || $Ticket->Id;
3557     my $ARGSRef = $args{'ARGSRef'};
3558
3559     my (@results) = ProcessRecordLinks(
3560         %args, RecordObj => $Ticket, RecordId => $TicketId, ARGSRef => $ARGSRef,
3561     );
3562
3563     #Merge if we need to
3564     my $input = $TicketId .'-MergeInto';
3565     if ( $ARGSRef->{ $input } ) {
3566         $ARGSRef->{ $input } =~ s/\s+//g;
3567         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $input } );
3568         push @results, $msg;
3569     }
3570
3571     return (@results);
3572 }
3573
3574
3575 sub ProcessRecordLinks {
3576     my %args = (
3577         RecordObj => undef,
3578         RecordId  => undef,
3579         ARGSRef   => undef,
3580         @_
3581     );
3582
3583     my $Record  = $args{'RecordObj'};
3584     my $RecordId = $args{'RecordId'} || $Record->Id;
3585     my $ARGSRef = $args{'ARGSRef'};
3586
3587     my (@results);
3588
3589     # Delete links that are gone gone gone.
3590     foreach my $arg ( keys %$ARGSRef ) {
3591         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3592             my $base   = $1;
3593             my $type   = $2;
3594             my $target = $3;
3595
3596             my ( $val, $msg ) = $Record->DeleteLink(
3597                 Base   => $base,
3598                 Type   => $type,
3599                 Target => $target
3600             );
3601
3602             push @results, $msg;
3603
3604         }
3605
3606     }
3607
3608     my @linktypes = qw( DependsOn MemberOf RefersTo );
3609
3610     foreach my $linktype (@linktypes) {
3611         my $input = $RecordId .'-'. $linktype;
3612         if ( $ARGSRef->{ $input } ) {
3613             $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3614                 if ref $ARGSRef->{ $input };
3615
3616             for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3617                 next unless $luri;
3618                 $luri =~ s/\s+$//;    # Strip trailing whitespace
3619                 my ( $val, $msg ) = $Record->AddLink(
3620                     Target => $luri,
3621                     Type   => $linktype
3622                 );
3623                 push @results, $msg;
3624             }
3625         }
3626         $input = $linktype .'-'. $RecordId;
3627         if ( $ARGSRef->{ $input } ) {
3628             $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3629                 if ref $ARGSRef->{ $input };
3630
3631             for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3632                 next unless $luri;
3633                 my ( $val, $msg ) = $Record->AddLink(
3634                     Base => $luri,
3635                     Type => $linktype
3636                 );
3637
3638                 push @results, $msg;
3639             }
3640         }
3641     }
3642
3643     return (@results);
3644 }
3645
3646 =head2 ProcessLinksForCreate
3647
3648 Takes a hash with a single key, C<ARGSRef>, the value of which is a hashref to
3649 C<%ARGS>.
3650
3651 Converts and returns submitted args in the form of C<new-LINKTYPE> and
3652 C<LINKTYPE-new> into their appropriate directional link types.  For example,
3653 C<new-DependsOn> becomes C<DependsOn> and C<DependsOn-new> becomes
3654 C<DependedOnBy>.  The incoming arg values are split on whitespace and
3655 normalized into arrayrefs before being returned.
3656
3657 Primarily used by object creation pages for transforming incoming form inputs
3658 from F</Elements/EditLinks> into arguments appropriate for individual record
3659 Create methods.
3660
3661 Returns a hashref in scalar context and a hash in list context.
3662
3663 =cut
3664
3665 sub ProcessLinksForCreate {
3666     my %args = @_;
3667     my %links;
3668
3669     foreach my $type ( keys %RT::Link::DIRMAP ) {
3670         for ([Base => "new-$type"], [Target => "$type-new"]) {
3671             my ($direction, $key) = @$_;
3672             next unless $args{ARGSRef}->{$key};
3673             $links{ $RT::Link::DIRMAP{$type}->{$direction} } = [
3674                 grep $_, split ' ', $args{ARGSRef}->{$key}
3675             ];
3676         }
3677     }
3678     return wantarray ? %links : \%links;
3679 }
3680
3681 =head2 ProcessTransactionSquelching
3682
3683 Takes a hashref of the submitted form arguments, C<%ARGS>.
3684
3685 Returns a hash of squelched addresses.
3686
3687 =cut
3688
3689 sub ProcessTransactionSquelching {
3690     my $args    = shift;
3691     my %checked = map { $_ => 1 } grep { defined }
3692         (    ref $args->{'TxnSendMailTo'} eq "ARRAY"  ? @{$args->{'TxnSendMailTo'}} :
3693          defined $args->{'TxnSendMailTo'}             ?  ($args->{'TxnSendMailTo'}) :
3694                                                                              () );
3695     my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3696     return %squelched;
3697 }
3698
3699 sub ProcessRecordBulkCustomFields {
3700     my %args = (RecordObj => undef, ARGSRef => {}, @_);
3701
3702     my $ARGSRef = $args{'ARGSRef'};
3703
3704     my %data;
3705
3706     my @results;
3707     foreach my $key ( keys %$ARGSRef ) {
3708         next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/;
3709         my ($op, $cfid, $rest) = ($1, $2, $3);
3710         next if $rest =~ /-Category$/;
3711
3712         my $res = $data{$cfid} ||= {};
3713         unless (keys %$res) {
3714             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3715             $cf->Load( $cfid );
3716             next unless $cf->Id;
3717
3718             $res->{'cf'} = $cf;
3719         }
3720
3721         if ( $op eq 'Delete' && $rest eq 'AllValues' ) {
3722             $res->{'DeleteAll'} = $ARGSRef->{$key};
3723             next;
3724         }
3725
3726         my @values = _NormalizeObjectCustomFieldValue(
3727             CustomField => $res->{'cf'},
3728             Value => $ARGSRef->{$key},
3729             Param => $key,
3730         );
3731         next unless @values;
3732         $res->{$op} = \@values;
3733     }
3734
3735     while ( my ($cfid, $data) = each %data ) {
3736         my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid );
3737
3738         # just add one value for fields with single value
3739         if ( $data->{'Add'} && $data->{'cf'}->MaxValues == 1 ) {
3740             next if $current_values->HasEntry($data->{Add}[-1]);
3741
3742             my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3743                 Field => $cfid,
3744                 Value => $data->{'Add'}[-1],
3745             );
3746             push @results, $msg;
3747             next;
3748         }
3749
3750         if ( $data->{'DeleteAll'} ) {
3751             while ( my $value = $current_values->Next ) {
3752                 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3753                     Field   => $cfid,
3754                     ValueId => $value->id,
3755                 );
3756                 push @results, $msg;
3757             }
3758         }
3759         foreach my $value ( @{ $data->{'Delete'} || [] } ) {
3760             my $entry = $current_values->HasEntry($value);
3761             next unless $entry;
3762
3763             my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3764                 Field   => $cfid,
3765                 ValueId => $entry->id,
3766             );
3767             push @results, $msg;
3768         }
3769         foreach my $value ( @{ $data->{'Add'} || [] } ) {
3770             next if $current_values->HasEntry($value);
3771
3772             my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3773                 Field => $cfid,
3774                 Value => $value
3775             );
3776             push @results, $msg;
3777         }
3778     }
3779     return @results;
3780 }
3781
3782 =head2 _UploadedFile ( $arg );
3783
3784 Takes a CGI parameter name; if a file is uploaded under that name,
3785 return a hash reference suitable for AddCustomFieldValue's use:
3786 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3787
3788 Returns C<undef> if no files were uploaded in the C<$arg> field.
3789
3790 =cut
3791
3792 sub _UploadedFile {
3793     my $arg         = shift;
3794     my $cgi_object  = $m->cgi_object;
3795     my $fh          = $cgi_object->upload($arg) or return undef;
3796     my $upload_info = $cgi_object->uploadInfo($fh);
3797
3798     my $filename = "$fh";
3799     $filename =~ s#^.*[\\/]##;
3800     binmode($fh);
3801
3802     return {
3803         Value        => $filename,
3804         LargeContent => do { local $/; scalar <$fh> },
3805         ContentType  => $upload_info->{'Content-Type'},
3806     };
3807 }
3808
3809 sub GetColumnMapEntry {
3810     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3811
3812     # deal with the simplest thing first
3813     if ( $args{'Map'}{ $args{'Name'} } ) {
3814         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3815     }
3816
3817     # complex things
3818     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3819         $subkey =~ s/^\{(.*)\}$/$1/;
3820         return undef unless $args{'Map'}->{$mainkey};
3821         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3822             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3823
3824         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3825     }
3826     return undef;
3827 }
3828
3829 sub ProcessColumnMapValue {
3830     my $value = shift;
3831     my %args = ( Arguments => [], Escape => 1, @_ );
3832
3833     if ( ref $value ) {
3834         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3835             my @tmp = $value->( @{ $args{'Arguments'} } );
3836             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3837         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3838             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3839         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3840             return $$value;
3841         }
3842     } else {
3843         if ($args{'Escape'}) {
3844             $value = $m->interp->apply_escapes( $value, 'h' );
3845             $value =~ s/\n/<br>/g if defined $value;
3846         }
3847         return $value;
3848     }
3849 }
3850
3851 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3852
3853 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3854 principal collections mapped from the categories given.
3855
3856 =cut
3857
3858 sub GetPrincipalsMap {
3859     my $object = shift;
3860     my @map;
3861     for (@_) {
3862         if (/System/) {
3863             my $system = RT::Groups->new($session{'CurrentUser'});
3864             $system->LimitToSystemInternalGroups();
3865             $system->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3866             push @map, [
3867                 'System' => $system,    # loc_left_pair
3868                 'Name'   => 1,
3869             ];
3870         }
3871         elsif (/Groups/) {
3872             my $groups = RT::Groups->new($session{'CurrentUser'});
3873             $groups->LimitToUserDefinedGroups();
3874             $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3875
3876             # Only show groups who have rights granted on this object
3877             $groups->WithGroupRight(
3878                 Right   => '',
3879                 Object  => $object,
3880                 IncludeSystemRights => 0,
3881                 IncludeSubgroupMembers => 0,
3882             );
3883
3884             push @map, [
3885                 'User Groups' => $groups,   # loc_left_pair
3886                 'Name'        => 0
3887             ];
3888         }
3889         elsif (/Roles/) {
3890             my $roles = RT::Groups->new($session{'CurrentUser'});
3891
3892             if ($object->isa("RT::CustomField")) {
3893                 # If we're a custom field, show the global roles for our LookupType.
3894                 my $class = $object->RecordClassFromLookupType;
3895                 if ($class and $class->DOES("RT::Record::Role::Roles")) {
3896                     $roles->LimitToRolesForObject(RT->System);
3897                     $roles->Limit(
3898                         FIELD         => "Name",
3899                         FUNCTION      => 'LOWER(?)',
3900                         OPERATOR      => "IN",
3901                         VALUE         => [ map {lc $_} $class->Roles ],
3902                         CASESENSITIVE => 1,
3903                     );
3904                 } else {
3905                     # No roles to show; so show nothing
3906                     undef $roles;
3907                 }
3908             } else {
3909                 $roles->LimitToRolesForObject($object);
3910             }
3911
3912             if ($roles) {
3913                 $roles->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3914                 push @map, [
3915                     'Roles' => $roles,  # loc_left_pair
3916                     'Name'  => 1
3917                 ];
3918             }
3919         }
3920         elsif (/Users/) {
3921             my $Users = RT->PrivilegedUsers->UserMembersObj();
3922             $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3923
3924             # Only show users who have rights granted on this object
3925             my $group_members = $Users->WhoHaveGroupRight(
3926                 Right   => '',
3927                 Object  => $object,
3928                 IncludeSystemRights => 0,
3929                 IncludeSubgroupMembers => 0,
3930             );
3931
3932             # Limit to UserEquiv groups
3933             my $groups = $Users->Join(
3934                 ALIAS1 => $group_members,
3935                 FIELD1 => 'GroupId',
3936                 TABLE2 => 'Groups',
3937                 FIELD2 => 'id',
3938             );
3939             $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence', CASESENSITIVE => 0 );
3940             $Users->Limit( ALIAS => $groups, FIELD => 'Name', VALUE => 'UserEquiv', CASESENSITIVE => 0 );
3941
3942             push @map, [
3943                 'Users' => $Users,  # loc_left_pair
3944                 'Format' => 0
3945             ];
3946         }
3947     }
3948     return @map;
3949 }
3950
3951 =head2 _load_container_object ( $type, $id );
3952
3953 Instantiate container object for saving searches.
3954
3955 =cut
3956
3957 sub _load_container_object {
3958     my ( $obj_type, $obj_id ) = @_;
3959     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3960 }
3961
3962 =head2 _parse_saved_search ( $arg );
3963
3964 Given a serialization string for saved search, and returns the
3965 container object and the search id.
3966
3967 =cut
3968
3969 sub _parse_saved_search {
3970     my $spec = shift;
3971     return unless $spec;
3972     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3973         return;
3974     }
3975     my $obj_type  = $1;
3976     my $obj_id    = $2;
3977     my $search_id = $3;
3978
3979     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3980 }
3981
3982 =head2 ScrubHTML content
3983
3984 Removes unsafe and undesired HTML from the passed content
3985
3986 =cut
3987
3988 my $SCRUBBER;
3989 sub ScrubHTML {
3990     my $Content = shift;
3991     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3992
3993     $Content = '' if !defined($Content);
3994     return $SCRUBBER->scrub($Content);
3995 }
3996
3997 =head2 _NewScrubber
3998
3999 Returns a new L<HTML::Scrubber> object.
4000
4001 If you need to be more lax about what HTML tags and attributes are allowed,
4002 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
4003 following:
4004
4005     package HTML::Mason::Commands;
4006     # Let tables through
4007     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
4008     1;
4009
4010 =cut
4011
4012 our @SCRUBBER_ALLOWED_TAGS = qw(
4013     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP S DEL STRIKE H1 H2 H3 H4 H5
4014     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
4015 );
4016
4017 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
4018     # Match http, https, ftp, mailto and relative urls
4019     # XXX: we also scrub format strings with this module then allow simple config options
4020     href   => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|HomePath|BaseURL|URL)__)}i,
4021     face   => 1,
4022     size   => 1,
4023     color  => 1,
4024     target => 1,
4025     style  => qr{
4026         ^(?:\s*
4027             (?:(?:background-)?color: \s*
4028                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
4029                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
4030                        [\w\-]+                                  # green, light-blue, etc.
4031                        )                            |
4032                text-align: \s* \w+                  |
4033                font-size: \s* [\w.\-]+              |
4034                font-family: \s* [\w\s"',.\-]+       |
4035                font-weight: \s* [\w\-]+             |
4036
4037                border-style: \s* \w+                |
4038                border-color: \s* [#\w]+             |
4039                border-width: \s* [\s\w]+            |
4040                padding: \s* [\s\w]+                 |
4041                margin: \s* [\s\w]+                  |
4042
4043                # MS Office styles, which are probably fine.  If we don't, then any
4044                # associated styles in the same attribute get stripped.
4045                mso-[\w\-]+?: \s* [\w\s"',.\-]+
4046             )\s* ;? \s*)
4047          +$ # one or more of these allowed properties from here 'till sunset
4048     }ix,
4049     dir    => qr/^(rtl|ltr)$/i,
4050     lang   => qr/^\w+(-\w+)?$/,
4051 );
4052
4053 our %SCRUBBER_RULES = ();
4054
4055 # If we're displaying images, let embedded ones through
4056 if (RT->Config->Get('ShowTransactionImages') or RT->Config->Get('ShowRemoteImages')) {
4057     $SCRUBBER_RULES{'img'} = {
4058         '*' => 0,
4059         alt => 1,
4060     };
4061
4062     my @src;
4063     push @src, qr/^cid:/i
4064         if RT->Config->Get('ShowTransactionImages');
4065
4066     push @src, $SCRUBBER_ALLOWED_ATTRIBUTES{'href'}
4067         if RT->Config->Get('ShowRemoteImages');
4068
4069     $SCRUBBER_RULES{'img'}->{'src'} = join "|", @src;
4070 }
4071
4072 sub _NewScrubber {
4073     require HTML::Scrubber;
4074     my $scrubber = HTML::Scrubber->new();
4075
4076     if (HTML::Gumbo->require) {
4077         no warnings 'redefine';
4078         my $orig = \&HTML::Scrubber::scrub;
4079         *HTML::Scrubber::scrub = sub {
4080             my $self = shift;
4081
4082             eval { $_[0] = HTML::Gumbo->new->parse( $_[0] ); chomp $_[0] };
4083             warn "HTML::Gumbo pre-parse failed: $@" if $@;
4084             return $orig->($self, @_);
4085         };
4086         push @SCRUBBER_ALLOWED_TAGS, qw/TABLE THEAD TBODY TFOOT TR TD TH/;
4087         $SCRUBBER_ALLOWED_ATTRIBUTES{$_} = 1 for
4088             qw/colspan rowspan align valign cellspacing cellpadding border width height/;
4089     }
4090
4091     $scrubber->default(
4092         0,
4093         {
4094             %SCRUBBER_ALLOWED_ATTRIBUTES,
4095             '*' => 0, # require attributes be explicitly allowed
4096         },
4097     );
4098     $scrubber->deny(qw[*]);
4099     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
4100     $scrubber->rules(%SCRUBBER_RULES);
4101
4102     # Scrubbing comments is vital since IE conditional comments can contain
4103     # arbitrary HTML and we'd pass it right on through.
4104     $scrubber->comment(0);
4105
4106     return $scrubber;
4107 }
4108
4109 =head2 JSON
4110
4111 Redispatches to L<RT::Interface::Web/EncodeJSON>
4112
4113 =cut
4114
4115 sub JSON {
4116     RT::Interface::Web::EncodeJSON(@_);
4117 }
4118
4119 sub CSSClass {
4120     my $value = shift;
4121     return '' unless defined $value;
4122     $value =~ s/[^A-Za-z0-9_-]/_/g;
4123     return $value;
4124 }
4125
4126 sub GetCustomFieldInputName {
4127     RT::Interface::Web::GetCustomFieldInputName(@_);
4128 }
4129
4130 sub GetCustomFieldInputNamePrefix {
4131     RT::Interface::Web::GetCustomFieldInputNamePrefix(@_);
4132 }
4133
4134 package RT::Interface::Web;
4135 RT::Base->_ImportOverlays();
4136
4137 1;