rt/lib/RT/Interface/Web.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2015 Best Practical Solutions, LLC
   6 #                                          <sales@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  13 # This work is made available to you under the terms of Version 2 of
  14 # the GNU General Public License. A copy of that license should have
  15 # been provided with this software, but in any event can be snarfed
  16 # from www.gnu.org.
  17 #
  18 # This work is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 # 02110-1301 or visit their web page on the internet at
  27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  32 # (The following paragraph is not intended to limit the rights granted
  33 # to you to modify and distribute this software under the terms of
  34 # the GNU General Public License and is only of importance to you if
  35 # you choose to contribute your changes and enhancements to the
  36 # community by submitting them to Best Practical Solutions, LLC.)
  37 #
  38 # By intentionally submitting any modifications, corrections or
  39 # derivatives to this work, or any other work intended for use with
  40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  41 # you are the copyright holder for those contributions and you grant
  42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  43 # royalty-free, perpetual, license to use, copy, create derivative
  44 # works based on those contributions, and sublicense and distribute
  45 # those contributions and any derivatives thereof.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48
  49 ## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
  50
  51 ## This is a library of static subs to be used by the Mason web
  52 ## interface to RT
  53
  54 =head1 NAME
  55
  56 RT::Interface::Web
  57
  58
  59 =cut
  60
  61 use strict;
  62 use warnings;
  63
  64 package RT::Interface::Web;
  65
  66 use RT::SavedSearches;
  67 use URI qw();
  68 use RT::Interface::Web::Menu;
  69 use RT::Interface::Web::Session;
  70 use Digest::MD5 ();
  71 use List::MoreUtils qw();
  72 use JSON qw();
  73 use Plack::Util;
  74
  75 =head2 SquishedCSS $style
  76
  77 =cut
  78
  79 my %SQUISHED_CSS;
  80 sub SquishedCSS {
  81     my $style = shift or die "need name";
  82     return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
  83     require RT::Squish::CSS;
  84     my $css = RT::Squish::CSS->new( Style => $style );
  85     $SQUISHED_CSS{ $css->Style } = $css;
  86     return $css;
  87 }
  88
  89 =head2 SquishedJS
  90
  91 =cut
  92
  93 my $SQUISHED_JS;
  94 sub SquishedJS {
  95     return $SQUISHED_JS if $SQUISHED_JS;
  96
  97     require RT::Squish::JS;
  98     my $js = RT::Squish::JS->new();
  99     $SQUISHED_JS = $js;
 100     return $js;
 101 }
 102
 103 =head2 JSFiles
 104
 105 =cut
 106
 107 sub JSFiles {
 108     return qw{
 109       jquery-1.9.1.min.js
 110       jquery_noconflict.js
 111       jquery-ui-1.10.0.custom.min.js
 112       jquery-ui-timepicker-addon.js
 113       jquery-ui-patch-datepicker.js
 114       jquery.modal.min.js
 115       jquery.modal-defaults.js
 116       jquery.cookie.js
 117       titlebox-state.js
 118       i18n.js
 119       util.js
 120       autocomplete.js
 121       jquery.event.hover-1.0.js
 122       superfish.js
 123       supersubs.js
 124       jquery.supposition.js
 125       history-folding.js
 126       cascaded.js
 127       forms.js
 128       event-registration.js
 129       late.js
 130       /static/RichText/ckeditor.js
 131       }, RT->Config->Get('JSFiles');
 132 }
 133
 134 =head2 ClearSquished
 135
 136 Removes the cached CSS and JS entries, forcing them to be regenerated
 137 on next use.
 138
 139 =cut
 140
 141 sub ClearSquished {
 142     undef $SQUISHED_JS;
 143     %SQUISHED_CSS = ();
 144 }
 145
 146 =head2 EscapeHTML SCALARREF
 147
 148 does a css-busting but minimalist escaping of whatever html you're passing in.
 149
 150 =cut
 151
 152 sub EscapeHTML {
 153     my $ref = shift;
 154     return unless defined $$ref;
 155
 156     $$ref =~ s/&/&#38;/g;
 157     $$ref =~ s/</&lt;/g;
 158     $$ref =~ s/>/&gt;/g;
 159     $$ref =~ s/\(/&#40;/g;
 160     $$ref =~ s/\)/&#41;/g;
 161     $$ref =~ s/"/&#34;/g;
 162     $$ref =~ s/'/&#39;/g;
 163 }
 164
 165 # Back-compat
 166 # XXX: Remove in 4.4
 167 sub EscapeUTF8 {
 168     RT->Deprecated(
 169         Instead => "EscapeHTML",
 170         Remove => "4.4",
 171     );
 172     EscapeHTML(@_);
 173 }
 174
 175 =head2 EscapeURI SCALARREF
 176
 177 Escapes URI component according to RFC2396
 178
 179 =cut
 180
 181 sub EscapeURI {
 182     my $ref = shift;
 183     return unless defined $$ref;
 184
 185     use bytes;
 186     $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
 187 }
 188
 189 =head2 EncodeJSON SCALAR
 190
 191 Encodes the SCALAR to JSON and returns a JSON Unicode (B<not> UTF-8) string.
 192 SCALAR may be a simple value or a reference.
 193
 194 =cut
 195
 196 sub EncodeJSON {
 197     my $s = JSON::to_json(shift, { allow_nonref => 1 });
 198     $s =~ s{/}{\\/}g;
 199     return $s;
 200 }
 201
 202 sub _encode_surrogates {
 203     my $uni = $_[0] - 0x10000;
 204     return ($uni /  0x400 + 0xD800, $uni % 0x400 + 0xDC00);
 205 }
 206
 207 sub EscapeJS {
 208     my $ref = shift;
 209     return unless defined $$ref;
 210
 211     $$ref = "'" . join('',
 212                  map {
 213                      chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
 214                      $_  <= 255   ? sprintf("\\x%02X", $_) :
 215                      $_  <= 65535 ? sprintf("\\u%04X", $_) :
 216                      sprintf("\\u%X\\u%X", _encode_surrogates($_))
 217                  } unpack('U*', $$ref))
 218         . "'";
 219 }
 220
 221 =head2 WebCanonicalizeInfo();
 222
 223 Different web servers set different environmental varibles. This
 224 function must return something suitable for REMOTE_USER. By default,
 225 just downcase $ENV{'REMOTE_USER'}
 226
 227 =cut
 228
 229 sub WebCanonicalizeInfo {
 230     return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
 231 }
 232
 233
 234
 235 =head2 WebRemoteUserAutocreateInfo($user);
 236
 237 Returns a hash of user attributes, used when WebRemoteUserAutocreate is set.
 238
 239 =cut
 240
 241 sub WebRemoteUserAutocreateInfo {
 242     my $user = shift;
 243
 244     my %user_info;
 245
 246     # default to making Privileged users, even if they specify
 247     # some other default Attributes
 248     if ( !$RT::UserAutocreateDefaultsOnLogin
 249         || ( ref($RT::UserAutocreateDefaultsOnLogin) && not exists $RT::UserAutocreateDefaultsOnLogin->{Privileged} ) )
 250     {
 251         $user_info{'Privileged'} = 1;
 252     }
 253
 254     # Populate fields with information from Unix /etc/passwd
 255     my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
 256     $user_info{'Comments'} = $comments if defined $comments;
 257     $user_info{'RealName'} = $realname if defined $realname;
 258
 259     # and return the wad of stuff
 260     return {%user_info};
 261 }
 262
 263
 264 sub HandleRequest {
 265     my $ARGS = shift;
 266
 267     if (RT->Config->Get('DevelMode')) {
 268         require Module::Refresh;
 269         Module::Refresh->refresh;
 270     }
 271
 272     $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
 273
 274     $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
 275
 276     # Roll back any dangling transactions from a previous failed connection
 277     $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
 278
 279     MaybeEnableSQLStatementLog();
 280
 281     # avoid reentrancy, as suggested by masonbook
 282     local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
 283
 284     $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
 285         if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
 286
 287     ValidateWebConfig();
 288
 289     DecodeARGS($ARGS);
 290     local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
 291     PreprocessTimeUpdates($ARGS);
 292
 293     InitializeMenu();
 294     MaybeShowInstallModePage();
 295
 296     $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
 297     SendSessionCookie();
 298
 299     if ( _UserLoggedIn() ) {
 300         # make user info up to date
 301         $HTML::Mason::Commands::session{'CurrentUser'}
 302           ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
 303         undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
 304     }
 305     else {
 306         $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
 307     }
 308
 309     # Process session-related callbacks before any auth attempts
 310     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
 311
 312     MaybeRejectPrivateComponentRequest();
 313
 314     MaybeShowNoAuthPage($ARGS);
 315
 316     AttemptExternalAuth($ARGS) if RT->Config->Get('WebRemoteUserContinuous') or not _UserLoggedIn();
 317
 318     _ForceLogout() unless _UserLoggedIn();
 319
 320     # Process per-page authentication callbacks
 321     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
 322
 323     if ( $ARGS->{'NotMobile'} ) {
 324         $HTML::Mason::Commands::session{'NotMobile'} = 1;
 325     }
 326
 327     unless ( _UserLoggedIn() ) {
 328         _ForceLogout();
 329
 330         # Authenticate if the user is trying to login via user/pass query args
 331         my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
 332
 333         unless ($authed) {
 334             my $m = $HTML::Mason::Commands::m;
 335
 336             # REST urls get a special 401 response
 337             if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
 338                 $HTML::Mason::Commands::r->content_type("text/plain; charset=utf-8");
 339                 $m->error_format("text");
 340                 $m->out("RT/$RT::VERSION 401 Credentials required\n");
 341                 $m->out("\n$msg\n") if $msg;
 342                 $m->abort;
 343             }
 344             # Specially handle /index.html and /m/index.html so that we get a nicer URL
 345             elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
 346                 my $mobile = $1 ? 1 : 0;
 347                 my $next   = SetNextPage($ARGS);
 348                 $m->comp('/NoAuth/Login.html',
 349                     next    => $next,
 350                     actions => [$msg],
 351                     mobile  => $mobile);
 352                 $m->abort;
 353             }
 354             else {
 355                 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
 356             }
 357         }
 358     }
 359
 360     MaybeShowInterstitialCSRFPage($ARGS);
 361
 362     # now it applies not only to home page, but any dashboard that can be used as a workspace
 363     $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
 364         if ( $ARGS->{'HomeRefreshInterval'} );
 365
 366     # Process per-page global callbacks
 367     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
 368
 369     ShowRequestedPage($ARGS);
 370     LogRecordedSQLStatements(RequestData => {
 371         Path => $HTML::Mason::Commands::m->request_path,
 372     });
 373
 374     # Process per-page final cleanup callbacks
 375     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
 376
 377     $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
 378       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 links 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 links 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 links 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 # Components which are blacklisted from automatic, argument-based whitelisting.
1390 # These pages are not idempotent when called with just an id.
1391 our %is_blacklisted_component = (
1392     # Takes only id and toggles bookmark state
1393     '/Helpers/Toggle/TicketBookmark' => 1,
1394 );
1395
1396 sub IsCompCSRFWhitelisted {
1397     my $comp = shift;
1398     my $ARGS = shift;
1399
1400     return 1 if $is_whitelisted_component{$comp};
1401
1402     my %args = %{ $ARGS };
1403
1404     # If the user specifies a *correct* user and pass then they are
1405     # golden.  This acts on the presumption that external forms may
1406     # hardcode a username and password -- if a malicious attacker knew
1407     # both already, CSRF is the least of your problems.
1408     my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1409     if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1410         my $user_obj = RT::CurrentUser->new();
1411         $user_obj->Load($args{user});
1412         return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1413
1414         delete $args{user};
1415         delete $args{pass};
1416     }
1417
1418     # Some pages aren't idempotent even with safe args like id; blacklist
1419     # them from the automatic whitelisting below.
1420     return 0 if $is_blacklisted_component{$comp};
1421
1422     # Eliminate arguments that do not indicate an effectful request.
1423     # For example, "id" is acceptable because that is how RT retrieves a
1424     # record.
1425     delete $args{id};
1426
1427     # If they have a results= from MaybeRedirectForResults, that's also fine.
1428     delete $args{results};
1429
1430     # The homepage refresh, which uses the Refresh header, doesn't send
1431     # a referer in most browsers; whitelist the one parameter it reloads
1432     # with, HomeRefreshInterval, which is safe
1433     delete $args{HomeRefreshInterval};
1434
1435     # The NotMobile flag is fine for any page; it's only used to toggle a flag
1436     # in the session related to which interface you get.
1437     delete $args{NotMobile};
1438
1439     # If there are no arguments, then it's likely to be an idempotent
1440     # request, which are not susceptible to CSRF
1441     return 1 if !%args;
1442
1443     return 0;
1444 }
1445
1446 sub IsRefererCSRFWhitelisted {
1447     my $referer = _NormalizeHost(shift);
1448     my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1449     $base_url = $base_url->host_port;
1450
1451     my $configs;
1452     for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1453         push @$configs,$config;
1454
1455         my $host_port = $referer->host_port;
1456         if ($config =~ /\*/) {
1457             # Turn a literal * into a domain component or partial component match.
1458             # Refer to http://tools.ietf.org/html/rfc2818#page-5
1459             my $regex = join "[a-zA-Z0-9\-]*",
1460                          map { quotemeta($_) }
1461                        split /\*/, $config;
1462
1463             return 1 if $host_port =~ /^$regex$/i;
1464         } else {
1465             return 1 if $host_port eq $config;
1466         }
1467     }
1468
1469     return (0,$referer,$configs);
1470 }
1471
1472 =head3 _NormalizeHost
1473
1474 Takes a URI and creates a URI object that's been normalized
1475 to handle common problems such as localhost vs 127.0.0.1
1476
1477 =cut
1478
1479 sub _NormalizeHost {
1480     my $s = shift;
1481     $s = "http://$s" unless $s =~ /^http/i;
1482     my $uri= URI->new($s);
1483     $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1484
1485     return $uri;
1486
1487 }
1488
1489 sub IsPossibleCSRF {
1490     my $ARGS = shift;
1491
1492     # If first request on this session is to a REST endpoint, then
1493     # whitelist the REST endpoints -- and explicitly deny non-REST
1494     # endpoints.  We do this because using a REST cookie in a browser
1495     # would open the user to CSRF attacks to the REST endpoints.
1496     my $path = $HTML::Mason::Commands::r->path_info;
1497     $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1498         unless defined $HTML::Mason::Commands::session{'REST'};
1499
1500     if ($HTML::Mason::Commands::session{'REST'}) {
1501         return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1502         my $why = <<EOT;
1503 This login session belongs to a REST client, and cannot be used to
1504 access non-REST interfaces of RT for security reasons.
1505 EOT
1506         my $details = <<EOT;
1507 Please log out and back in to obtain a session for normal browsing.  If
1508 you understand the security implications, disabling RT's CSRF protection
1509 will remove this restriction.
1510 EOT
1511         chomp $details;
1512         HTML::Mason::Commands::Abort( $why, Details => $details );
1513     }
1514
1515     return 0 if IsCompCSRFWhitelisted(
1516         $HTML::Mason::Commands::m->request_comp->path,
1517         $ARGS
1518     );
1519
1520     # if there is no Referer header then assume the worst
1521     return (1,
1522             "your browser did not supply a Referrer header", # loc
1523         ) if !$ENV{HTTP_REFERER};
1524
1525     my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1526     return 0 if $whitelisted;
1527
1528     if ( @$configs > 1 ) {
1529         return (1,
1530                 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1531                 $browser->host_port,
1532                 shift @$configs,
1533                 join(', ', @$configs) );
1534     }
1535
1536     return (1,
1537             "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1538             $browser->host_port,
1539             $configs->[0]);
1540 }
1541
1542 sub ExpandCSRFToken {
1543     my $ARGS = shift;
1544
1545     my $token = delete $ARGS->{CSRF_Token};
1546     return unless $token;
1547
1548     my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1549     return unless $data;
1550     return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1551
1552     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1553     return unless $user->ValidateAuthString( $data->{auth}, $token );
1554
1555     %{$ARGS} = %{$data->{args}};
1556     $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1557
1558     # We explicitly stored file attachments with the request, but not in
1559     # the session yet, as that would itself be an attack.  Put them into
1560     # the session now, so they'll be visible.
1561     if ($data->{attach}) {
1562         my $filename = $data->{attach}{filename};
1563         my $mime     = $data->{attach}{mime};
1564         $HTML::Mason::Commands::session{'Attachments'}{$ARGS->{'Token'}||''}{$filename}
1565             = $mime;
1566     }
1567
1568     return 1;
1569 }
1570
1571 sub StoreRequestToken {
1572     my $ARGS = shift;
1573
1574     my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1575     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1576     my $data = {
1577         auth => $user->GenerateAuthString( $token ),
1578         path => $HTML::Mason::Commands::r->path_info,
1579         args => $ARGS,
1580     };
1581     if ($ARGS->{Attach}) {
1582         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1583         my $file_path = delete $ARGS->{'Attach'};
1584
1585         # This needs to be decoded because the value is a reference;
1586         # hence it was not decoded along with all of the standard
1587         # arguments in DecodeARGS
1588         $data->{attach} = {
1589             filename => Encode::decode("UTF-8", "$file_path"),
1590             mime     => $attachment,
1591         };
1592     }
1593
1594     $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1595     $HTML::Mason::Commands::session{'i'}++;
1596     return $token;
1597 }
1598
1599 sub MaybeShowInterstitialCSRFPage {
1600     my $ARGS = shift;
1601
1602     return unless RT->Config->Get('RestrictReferrer');
1603
1604     # Deal with the form token provided by the interstitial, which lets
1605     # browsers which never set referer headers still use RT, if
1606     # painfully.  This blows values into ARGS
1607     return if ExpandCSRFToken($ARGS);
1608
1609     my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1610     return if !$is_csrf;
1611
1612     $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1613
1614     my $token = StoreRequestToken($ARGS);
1615     $HTML::Mason::Commands::m->comp(
1616         '/Elements/CSRF',
1617         OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1618         Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1619         Token => $token,
1620     );
1621     # Calls abort, never gets here
1622 }
1623
1624 our @POTENTIAL_PAGE_ACTIONS = (
1625     qr'/Ticket/Create.html' => "create a ticket",              # loc
1626     qr'/Ticket/'            => "update a ticket",              # loc
1627     qr'/Admin/'             => "modify RT's configuration",    # loc
1628     qr'/Approval/'          => "update an approval",           # loc
1629     qr'/Articles/'          => "update an article",            # loc
1630     qr'/Dashboards/'        => "modify a dashboard",           # loc
1631     qr'/m/ticket/'          => "update a ticket",              # loc
1632     qr'Prefs'               => "modify your preferences",      # loc
1633     qr'/Search/'            => "modify or access a search",    # loc
1634     qr'/SelfService/Create' => "create a ticket",              # loc
1635     qr'/SelfService/'       => "update a ticket",              # loc
1636 );
1637
1638 sub PotentialPageAction {
1639     my $page = shift;
1640     my @potentials = @POTENTIAL_PAGE_ACTIONS;
1641     while (my ($pattern, $result) = splice @potentials, 0, 2) {
1642         return HTML::Mason::Commands::loc($result)
1643             if $page =~ $pattern;
1644     }
1645     return "";
1646 }
1647
1648 =head2 RewriteInlineImages PARAMHASH
1649
1650 Turns C<< <img src="cid:..."> >> elements in HTML into working images pointing
1651 back to RT's stored copy.
1652
1653 Takes the following parameters:
1654
1655 =over 4
1656
1657 =item Content
1658
1659 Scalar ref of the HTML content to rewrite.  Modified in place to support the
1660 most common use-case.
1661
1662 =item Attachment
1663
1664 The L<RT::Attachment> object from which the Content originates.
1665
1666 =item Related (optional)
1667
1668 Array ref of related L<RT::Attachment> objects to use for C<Content-ID> matching.
1669
1670 Defaults to the result of the C<Siblings> method on the passed Attachment.
1671
1672 =item AttachmentPath (optional)
1673
1674 The base path to use when rewriting C<src> attributes.
1675
1676 Defaults to C< $WebPath/Ticket/Attachment >
1677
1678 =back
1679
1680 In scalar context, returns the number of elements rewritten.
1681
1682 In list content, returns the attachments IDs referred to by the rewritten <img>
1683 elements, in the order found.  There may be duplicates.
1684
1685 =cut
1686
1687 sub RewriteInlineImages {
1688     my %args = (
1689         Content         => undef,
1690         Attachment      => undef,
1691         Related         => undef,
1692         AttachmentPath  => RT->Config->Get('WebPath')."/Ticket/Attachment",
1693         @_
1694     );
1695
1696     return unless defined $args{Content}
1697               and ref $args{Content} eq 'SCALAR'
1698               and defined $args{Attachment};
1699
1700     my $related_part = $args{Attachment}->Closest("multipart/related")
1701         or return;
1702
1703     $args{Related} ||= $related_part->Children->ItemsArrayRef;
1704     return unless @{$args{Related}};
1705
1706     my $content = $args{'Content'};
1707     my @rewritten;
1708
1709     require HTML::RewriteAttributes::Resources;
1710     $$content = HTML::RewriteAttributes::Resources->rewrite($$content, sub {
1711         my $cid  = shift;
1712         my %meta = @_;
1713         return $cid unless    lc $meta{tag}  eq 'img'
1714                           and lc $meta{attr} eq 'src'
1715                           and $cid =~ s/^cid://i;
1716
1717         for my $attach (@{$args{Related}}) {
1718             if (($attach->GetHeader('Content-ID') || '') =~ /^(<)?\Q$cid\E(?(1)>)$/) {
1719                 push @rewritten, $attach->Id;
1720                 return "$args{AttachmentPath}/" . $attach->TransactionId . '/' . $attach->Id;
1721             }
1722         }
1723
1724         # No attachments means this is a bogus CID. Just pass it through.
1725         RT->Logger->debug(qq[Found bogus inline image src="cid:$cid"]);
1726         return "cid:$cid";
1727     });
1728     return @rewritten;
1729 }
1730
1731 =head2 GetCustomFieldInputName(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1732
1733 Returns the standard custom field input name; this is complementary to
1734 L</_ParseObjectCustomFieldArgs>.  Takes the following arguments:
1735
1736 =over
1737
1738 =item CustomField => I<L<RT::CustomField> object>
1739
1740 Required.
1741
1742 =item Object => I<object>
1743
1744 The object that the custom field is applied to; optional.  If omitted,
1745 defaults to a new object of the appropriate class for the custom field.
1746
1747 =item Grouping => I<CF grouping>
1748
1749 The grouping that the custom field is being rendered in.  Groupings
1750 allow a custom field to appear in more than one location per form.
1751
1752 =back
1753
1754 =cut
1755
1756 sub GetCustomFieldInputName {
1757     my %args = (
1758         CustomField => undef,
1759         Object      => undef,
1760         Grouping    => undef,
1761         @_,
1762     );
1763
1764     my $name = GetCustomFieldInputNamePrefix(%args);
1765
1766     if ( $args{CustomField}->Type eq 'Select' ) {
1767         if ( $args{CustomField}->RenderType eq 'List' and $args{CustomField}->SingleValue ) {
1768             $name .= 'Value';
1769         }
1770         else {
1771             $name .= 'Values';
1772         }
1773     }
1774     elsif ( $args{CustomField}->Type =~ /^(?:Binary|Image)$/ ) {
1775         $name .= 'Upload';
1776     }
1777     elsif ( $args{CustomField}->Type =~ /^(?:Date|DateTime|Text|Wikitext)$/ ) {
1778         $name .= 'Values';
1779     }
1780     else {
1781         if ( $args{CustomField}->SingleValue ) {
1782             $name .= 'Value';
1783         }
1784         else {
1785             $name .= 'Values';
1786         }
1787     }
1788
1789     return $name;
1790 }
1791
1792 =head2 GetCustomFieldInputNamePrefix(CustomField => $cf_object, Object => $object, Grouping => $grouping_name)
1793
1794 Returns the standard custom field input name prefix(without "Value" or alike suffix)
1795
1796 =cut
1797
1798 sub GetCustomFieldInputNamePrefix {
1799     my %args = (
1800         CustomField => undef,
1801         Object      => undef,
1802         Grouping    => undef,
1803         @_,
1804     );
1805
1806     my $prefix = join '-', 'Object', ref( $args{Object} ) || $args{CustomField}->ObjectTypeFromLookupType,
1807         ( $args{Object} && $args{Object}->id ? $args{Object}->id : '' ),
1808         'CustomField' . ( $args{Grouping} ? ":$args{Grouping}" : '' ),
1809         $args{CustomField}->id, '';
1810
1811     return $prefix;
1812 }
1813
1814 package HTML::Mason::Commands;
1815
1816 use vars qw/$r $m %session/;
1817
1818 use Scalar::Util qw(blessed);
1819
1820 sub Menu {
1821     return $HTML::Mason::Commands::m->notes('menu');
1822 }
1823
1824 sub PageMenu {
1825     return $HTML::Mason::Commands::m->notes('page-menu');
1826 }
1827
1828 sub PageWidgets {
1829     return $HTML::Mason::Commands::m->notes('page-widgets');
1830 }
1831
1832 sub RenderMenu {
1833     my %args = (toplevel => 1, parent_id => '', depth => 0, @_);
1834     return unless $args{'menu'};
1835
1836     my ($menu, $depth, $toplevel, $id, $parent_id)
1837         = @args{qw(menu depth toplevel id parent_id)};
1838
1839     my $interp = $m->interp;
1840     my $web_path = RT->Config->Get('WebPath');
1841
1842     my $res = '';
1843     $res .= ' ' x $depth;
1844     $res .= '<ul';
1845     $res .= ' id="'. $interp->apply_escapes($id, 'h') .'"'
1846         if $id;
1847     $res .= ' class="toplevel"' if $toplevel;
1848     $res .= ">\n";
1849
1850     for my $child ($menu->children) {
1851         $res .= ' 'x ($depth+1);
1852
1853         my $item_id = lc(($parent_id? "$parent_id-" : "") .$child->key);
1854         $item_id =~ s/\s/-/g;
1855         my $eitem_id = $interp->apply_escapes($item_id, 'h');
1856         $res .= qq{<li id="li-$eitem_id"};
1857
1858         my @classes;
1859         push @classes, 'has-children' if $child->has_children;
1860         push @classes, 'active'       if $child->active;
1861         $res .= ' class="'. join( ' ', @classes ) .'"'
1862             if @classes;
1863
1864         $res .= '>';
1865
1866         if ( my $tmp = $child->raw_html ) {
1867             $res .= $tmp;
1868         } else {
1869             $res .= qq{<a id="$eitem_id" class="menu-item};
1870             if ( $tmp = $child->class ) {
1871                 $res .= ' '. $interp->apply_escapes($tmp, 'h');
1872             }
1873             $res .= '"';
1874
1875             my $path = $child->path;
1876             my $url = (not $path or $path =~ m{^\w+:/}) ? $path : $web_path . $path;
1877             $url ||= "#";
1878             $res .= ' href="'. $interp->apply_escapes($url, 'h') .'"';
1879
1880             if ( $tmp = $child->target ) {
1881                 $res .= ' target="'. $interp->apply_escapes($tmp, 'h') .'"'
1882             }
1883
1884             if ($child->attributes) {
1885                 for my $key (keys %{$child->attributes}) {
1886                     my ($name, $value) = map { $interp->apply_escapes($_, 'h') }
1887                                              $key, $child->attributes->{$key};
1888                     $res .= " $name=\"$value\"";
1889                 }
1890             }
1891             $res .= '>';
1892
1893             if ( $child->escape_title ) {
1894                 $res .= $interp->apply_escapes($child->title, 'h');
1895             } else {
1896                 $res .= $child->title;
1897             }
1898             $res .= '</a>';
1899         }
1900
1901         if ( $child->has_children ) {
1902             $res .= "\n";
1903             $res .= RenderMenu(
1904                 menu => $child,
1905                 toplevel => 0,
1906                 parent_id => $item_id,
1907                 depth => $depth+1,
1908                 return => 1,
1909             );
1910             $res .= "\n";
1911             $res .= ' ' x ($depth+1);
1912         }
1913         $res .= "</li>\n";
1914     }
1915     $res .= ' ' x $depth;
1916     $res .= '</ul>';
1917     return $res if $args{'return'};
1918
1919     $m->print($res);
1920     return '';
1921 }
1922
1923 =head2 loc ARRAY
1924
1925 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1926 with whatever it's called with. If there is no $session{'CurrentUser'},
1927 it creates a temporary user, so we have something to get a localisation handle
1928 through
1929
1930 =cut
1931
1932 sub loc {
1933
1934     if ( $session{'CurrentUser'}
1935         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1936     {
1937         return ( $session{'CurrentUser'}->loc(@_) );
1938     } elsif (
1939         my $u = eval {
1940             RT::CurrentUser->new();
1941         }
1942         )
1943     {
1944         return ( $u->loc(@_) );
1945     } else {
1946
1947         # pathetic case -- SystemUser is gone.
1948         return $_[0];
1949     }
1950 }
1951
1952
1953
1954 =head2 loc_fuzzy STRING
1955
1956 loc_fuzzy is for handling localizations of messages that may already
1957 contain interpolated variables, typically returned from libraries
1958 outside RT's control.  It takes the message string and extracts the
1959 variable array automatically by matching against the candidate entries
1960 inside the lexicon file.
1961
1962 =cut
1963
1964 sub loc_fuzzy {
1965     my $msg = shift;
1966
1967     if ( $session{'CurrentUser'}
1968         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1969     {
1970         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1971     } else {
1972         my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1973         return ( $u->loc_fuzzy($msg) );
1974     }
1975 }
1976
1977
1978 # Error - calls Error and aborts
1979 sub Abort {
1980     my $why  = shift;
1981     my %args = @_;
1982
1983     if (   $session{'ErrorDocument'}
1984         && $session{'ErrorDocumentType'} )
1985     {
1986         $r->content_type( $session{'ErrorDocumentType'} );
1987         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1988         $m->abort;
1989     } else {
1990         $m->comp( "/Elements/Error", Why => $why, %args );
1991         $m->abort;
1992     }
1993 }
1994
1995 sub MaybeRedirectForResults {
1996     my %args = (
1997         Path      => $HTML::Mason::Commands::m->request_comp->path,
1998         Arguments => {},
1999         Anchor    => undef,
2000         Actions   => undef,
2001         Force     => 0,
2002         @_
2003     );
2004     my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
2005     return unless $has_actions || $args{'Force'};
2006
2007     my %arguments = %{ $args{'Arguments'} };
2008
2009     if ( $has_actions ) {
2010         my $key = Digest::MD5::md5_hex( rand(1024) );
2011         push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
2012         $session{'i'}++;
2013         $arguments{'results'} = $key;
2014     }
2015
2016     $args{'Path'} =~ s!^/+!!;
2017     my $url = RT->Config->Get('WebURL') . $args{Path};
2018
2019     if ( keys %arguments ) {
2020         $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
2021     }
2022     if ( $args{'Anchor'} ) {
2023         $url .= "#". $args{'Anchor'};
2024     }
2025     return RT::Interface::Web::Redirect($url);
2026 }
2027
2028 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
2029
2030 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
2031 redirect to the approvals display page, preserving any arguments.
2032
2033 C<Path>s matching C<Whitelist> are let through.
2034
2035 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
2036
2037 =cut
2038
2039 sub MaybeRedirectToApproval {
2040     my %args = (
2041         Path        => $HTML::Mason::Commands::m->request_comp->path,
2042         ARGSRef     => {},
2043         Whitelist   => undef,
2044         @_
2045     );
2046
2047     return unless $ENV{REQUEST_METHOD} eq 'GET';
2048
2049     my $id = $args{ARGSRef}->{id};
2050
2051     if (    $id
2052         and RT->Config->Get('ForceApprovalsView')
2053         and not $args{Path} =~ /$args{Whitelist}/)
2054     {
2055         my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
2056         $ticket->Load($id);
2057
2058         if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
2059             MaybeRedirectForResults(
2060                 Path      => "/Approvals/Display.html",
2061                 Force     => 1,
2062                 Anchor    => $args{ARGSRef}->{Anchor},
2063                 Arguments => $args{ARGSRef},
2064             );
2065         }
2066     }
2067 }
2068
2069 =head2 CreateTicket ARGS
2070
2071 Create a new ticket, using Mason's %ARGS.  returns @results.
2072
2073 =cut
2074
2075 sub CreateTicket {
2076     my %ARGS = (@_);
2077
2078     my (@Actions);
2079
2080     my $current_user = $session{'CurrentUser'};
2081     my $Ticket = RT::Ticket->new( $current_user );
2082
2083     my $Queue = RT::Queue->new( $current_user );
2084     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
2085         Abort('Queue not found');
2086     }
2087
2088     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
2089         Abort('You have no permission to create tickets in that queue.');
2090     }
2091
2092     my $due;
2093     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
2094         $due = RT::Date->new( $current_user );
2095         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
2096     }
2097     my $starts;
2098     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
2099         $starts = RT::Date->new( $current_user );
2100         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
2101     }
2102
2103     my $sigless = RT::Interface::Web::StripContent(
2104         Content        => $ARGS{Content},
2105         ContentType    => $ARGS{ContentType},
2106         StripSignature => 1,
2107         CurrentUser    => $current_user,
2108     );
2109
2110     my $date_now = RT::Date->new( $current_user );
2111     $date_now->SetToNow;
2112     my $MIMEObj = MakeMIMEEntity(
2113         Subject => $ARGS{'Subject'},
2114         From    => $ARGS{'From'} || $current_user->EmailAddress,
2115         To      => $ARGS{'To'} || $Queue->CorrespondAddress
2116                                || RT->Config->Get('CorrespondAddress'),
2117         Cc      => $ARGS{'Cc'},
2118         Date    => $date_now->RFC2822(Timezone => 'user'),
2119         Body    => $sigless,
2120         Type    => $ARGS{'ContentType'},
2121         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2122     );
2123
2124     my @attachments;
2125     if ( my $tmp = $session{'Attachments'}{ $ARGS{'Token'} || '' } ) {
2126         push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2127
2128         delete $session{'Attachments'}{ $ARGS{'Token'} || '' }
2129             unless $ARGS{'KeepAttachments'};
2130         $session{'Attachments'} = $session{'Attachments'}
2131             if @attachments;
2132     }
2133     if ( $ARGS{'Attachments'} ) {
2134         push @attachments, grep $_, map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} };
2135     }
2136     if ( @attachments ) {
2137         $MIMEObj->make_multipart;
2138         $MIMEObj->add_part( $_ ) foreach @attachments;
2139     }
2140
2141     for my $argument (qw(Encrypt Sign)) {
2142         if ( defined $ARGS{ $argument } ) {
2143             $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
2144         }
2145     }
2146
2147     my %create_args = (
2148         Type => $ARGS{'Type'} || 'ticket',
2149         Queue => $ARGS{'Queue'},
2150         Owner => $ARGS{'Owner'},
2151
2152         # note: name change
2153         Requestor       => $ARGS{'Requestors'},
2154         Cc              => $ARGS{'Cc'},
2155         AdminCc         => $ARGS{'AdminCc'},
2156         InitialPriority => $ARGS{'InitialPriority'},
2157         FinalPriority   => $ARGS{'FinalPriority'},
2158         TimeLeft        => $ARGS{'TimeLeft'},
2159         TimeEstimated   => $ARGS{'TimeEstimated'},
2160         TimeWorked      => $ARGS{'TimeWorked'},
2161         Subject         => $ARGS{'Subject'},
2162         Status          => $ARGS{'Status'},
2163         Due             => $due ? $due->ISO : undef,
2164         Starts          => $starts ? $starts->ISO : undef,
2165         MIMEObj         => $MIMEObj,
2166         SquelchMailTo   => $ARGS{'SquelchMailTo'},
2167         TransSquelchMailTo => $ARGS{'TransSquelchMailTo'},
2168     );
2169
2170     if ($ARGS{'DryRun'}) {
2171         $create_args{DryRun} = 1;
2172         $create_args{Owner}     ||= $RT::Nobody->Id;
2173         $create_args{Requestor} ||= $session{CurrentUser}->EmailAddress;
2174         $create_args{Subject}   ||= '';
2175         $create_args{Status}    ||= $Queue->Lifecycle->DefaultOnCreate,
2176     } else {
2177         my @txn_squelch;
2178         foreach my $type (qw(Requestor Cc AdminCc)) {
2179             push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
2180                 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
2181         }
2182         push @{$create_args{TransSquelchMailTo}}, @txn_squelch;
2183     }
2184
2185     if ( $ARGS{'AttachTickets'} ) {
2186         require RT::Action::SendEmail;
2187         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2188             ref $ARGS{'AttachTickets'}
2189             ? @{ $ARGS{'AttachTickets'} }
2190             : ( $ARGS{'AttachTickets'} ) );
2191     }
2192
2193     my %cfs = ProcessObjectCustomFieldUpdatesForCreate(
2194         ARGSRef         => \%ARGS,
2195         ContextObject   => $Queue,
2196     );
2197
2198     my %links = ProcessLinksForCreate( ARGSRef => \%ARGS );
2199
2200     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args, %links, %cfs);
2201     return $Trans if $ARGS{DryRun};
2202
2203     unless ($id) {
2204         Abort($ErrMsg);
2205     }
2206
2207     push( @Actions, split( "\n", $ErrMsg ) );
2208     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
2209         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
2210     }
2211     return ( $Ticket, @Actions );
2212
2213 }
2214
2215
2216
2217 =head2  LoadTicket id
2218
2219 Takes a ticket id as its only variable. if it's handed an array, it takes
2220 the first value.
2221
2222 Returns an RT::Ticket object as the current user.
2223
2224 =cut
2225
2226 sub LoadTicket {
2227     my $id = shift;
2228
2229     if ( ref($id) eq "ARRAY" ) {
2230         $id = $id->[0];
2231     }
2232
2233     unless ($id) {
2234         Abort("No ticket specified");
2235     }
2236
2237     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
2238     $Ticket->Load($id);
2239     unless ( $Ticket->id ) {
2240         Abort("Could not load ticket $id");
2241     }
2242     return $Ticket;
2243 }
2244
2245
2246
2247 =head2 ProcessUpdateMessage
2248
2249 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
2250
2251 Don't write message if it only contains current user's signature and
2252 SkipSignatureOnly argument is true. Function anyway adds attachments
2253 and updates time worked field even if skips message. The default value
2254 is true.
2255
2256 =cut
2257
2258 # change from stock: if txn custom fields are set but there's no content
2259 # or attachment, create a Touch txn instead of doing nothing
2260
2261 sub ProcessUpdateMessage {
2262
2263     my %args = (
2264         ARGSRef           => undef,
2265         TicketObj         => undef,
2266         SkipSignatureOnly => 1,
2267         @_
2268     );
2269
2270     my @attachments;
2271     if ( my $tmp = $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' } ) {
2272         push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp;
2273
2274         delete $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' }
2275             unless $args{'KeepAttachments'};
2276         $session{'Attachments'} = $session{'Attachments'}
2277             if @attachments;
2278     }
2279     if ( $args{ARGSRef}{'UpdateAttachments'} ) {
2280         push @attachments, grep $_, map $args{ARGSRef}->{UpdateAttachments}{$_},
2281                                    sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2282     }
2283
2284     # Strip the signature
2285     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
2286         Content        => $args{ARGSRef}->{UpdateContent},
2287         ContentType    => $args{ARGSRef}->{UpdateContentType},
2288         StripSignature => $args{SkipSignatureOnly},
2289         CurrentUser    => $args{'TicketObj'}->CurrentUser,
2290     );
2291
2292     my %txn_customfields;
2293
2294     foreach my $key ( keys %{ $args{ARGSRef} } ) {
2295       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
2296         next if $key =~ /(TimeUnits|Magic)$/;
2297         $txn_customfields{$key} = $args{ARGSRef}->{$key};
2298       }
2299     }
2300
2301     # If, after stripping the signature, we have no message, create a
2302     # Touch transaction if necessary
2303     if (    not @attachments
2304         and not length $args{ARGSRef}->{'UpdateContent'} )
2305     {
2306         #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
2307         #      $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
2308         #          delete $args{ARGSRef}->{'UpdateTimeWorked'};
2309         #  }
2310
2311         my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
2312         if ( $timetaken or grep {length $_} values %txn_customfields ) {
2313             my ( $Transaction, $Description, $Object ) =
2314                 $args{TicketObj}->Touch(
2315                   CustomFields => \%txn_customfields,
2316                   TimeTaken => $timetaken
2317                 );
2318             return $Description;
2319         }
2320         return;
2321     }
2322
2323     if ( ($args{ARGSRef}->{'UpdateSubject'}||'') eq ($args{'TicketObj'}->Subject || '') ) {
2324         $args{ARGSRef}->{'UpdateSubject'} = undef;
2325     }
2326
2327     my $Message = MakeMIMEEntity(
2328         Subject => $args{ARGSRef}->{'UpdateSubject'},
2329         Body    => $args{ARGSRef}->{'UpdateContent'},
2330         Type    => $args{ARGSRef}->{'UpdateContentType'},
2331         Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2332     );
2333
2334     $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
2335         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2336     ) );
2337     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2338     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2339         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2340     } else {
2341         $old_txn = $args{TicketObj}->Transactions->First();
2342     }
2343
2344     if ( my $msg = $old_txn->Message->First ) {
2345         RT::Interface::Email::SetInReplyTo(
2346             Message   => $Message,
2347             InReplyTo => $msg,
2348             Ticket    => $args{'TicketObj'},
2349         );
2350     }
2351
2352     if ( @attachments ) {
2353         $Message->make_multipart;
2354         $Message->add_part( $_ ) foreach @attachments;
2355     }
2356
2357     if ( $args{ARGSRef}->{'AttachTickets'} ) {
2358         require RT::Action::SendEmail;
2359         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2360             ref $args{ARGSRef}->{'AttachTickets'}
2361             ? @{ $args{ARGSRef}->{'AttachTickets'} }
2362             : ( $args{ARGSRef}->{'AttachTickets'} ) );
2363     }
2364
2365     my %message_args = (
2366         Sign         => $args{ARGSRef}->{'Sign'},
2367         Encrypt      => $args{ARGSRef}->{'Encrypt'},
2368         MIMEObj      => $Message,
2369         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
2370         CustomFields => \%txn_customfields,
2371     );
2372
2373     _ProcessUpdateMessageRecipients(
2374         MessageArgs => \%message_args,
2375         %args,
2376     );
2377
2378     my @results;
2379     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2380         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2381         push( @results, $Description );
2382         $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2383     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2384         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2385         push( @results, $Description );
2386         $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object;
2387     } else {
2388         push( @results,
2389             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2390     }
2391     return @results;
2392 }
2393
2394 sub _ProcessUpdateMessageRecipients {
2395     my %args = (
2396         ARGSRef           => undef,
2397         TicketObj         => undef,
2398         MessageArgs       => undef,
2399         @_,
2400     );
2401
2402     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2403     my $cc  = $args{ARGSRef}->{'UpdateCc'};
2404
2405     my $message_args = $args{MessageArgs};
2406
2407     $message_args->{CcMessageTo} = $cc;
2408     $message_args->{BccMessageTo} = $bcc;
2409
2410     my @txn_squelch;
2411     foreach my $type (qw(Cc AdminCc)) {
2412         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2413             push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2414             push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2415             push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2416         }
2417     }
2418     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2419         push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2420         push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2421     }
2422
2423     push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2424     $message_args->{SquelchMailTo} = \@txn_squelch
2425         if @txn_squelch;
2426
2427     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2428         foreach my $key ( keys %{ $args{ARGSRef} } ) {
2429             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2430
2431             my $var   = ucfirst($1) . 'MessageTo';
2432             my $value = $2;
2433             if ( $message_args->{$var} ) {
2434                 $message_args->{$var} .= ", $value";
2435             } else {
2436                 $message_args->{$var} = $value;
2437             }
2438         }
2439     }
2440 }
2441
2442 sub ProcessAttachments {
2443     my %args = (
2444         ARGSRef => {},
2445         Token   => '',
2446         @_
2447     );
2448
2449     my $token = $args{'ARGSRef'}{'Token'}
2450         ||= $args{'Token'} ||= Digest::MD5::md5_hex( rand(1024) );
2451
2452     my $update_session = 0;
2453
2454     # deal with deleting uploaded attachments
2455     if ( my $del = $args{'ARGSRef'}{'DeleteAttach'} ) {
2456         delete $session{'Attachments'}{ $token }{ $_ }
2457             foreach ref $del? @$del : ($del);
2458
2459         $update_session = 1;
2460     }
2461
2462     # store the uploaded attachment in session
2463     my $new = $args{'ARGSRef'}{'Attach'};
2464     if ( defined $new && length $new ) {
2465         my $attachment = MakeMIMEEntity(
2466             AttachmentFieldName => 'Attach'
2467         );
2468
2469         # This needs to be decoded because the value is a reference;
2470         # hence it was not decoded along with all of the standard
2471         # arguments in DecodeARGS
2472         my $file_path = Encode::decode( "UTF-8", "$new");
2473         $session{'Attachments'}{ $token }{ $file_path } = $attachment;
2474
2475         $update_session = 1;
2476     }
2477     $session{'Attachments'} = $session{'Attachments'} if $update_session;
2478 }
2479
2480
2481 =head2 MakeMIMEEntity PARAMHASH
2482
2483 Takes a paramhash Subject, Body and AttachmentFieldName.
2484
2485 Also takes Form, Cc and Type as optional paramhash keys.
2486
2487   Returns a MIME::Entity.
2488
2489 =cut
2490
2491 sub MakeMIMEEntity {
2492
2493     #TODO document what else this takes.
2494     my %args = (
2495         Subject             => undef,
2496         From                => undef,
2497         Cc                  => undef,
2498         Body                => undef,
2499         AttachmentFieldName => undef,
2500         Type                => undef,
2501         Interface           => 'API',
2502         @_,
2503     );
2504     my $Message = MIME::Entity->build(
2505         Type    => 'multipart/mixed',
2506         "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
2507         "X-RT-Interface" => $args{Interface},
2508         map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
2509             grep defined $args{$_}, qw(Subject From Cc To Date)
2510     );
2511
2512     if ( defined $args{'Body'} && length $args{'Body'} ) {
2513
2514         # Make the update content have no 'weird' newlines in it
2515         $args{'Body'} =~ s/\r\n/\n/gs;
2516
2517         $Message->attach(
2518             Type    => $args{'Type'} || 'text/plain',
2519             Charset => 'UTF-8',
2520             Data    => Encode::encode( "UTF-8", $args{'Body'} ),
2521         );
2522     }
2523
2524     if ( $args{'AttachmentFieldName'} ) {
2525
2526         my $cgi_object = $m->cgi_object;
2527         my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2528         if ( defined $filehandle && length $filehandle ) {
2529
2530             my ( @content, $buffer );
2531             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2532                 push @content, $buffer;
2533             }
2534
2535             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2536
2537             my $filename = Encode::decode("UTF-8","$filehandle");
2538             $filename =~ s{^.*[\\/]}{};
2539
2540             $Message->attach(
2541                 Type     => $uploadinfo->{'Content-Type'},
2542                 Filename => Encode::encode("UTF-8",$filename),
2543                 Data     => \@content, # Bytes, as read directly from the file, above
2544             );
2545             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2546                 $Message->head->replace( 'Subject' => Encode::encode( "UTF-8", $filename ) );
2547             }
2548
2549             # Attachment parts really shouldn't get a Message-ID or "interface"
2550             $Message->head->delete('Message-ID');
2551             $Message->head->delete('X-RT-Interface');
2552         }
2553     }
2554
2555     $Message->make_singlepart;
2556
2557     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
2558
2559     return ($Message);
2560
2561 }
2562
2563
2564
2565 =head2 ParseDateToISO
2566
2567 Takes a date in an arbitrary format.
2568 Returns an ISO date and time in GMT
2569
2570 =cut
2571
2572 sub ParseDateToISO {
2573     my $date = shift;
2574
2575     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2576     $date_obj->Set(
2577         Format => 'unknown',
2578         Value  => $date
2579     );
2580     return ( $date_obj->ISO );
2581 }
2582
2583
2584
2585 sub ProcessACLChanges {
2586     my $ARGSref = shift;
2587
2588     my @results;
2589
2590     foreach my $arg ( keys %$ARGSref ) {
2591         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2592
2593         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2594
2595         my @rights;
2596         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2597             @rights = @{ $ARGSref->{$arg} };
2598         } else {
2599             @rights = $ARGSref->{$arg};
2600         }
2601         @rights = grep $_, @rights;
2602         next unless @rights;
2603
2604         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2605         $principal->Load($principal_id);
2606
2607         my $obj;
2608         if ( $object_type eq 'RT::System' ) {
2609             $obj = $RT::System;
2610         } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2611             $obj = $object_type->new( $session{'CurrentUser'} );
2612             $obj->Load($object_id);
2613             unless ( $obj->id ) {
2614                 $RT::Logger->error("couldn't load $object_type #$object_id");
2615                 next;
2616             }
2617         } else {
2618             $RT::Logger->error("object type '$object_type' is incorrect");
2619             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2620             next;
2621         }
2622
2623         foreach my $right (@rights) {
2624             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2625             push( @results, $msg );
2626         }
2627     }
2628
2629     return (@results);
2630 }
2631
2632
2633 =head2 ProcessACLs
2634
2635 ProcessACLs expects values from a series of checkboxes that describe the full
2636 set of rights a principal should have on an object.
2637
2638 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2639 instead of with the prefixes Grant/RevokeRight.  Each input should be an array
2640 listing the rights the principal should have, and ProcessACLs will modify the
2641 current rights to match.  Additionally, the previously unused CheckACL input
2642 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2643 rights are removed from a principal and as such no SetRights input is
2644 submitted.
2645
2646 =cut
2647
2648 sub ProcessACLs {
2649     my $ARGSref = shift;
2650     my (%state, @results);
2651
2652     my $CheckACL = $ARGSref->{'CheckACL'};
2653     my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2654
2655     # Check if we want to grant rights to a previously rights-less user
2656     for my $type (qw(user group)) {
2657         my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2658             or next;
2659
2660         unless ($principal->PrincipalId) {
2661             push @results, loc("Couldn't load the specified principal");
2662             next;
2663         }
2664
2665         my $principal_id = $principal->PrincipalId;
2666
2667         # Turn our addprincipal rights spec into a real one
2668         for my $arg (keys %$ARGSref) {
2669             next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2670
2671             my $tuple = "$principal_id-$1";
2672             my $key   = "SetRights-$tuple";
2673
2674             # If we have it already, that's odd, but merge them
2675             if (grep { $_ eq $tuple } @check) {
2676                 $ARGSref->{$key} = [
2677                     (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2678                     (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2679                 ];
2680             } else {
2681                 $ARGSref->{$key} = $ARGSref->{$arg};
2682                 push @check, $tuple;
2683             }
2684         }
2685     }
2686
2687     # Build our rights state for each Principal-Object tuple
2688     foreach my $arg ( keys %$ARGSref ) {
2689         next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2690
2691         my $tuple  = $1;
2692         my $value  = $ARGSref->{$arg};
2693         my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2694         next unless @rights;
2695
2696         $state{$tuple} = { map { $_ => 1 } @rights };
2697     }
2698
2699     foreach my $tuple (List::MoreUtils::uniq @check) {
2700         next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2701
2702         my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2703
2704         my $principal = RT::Principal->new( $session{'CurrentUser'} );
2705         $principal->Load($principal_id);
2706
2707         my $obj;
2708         if ( $object_type eq 'RT::System' ) {
2709             $obj = $RT::System;
2710         } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) {
2711             $obj = $object_type->new( $session{'CurrentUser'} );
2712             $obj->Load($object_id);
2713             unless ( $obj->id ) {
2714                 $RT::Logger->error("couldn't load $object_type #$object_id");
2715                 next;
2716             }
2717         } else {
2718             $RT::Logger->error("object type '$object_type' is incorrect");
2719             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2720             next;
2721         }
2722
2723         my $acls = RT::ACL->new($session{'CurrentUser'});
2724         $acls->LimitToObject( $obj );
2725         $acls->LimitToPrincipal( Id => $principal_id );
2726
2727         while ( my $ace = $acls->Next ) {
2728             my $right = $ace->RightName;
2729
2730             # Has right and should have right
2731             next if delete $state{$tuple}->{$right};
2732
2733             # Has right and shouldn't have right
2734             my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2735             push @results, $msg;
2736         }
2737
2738         # For everything left, they don't have the right but they should
2739         for my $right (keys %{ $state{$tuple} || {} }) {
2740             delete $state{$tuple}->{$right};
2741             my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2742             push @results, $msg;
2743         }
2744
2745         # Check our state for leftovers
2746         if ( keys %{ $state{$tuple} || {} } ) {
2747             my $missed = join '|', %{$state{$tuple} || {}};
2748             $RT::Logger->warn(
2749                "Uh-oh, it looks like we somehow missed a right in "
2750               ."ProcessACLs.  Here's what was leftover: $missed"
2751             );
2752         }
2753     }
2754
2755     return (@results);
2756 }
2757
2758 =head2 _ParseACLNewPrincipal
2759
2760 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>).  Looks
2761 for the presence of rights being added on a principal of the specified type,
2762 and returns undef if no new principal is being granted rights.  Otherwise loads
2763 up an L<RT::User> or L<RT::Group> object and returns it.  Note that the object
2764 may not be successfully loaded, and you should check C<->id> yourself.
2765
2766 =cut
2767
2768 sub _ParseACLNewPrincipal {
2769     my $ARGSref = shift;
2770     my $type    = lc shift;
2771     my $key     = "AddPrincipalForRights-$type";
2772
2773     return unless $ARGSref->{$key};
2774
2775     my $principal;
2776     if ( $type eq 'user' ) {
2777         $principal = RT::User->new( $session{'CurrentUser'} );
2778         $principal->LoadByCol( Name => $ARGSref->{$key} );
2779     }
2780     elsif ( $type eq 'group' ) {
2781         $principal = RT::Group->new( $session{'CurrentUser'} );
2782         $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2783     }
2784     return $principal;
2785 }
2786
2787
2788 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2789
2790 @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.
2791
2792 Returns an array of success/failure messages
2793
2794 =cut
2795
2796 sub UpdateRecordObject {
2797     my %args = (
2798         ARGSRef         => undef,
2799         AttributesRef   => undef,
2800         Object          => undef,
2801         AttributePrefix => undef,
2802         @_
2803     );
2804
2805     my $Object  = $args{'Object'};
2806     my @results = $Object->Update(
2807         AttributesRef   => $args{'AttributesRef'},
2808         ARGSRef         => $args{'ARGSRef'},
2809         AttributePrefix => $args{'AttributePrefix'},
2810     );
2811
2812     return (@results);
2813 }
2814
2815
2816
2817 sub ProcessCustomFieldUpdates {
2818     my %args = (
2819         CustomFieldObj => undef,
2820         ARGSRef        => undef,
2821         @_
2822     );
2823
2824     my $Object  = $args{'CustomFieldObj'};
2825     my $ARGSRef = $args{'ARGSRef'};
2826
2827     my @attribs = qw(Name Type Description Queue SortOrder);
2828     my @results = UpdateRecordObject(
2829         AttributesRef => \@attribs,
2830         Object        => $Object,
2831         ARGSRef       => $ARGSRef
2832     );
2833
2834     my $prefix = "CustomField-" . $Object->Id;
2835     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2836         my ( $addval, $addmsg ) = $Object->AddValue(
2837             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
2838             Description => $ARGSRef->{"$prefix-AddValue-Description"},
2839             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2840         );
2841         push( @results, $addmsg );
2842     }
2843
2844     my @delete_values
2845         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2846         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2847         : ( $ARGSRef->{"$prefix-DeleteValue"} );
2848
2849     foreach my $id (@delete_values) {
2850         next unless defined $id;
2851         my ( $err, $msg ) = $Object->DeleteValue($id);
2852         push( @results, $msg );
2853     }
2854
2855     my $vals = $Object->Values();
2856     while ( my $cfv = $vals->Next() ) {
2857         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2858             if ( $cfv->SortOrder != $so ) {
2859                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2860                 push( @results, $msg );
2861             }
2862         }
2863     }
2864
2865     return (@results);
2866 }
2867
2868
2869
2870 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2871
2872 Returns an array of results messages.
2873
2874 =cut
2875
2876 sub ProcessTicketBasics {
2877
2878     my %args = (
2879         TicketObj => undef,
2880         ARGSRef   => undef,
2881         @_
2882     );
2883
2884     my $TicketObj = $args{'TicketObj'};
2885     my $ARGSRef   = $args{'ARGSRef'};
2886
2887     my $OrigOwner = $TicketObj->Owner;
2888
2889     # Set basic fields
2890     my @attribs = qw(
2891         Subject
2892         FinalPriority
2893         Priority
2894         TimeEstimated
2895         TimeWorked
2896         TimeLeft
2897         Type
2898         Status
2899         Queue
2900     );
2901
2902     # Canonicalize Queue and Owner to their IDs if they aren't numeric
2903     for my $field (qw(Queue Owner)) {
2904         if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2905             my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2906             my $temp = $class->new(RT->SystemUser);
2907             $temp->Load( $ARGSRef->{$field} );
2908             if ( $temp->id ) {
2909                 $ARGSRef->{$field} = $temp->id;
2910             }
2911         }
2912     }
2913
2914     # Status isn't a field that can be set to a null value.
2915     # RT core complains if you try
2916     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2917
2918     my @results = UpdateRecordObject(
2919         AttributesRef => \@attribs,
2920         Object        => $TicketObj,
2921         ARGSRef       => $ARGSRef,
2922     );
2923
2924     # We special case owner changing, so we can use ForceOwnerChange
2925     if ( $ARGSRef->{'Owner'}
2926       && $ARGSRef->{'Owner'} !~ /\D/
2927       && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2928         my ($ChownType);
2929         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2930             $ChownType = "Force";
2931         }
2932         else {
2933             $ChownType = "Set";
2934         }
2935
2936         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2937         push( @results, $msg );
2938     }
2939
2940     # }}}
2941
2942     return (@results);
2943 }
2944
2945 sub ProcessTicketReminders {
2946     my %args = (
2947         TicketObj => undef,
2948         ARGSRef   => undef,
2949         @_
2950     );
2951
2952     my $Ticket = $args{'TicketObj'};
2953     my $args   = $args{'ARGSRef'};
2954     my @results;
2955
2956     my $reminder_collection = $Ticket->Reminders->Collection;
2957
2958     if ( $args->{'update-reminders'} ) {
2959         while ( my $reminder = $reminder_collection->Next ) {
2960             my $resolve_status = $reminder->LifecycleObj->ReminderStatusOnResolve;
2961             my ( $status, $msg, $old_subject, @subresults );
2962             if (   $reminder->Status ne $resolve_status
2963                 && $args->{ 'Complete-Reminder-' . $reminder->id } )
2964             {
2965                 ( $status, $msg ) = $Ticket->Reminders->Resolve($reminder);
2966                 push @subresults, $msg;
2967             }
2968             elsif ( $reminder->Status eq $resolve_status
2969                 && !$args->{ 'Complete-Reminder-' . $reminder->id } )
2970             {
2971                 ( $status, $msg ) = $Ticket->Reminders->Open($reminder);
2972                 push @subresults, $msg;
2973             }
2974
2975             if (
2976                 exists( $args->{ 'Reminder-Subject-' . $reminder->id } )
2977                 && ( $reminder->Subject ne
2978                     $args->{ 'Reminder-Subject-' . $reminder->id } )
2979               )
2980             {
2981                 $old_subject = $reminder->Subject;
2982                 ( $status, $msg ) =
2983                   $reminder->SetSubject(
2984                     $args->{ 'Reminder-Subject-' . $reminder->id } );
2985                 push @subresults, $msg;
2986             }
2987
2988             if (
2989                 exists( $args->{ 'Reminder-Owner-' . $reminder->id } )
2990                 && ( $reminder->Owner !=
2991                     $args->{ 'Reminder-Owner-' . $reminder->id } )
2992               )
2993             {
2994                 ( $status, $msg ) =
2995                   $reminder->SetOwner(
2996                     $args->{ 'Reminder-Owner-' . $reminder->id }, "Force" );
2997                 push @subresults, $msg;
2998             }
2999
3000             if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } )
3001                 && $args->{ 'Reminder-Due-' . $reminder->id } ne '' )
3002             {
3003                 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3004                 my $due     = $args->{ 'Reminder-Due-' . $reminder->id };
3005
3006                 $DateObj->Set(
3007                     Format => 'unknown',
3008                     Value  => $due,
3009                 );
3010                 if ( $DateObj->Unix != $reminder->DueObj->Unix ) {
3011                     ( $status, $msg ) = $reminder->SetDue( $DateObj->ISO );
3012                 }
3013                 else {
3014                     $msg = loc( "invalid due date: [_1]", $due );
3015                 }
3016
3017                 push @subresults, $msg;
3018             }
3019
3020             push @results, map {
3021                 loc( "Reminder '[_1]': [_2]", $old_subject || $reminder->Subject, $_ )
3022             } @subresults;
3023         }
3024     }
3025
3026     if ( $args->{'NewReminder-Subject'} ) {
3027         my $due_obj = RT::Date->new( $session{'CurrentUser'} );
3028         $due_obj->Set(
3029           Format => 'unknown',
3030           Value => $args->{'NewReminder-Due'}
3031         );
3032         my ( $status, $msg ) = $Ticket->Reminders->Add(
3033             Subject => $args->{'NewReminder-Subject'},
3034             Owner   => $args->{'NewReminder-Owner'},
3035             Due     => $due_obj->ISO
3036         );
3037         if ( $status ) {
3038             push @results,
3039               loc( "Reminder '[_1]': [_2]", $args->{'NewReminder-Subject'}, loc("Created") )
3040         }
3041         else {
3042             push @results, $msg;
3043         }
3044     }
3045     return @results;
3046 }
3047
3048 sub ProcessObjectCustomFieldUpdates {
3049     my %args    = @_;
3050     my $ARGSRef = $args{'ARGSRef'};
3051     my @results;
3052
3053     # Build up a list of objects that we want to work with
3054     my %custom_fields_to_mod = _ParseObjectCustomFieldArgs($ARGSRef);
3055
3056     # For each of those objects
3057     foreach my $class ( keys %custom_fields_to_mod ) {
3058         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
3059             my $Object = $args{'Object'};
3060             $Object = $class->new( $session{'CurrentUser'} )
3061                 unless $Object && ref $Object eq $class;
3062
3063             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
3064             unless ( $Object->id ) {
3065                 $RT::Logger->warning("Couldn't load object $class #$id");
3066                 next;
3067             }
3068
3069             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
3070                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
3071                 $CustomFieldObj->SetContextObject($Object);
3072                 $CustomFieldObj->LoadById($cf);
3073                 unless ( $CustomFieldObj->id ) {
3074                     $RT::Logger->warning("Couldn't load custom field #$cf");
3075                     next;
3076                 }
3077                 my @groupings = sort keys %{ $custom_fields_to_mod{$class}{$id}{$cf} };
3078                 if (@groupings > 1) {
3079                     # Check for consistency, in case of JS fail
3080                     for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3081                         my $base = $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]}{$key};
3082                         $base = [ $base ] unless ref $base;
3083                         for my $grouping (@groupings[1..$#groupings]) {
3084                             my $other = $custom_fields_to_mod{$class}{$id}{$cf}{$grouping}{$key};
3085                             $other = [ $other ] unless ref $other;
3086                             warn "CF $cf submitted with multiple differing values"
3087                                 if grep {$_} List::MoreUtils::pairwise {
3088                                     no warnings qw(uninitialized);
3089                                     $a ne $b
3090                                 } @{$base}, @{$other};
3091                         }
3092                     }
3093                     # We'll just be picking the 1st grouping in the hash, alphabetically
3094                 }
3095                 push @results,
3096                     _ProcessObjectCustomFieldUpdates(
3097                         Prefix => GetCustomFieldInputNamePrefix(
3098                             Object      => $Object,
3099                             CustomField => $CustomFieldObj,
3100                             Grouping    => $groupings[0],
3101                         ),
3102                         Object      => $Object,
3103                         CustomField => $CustomFieldObj,
3104                         ARGS        => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] },
3105                     );
3106             }
3107         }
3108     }
3109     return @results;
3110 }
3111
3112 sub _ParseObjectCustomFieldArgs {
3113     my $ARGSRef = shift || {};
3114     my %custom_fields_to_mod;
3115
3116     foreach my $arg ( keys %$ARGSRef ) {
3117
3118         # format: Object-<object class>-<object id>-CustomField[:<grouping>]-<CF id>-<commands>
3119         # you can use GetCustomFieldInputName to generate the complement input name
3120         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField(?::(\w+))?-(\d+)-(.*)$/;
3121
3122         next if $1 eq 'RT::Transaction';# don't try to update transaction fields
3123
3124         # For each of those objects, find out what custom fields we want to work with.
3125         #                   Class     ID     CF  grouping command
3126         $custom_fields_to_mod{$1}{ $2 || 0 }{$4}{$3 || ''}{$5} = $ARGSRef->{$arg};
3127     }
3128
3129     return wantarray ? %custom_fields_to_mod : \%custom_fields_to_mod;
3130 }
3131
3132 sub _ProcessObjectCustomFieldUpdates {
3133     my %args    = @_;
3134     my $cf      = $args{'CustomField'};
3135     my $cf_type = $cf->Type || '';
3136
3137     # Remove blank Values since the magic field will take care of this. Sometimes
3138     # the browser gives you a blank value which causes CFs to be processed twice
3139     if (   defined $args{'ARGS'}->{'Values'}
3140         && !length $args{'ARGS'}->{'Values'}
3141         && ($args{'ARGS'}->{'Values-Magic'}) )
3142     {
3143         delete $args{'ARGS'}->{'Values'};
3144     }
3145
3146     my @results;
3147     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
3148
3149         # skip category argument
3150         next if $arg =~ /-Category$/;
3151
3152         # and TimeUnits
3153         next if $arg eq 'Value-TimeUnits';
3154
3155         # since http won't pass in a form element with a null value, we need
3156         # to fake it
3157         if ( $arg =~ /-Magic$/ ) {
3158
3159             # We don't care about the magic, if there's really a values element;
3160             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
3161             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
3162
3163             # "Empty" values does not mean anything for Image and Binary fields
3164             next if $cf_type =~ /^(?:Image|Binary)$/;
3165
3166             $arg = 'Values';
3167             $args{'ARGS'}->{'Values'} = undef;
3168         }
3169
3170         my @values = _NormalizeObjectCustomFieldValue(
3171             CustomField => $cf,
3172             Param       => $args{'Prefix'} . $arg,
3173             Value       => $args{'ARGS'}->{$arg}
3174         );
3175
3176         # "Empty" values still don't mean anything for Image and Binary fields
3177         next if $cf_type =~ /^(?:Image|Binary)$/ and not @values;
3178
3179         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
3180             foreach my $value (@values) {
3181                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3182                     Field => $cf->id,
3183                     Value => $value
3184                 );
3185                 push( @results, $msg );
3186             }
3187         } elsif ( $arg eq 'Upload' ) {
3188             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %{$values[0]}, Field => $cf, );
3189             push( @results, $msg );
3190         } elsif ( $arg eq 'DeleteValues' ) {
3191             foreach my $value (@values) {
3192                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3193                     Field => $cf,
3194                     Value => $value,
3195                 );
3196                 push( @results, $msg );
3197             }
3198         } elsif ( $arg eq 'DeleteValueIds' ) {
3199             foreach my $value (@values) {
3200                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3201                     Field   => $cf,
3202                     ValueId => $value,
3203                 );
3204                 push( @results, $msg );
3205             }
3206         } elsif ( $arg eq 'Values' ) {
3207             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
3208
3209             my %values_hash;
3210             foreach my $value (@values) {
3211                 if ( my $entry = $cf_values->HasEntry($value) ) {
3212                     $values_hash{ $entry->id } = 1;
3213                     next;
3214                 }
3215
3216                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
3217                     Field => $cf,
3218                     Value => $value
3219                 );
3220                 push( @results, $msg );
3221                 $values_hash{$val} = 1 if $val;
3222             }
3223
3224             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3225             return @results if ( $cf->Type eq 'Date' && ! @values );
3226
3227             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
3228             return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
3229
3230             $cf_values->RedoSearch;
3231             while ( my $cf_value = $cf_values->Next ) {
3232                 next if $values_hash{ $cf_value->id };
3233
3234                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
3235                     Field   => $cf,
3236                     ValueId => $cf_value->id
3237                 );
3238                 push( @results, $msg );
3239             }
3240         } else {
3241             push(
3242                 @results,
3243                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
3244                     $cf->Name, ref $args{'Object'},
3245                     $args{'Object'}->id
3246                 )
3247             );
3248         }
3249     }
3250     return @results;
3251 }
3252
3253 sub ProcessObjectCustomFieldUpdatesForCreate {
3254     my %args = (
3255         ARGSRef         => {},
3256         ContextObject   => undef,
3257         @_
3258     );
3259     my $context = $args{'ContextObject'};
3260     my %parsed;
3261     my %custom_fields = _ParseObjectCustomFieldArgs( $args{'ARGSRef'} );
3262
3263     for my $class (keys %custom_fields) {
3264         # we're only interested in new objects, so only look at $id == 0
3265         for my $cfid (keys %{ $custom_fields{$class}{0} || {} }) {
3266             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3267             if ($context) {
3268                 my $system_cf = RT::CustomField->new( RT->SystemUser );
3269                 $system_cf->LoadById($cfid);
3270                 if ($system_cf->ValidateContextObject($context)) {
3271                     $cf->SetContextObject($context);
3272                 } else {
3273                     RT->Logger->error(
3274                         sprintf "Invalid context object %s (%d) for CF %d; skipping CF",
3275                                 ref $context, $context->id, $system_cf->id
3276                     );
3277                     next;
3278                 }
3279             }
3280             $cf->LoadById($cfid);
3281
3282             unless ($cf->id) {
3283                 RT->Logger->warning("Couldn't load custom field #$cfid");
3284                 next;
3285             }
3286
3287             my @groupings = sort keys %{ $custom_fields{$class}{0}{$cfid} };
3288             if (@groupings > 1) {
3289                 # Check for consistency, in case of JS fail
3290                 for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) {
3291                     warn "CF $cfid submitted with multiple differing $key"
3292                         if grep {($custom_fields{$class}{0}{$cfid}{$_}{$key} || '')
3293                              ne  ($custom_fields{$class}{0}{$cfid}{$groupings[0]}{$key} || '')}
3294                             @groupings;
3295                 }
3296                 # We'll just be picking the 1st grouping in the hash, alphabetically
3297             }
3298
3299             my @values;
3300             my $name_prefix = GetCustomFieldInputNamePrefix(
3301                 CustomField => $cf,
3302                 Grouping    => $groupings[0],
3303             );
3304             while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) {
3305                 # Values-Magic doesn't matter on create; no previous values are being removed
3306                 # Category is irrelevant for the actual value
3307                 next if $arg =~ /-Magic$/ or $arg =~ /-Category$/;
3308
3309                 push @values,
3310                     _NormalizeObjectCustomFieldValue(
3311                     CustomField => $cf,
3312                     Param       => $name_prefix . $arg,
3313                     Value       => $value,
3314                     );
3315             }
3316
3317             $parsed{"CustomField-$cfid"} = \@values if @values;
3318         }
3319     }
3320
3321     return wantarray ? %parsed : \%parsed;
3322 }
3323
3324 sub _NormalizeObjectCustomFieldValue {
3325     my %args    = (
3326         Param   => "",
3327         @_
3328     );
3329     my $cf_type = $args{CustomField}->Type;
3330     my @values  = ();
3331
3332     if ( ref $args{'Value'} eq 'ARRAY' ) {
3333         @values = @{ $args{'Value'} };
3334     } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
3335         @values = ( $args{'Value'} );
3336     } else {
3337         @values = split /\r*\n/, $args{'Value'}
3338             if defined $args{'Value'};
3339     }
3340     @values = grep length, map {
3341         s/\r+\n/\n/g;
3342         s/^\s+//;
3343         s/\s+$//;
3344         $_;
3345         }
3346         grep defined, @values;
3347
3348     if ($args{'Param'} =~ /-Upload$/ and $cf_type =~ /^(Image|Binary)$/) {
3349         @values = _UploadedFile( $args{'Param'} ) || ();
3350     }
3351
3352     return @values;
3353 }
3354
3355 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3356
3357 Returns an array of results messages.
3358
3359 =cut
3360
3361 sub ProcessTicketWatchers {
3362     my %args = (
3363         TicketObj => undef,
3364         ARGSRef   => undef,
3365         @_
3366     );
3367     my (@results);
3368
3369     my $Ticket  = $args{'TicketObj'};
3370     my $ARGSRef = $args{'ARGSRef'};
3371
3372     # Munge watchers
3373
3374     foreach my $key ( keys %$ARGSRef ) {
3375
3376         # Delete deletable watchers
3377         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
3378             my ( $code, $msg ) = $Ticket->DeleteWatcher(
3379                 PrincipalId => $2,
3380                 Type        => $1
3381             );
3382             push @results, $msg;
3383         }
3384
3385         # Delete watchers in the simple style demanded by the bulk manipulator
3386         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
3387             my ( $code, $msg ) = $Ticket->DeleteWatcher(
3388                 Email => $ARGSRef->{$key},
3389                 Type  => $1
3390             );
3391             push @results, $msg;
3392         }
3393
3394         # Add new wathchers by email address
3395         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
3396             and $key =~ /^WatcherTypeEmail(\d*)$/ )
3397         {
3398
3399             #They're in this order because otherwise $1 gets clobbered :/
3400             my ( $code, $msg ) = $Ticket->AddWatcher(
3401                 Type  => $ARGSRef->{$key},
3402                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
3403             );
3404             push @results, $msg;
3405         }
3406
3407         #Add requestors in the simple style demanded by the bulk manipulator
3408         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
3409             my ( $code, $msg ) = $Ticket->AddWatcher(
3410                 Type  => $1,
3411                 Email => $ARGSRef->{$key}
3412             );
3413             push @results, $msg;
3414         }
3415
3416         # Add new  watchers by owner
3417         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
3418             my $principal_id = $1;
3419             my $form         = $ARGSRef->{$key};
3420             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
3421                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
3422
3423                 my ( $code, $msg ) = $Ticket->AddWatcher(
3424                     Type        => $value,
3425                     PrincipalId => $principal_id
3426                 );
3427                 push @results, $msg;
3428             }
3429         }
3430
3431     }
3432     return (@results);
3433 }
3434
3435
3436
3437 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3438
3439 Returns an array of results messages.
3440
3441 =cut
3442
3443 sub ProcessTicketDates {
3444     my %args = (
3445         TicketObj => undef,
3446         ARGSRef   => undef,
3447         @_
3448     );
3449
3450     my $Ticket  = $args{'TicketObj'};
3451     my $ARGSRef = $args{'ARGSRef'};
3452
3453     my (@results);
3454
3455     # Set date fields
3456     my @date_fields = qw(
3457         Told
3458         Starts
3459         Started
3460         Due
3461         WillResolve
3462     );
3463
3464     #Run through each field in this list. update the value if apropriate
3465     foreach my $field (@date_fields) {
3466         next unless exists $ARGSRef->{ $field . '_Date' };
3467         next if $ARGSRef->{ $field . '_Date' } eq '';
3468
3469         my ( $code, $msg );
3470
3471         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3472         $DateObj->Set(
3473             Format => 'unknown',
3474             Value  => $ARGSRef->{ $field . '_Date' }
3475         );
3476
3477         my $obj = $field . "Obj";
3478         if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) {
3479             my $method = "Set$field";
3480             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3481             push @results, "$msg";
3482         }
3483     }
3484
3485     # }}}
3486     return (@results);
3487 }
3488
3489
3490
3491 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3492
3493 Returns an array of results messages.
3494
3495 =cut
3496
3497 sub ProcessTicketLinks {
3498     my %args = (
3499         TicketObj => undef,
3500         TicketId  => undef,
3501         ARGSRef   => undef,
3502         @_
3503     );
3504
3505     my $Ticket  = $args{'TicketObj'};
3506     my $TicketId = $args{'TicketId'} || $Ticket->Id;
3507     my $ARGSRef = $args{'ARGSRef'};
3508
3509     my (@results) = ProcessRecordLinks(
3510         %args, RecordObj => $Ticket, RecordId => $TicketId, ARGSRef => $ARGSRef,
3511     );
3512
3513     #Merge if we need to
3514     my $input = $TicketId .'-MergeInto';
3515     if ( $ARGSRef->{ $input } ) {
3516         $ARGSRef->{ $input } =~ s/\s+//g;
3517         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $input } );
3518         push @results, $msg;
3519     }
3520
3521     return (@results);
3522 }
3523
3524
3525 sub ProcessRecordLinks {
3526     my %args = (
3527         RecordObj => undef,
3528         RecordId  => undef,
3529         ARGSRef   => undef,
3530         @_
3531     );
3532
3533     my $Record  = $args{'RecordObj'};
3534     my $RecordId = $args{'RecordId'} || $Record->Id;
3535     my $ARGSRef = $args{'ARGSRef'};
3536
3537     my (@results);
3538
3539     # Delete links that are gone gone gone.
3540     foreach my $arg ( keys %$ARGSRef ) {
3541         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3542             my $base   = $1;
3543             my $type   = $2;
3544             my $target = $3;
3545
3546             my ( $val, $msg ) = $Record->DeleteLink(
3547                 Base   => $base,
3548                 Type   => $type,
3549                 Target => $target
3550             );
3551
3552             push @results, $msg;
3553
3554         }
3555
3556     }
3557
3558     my @linktypes = qw( DependsOn MemberOf RefersTo );
3559
3560     foreach my $linktype (@linktypes) {
3561         my $input = $RecordId .'-'. $linktype;
3562         if ( $ARGSRef->{ $input } ) {
3563             $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3564                 if ref $ARGSRef->{ $input };
3565
3566             for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3567                 next unless $luri;
3568                 $luri =~ s/\s+$//;    # Strip trailing whitespace
3569                 my ( $val, $msg ) = $Record->AddLink(
3570                     Target => $luri,
3571                     Type   => $linktype
3572                 );
3573                 push @results, $msg;
3574             }
3575         }
3576         $input = $linktype .'-'. $RecordId;
3577         if ( $ARGSRef->{ $input } ) {
3578             $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } )
3579                 if ref $ARGSRef->{ $input };
3580
3581             for my $luri ( split( / /, $ARGSRef->{ $input } ) ) {
3582                 next unless $luri;
3583                 my ( $val, $msg ) = $Record->AddLink(
3584                     Base => $luri,
3585                     Type => $linktype
3586                 );
3587
3588                 push @results, $msg;
3589             }
3590         }
3591     }
3592
3593     return (@results);
3594 }
3595
3596 =head2 ProcessLinksForCreate
3597
3598 Takes a hash with a single key, C<ARGSRef>, the value of which is a hashref to
3599 C<%ARGS>.
3600
3601 Converts and returns submitted args in the form of C<new-LINKTYPE> and
3602 C<LINKTYPE-new> into their appropriate directional link types.  For example,
3603 C<new-DependsOn> becomes C<DependsOn> and C<DependsOn-new> becomes
3604 C<DependedOnBy>.  The incoming arg values are split on whitespace and
3605 normalized into arrayrefs before being returned.
3606
3607 Primarily used by object creation pages for transforming incoming form inputs
3608 from F</Elements/EditLinks> into arguments appropriate for individual record
3609 Create methods.
3610
3611 Returns a hashref in scalar context and a hash in list context.
3612
3613 =cut
3614
3615 sub ProcessLinksForCreate {
3616     my %args = @_;
3617     my %links;
3618
3619     foreach my $type ( keys %RT::Link::DIRMAP ) {
3620         for ([Base => "new-$type"], [Target => "$type-new"]) {
3621             my ($direction, $key) = @$_;
3622             next unless $args{ARGSRef}->{$key};
3623             $links{ $RT::Link::DIRMAP{$type}->{$direction} } = [
3624                 grep $_, split ' ', $args{ARGSRef}->{$key}
3625             ];
3626         }
3627     }
3628     return wantarray ? %links : \%links;
3629 }
3630
3631 =head2 ProcessTransactionSquelching
3632
3633 Takes a hashref of the submitted form arguments, C<%ARGS>.
3634
3635 Returns a hash of squelched addresses.
3636
3637 =cut
3638
3639 sub ProcessTransactionSquelching {
3640     my $args    = shift;
3641     my %checked = map { $_ => 1 } grep { defined }
3642         (    ref $args->{'TxnSendMailTo'} eq "ARRAY"  ? @{$args->{'TxnSendMailTo'}} :
3643          defined $args->{'TxnSendMailTo'}             ?  ($args->{'TxnSendMailTo'}) :
3644                                                                              () );
3645     my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3646     return %squelched;
3647 }
3648
3649 sub ProcessRecordBulkCustomFields {
3650     my %args = (RecordObj => undef, ARGSRef => {}, @_);
3651
3652     my $ARGSRef = $args{'ARGSRef'};
3653
3654     my %data;
3655
3656     my @results;
3657     foreach my $key ( keys %$ARGSRef ) {
3658         next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/;
3659         my ($op, $cfid, $rest) = ($1, $2, $3);
3660         next if $rest =~ /-Category$/;
3661
3662         my $res = $data{$cfid} ||= {};
3663         unless (keys %$res) {
3664             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
3665             $cf->Load( $cfid );
3666             next unless $cf->Id;
3667
3668             $res->{'cf'} = $cf;
3669         }
3670
3671         if ( $op eq 'Delete' && $rest eq 'AllValues' ) {
3672             $res->{'DeleteAll'} = $ARGSRef->{$key};
3673             next;
3674         }
3675
3676         my @values = _NormalizeObjectCustomFieldValue(
3677             CustomField => $res->{'cf'},
3678             Value => $ARGSRef->{$key},
3679             Param => $key,
3680         );
3681         next unless @values;
3682         $res->{$op} = \@values;
3683     }
3684
3685     while ( my ($cfid, $data) = each %data ) {
3686         my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid );
3687
3688         # just add one value for fields with single value
3689         if ( $data->{'Add'} && $data->{'cf'}->MaxValues == 1 ) {
3690             next if $current_values->HasEntry($data->{Add}[-1]);
3691
3692             my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3693                 Field => $cfid,
3694                 Value => $data->{'Add'}[-1],
3695             );
3696             push @results, $msg;
3697             next;
3698         }
3699
3700         if ( $data->{'DeleteAll'} ) {
3701             while ( my $value = $current_values->Next ) {
3702                 my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3703                     Field   => $cfid,
3704                     ValueId => $value->id,
3705                 );
3706                 push @results, $msg;
3707             }
3708         }
3709         foreach my $value ( @{ $data->{'Delete'} || [] } ) {
3710             my $entry = $current_values->HasEntry($value);
3711             next unless $entry;
3712
3713             my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue(
3714                 Field   => $cfid,
3715                 ValueId => $entry->id,
3716             );
3717             push @results, $msg;
3718         }
3719         foreach my $value ( @{ $data->{'Add'} || [] } ) {
3720             next if $current_values->HasEntry($value);
3721
3722             my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue(
3723                 Field => $cfid,
3724                 Value => $value
3725             );
3726             push @results, $msg;
3727         }
3728     }
3729     return @results;
3730 }
3731
3732 =head2 _UploadedFile ( $arg );
3733
3734 Takes a CGI parameter name; if a file is uploaded under that name,
3735 return a hash reference suitable for AddCustomFieldValue's use:
3736 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3737
3738 Returns C<undef> if no files were uploaded in the C<$arg> field.
3739
3740 =cut
3741
3742 sub _UploadedFile {
3743     my $arg         = shift;
3744     my $cgi_object  = $m->cgi_object;
3745     my $fh          = $cgi_object->upload($arg) or return undef;
3746     my $upload_info = $cgi_object->uploadInfo($fh);
3747
3748     my $filename = "$fh";
3749     $filename =~ s#^.*[\\/]##;
3750     binmode($fh);
3751
3752     return {
3753         Value        => $filename,
3754         LargeContent => do { local $/; scalar <$fh> },
3755         ContentType  => $upload_info->{'Content-Type'},
3756     };
3757 }
3758
3759 sub GetColumnMapEntry {
3760     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3761
3762     # deal with the simplest thing first
3763     if ( $args{'Map'}{ $args{'Name'} } ) {
3764         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3765     }
3766
3767     # complex things
3768     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3769         $subkey =~ s/^\{(.*)\}$/$1/;
3770         return undef unless $args{'Map'}->{$mainkey};
3771         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3772             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3773
3774         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3775     }
3776     return undef;
3777 }
3778
3779 sub ProcessColumnMapValue {
3780     my $value = shift;
3781     my %args = ( Arguments => [], Escape => 1, @_ );
3782
3783     if ( ref $value ) {
3784         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3785             my @tmp = $value->( @{ $args{'Arguments'} } );
3786             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3787         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3788             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3789         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3790             return $$value;
3791         }
3792     } else {
3793         if ($args{'Escape'}) {
3794             $value = $m->interp->apply_escapes( $value, 'h' );
3795             $value =~ s/\n/<br>/g if defined $value;
3796         }
3797         return $value;
3798     }
3799 }
3800
3801 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3802
3803 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3804 principal collections mapped from the categories given.
3805
3806 =cut
3807
3808 sub GetPrincipalsMap {
3809     my $object = shift;
3810     my @map;
3811     for (@_) {
3812         if (/System/) {
3813             my $system = RT::Groups->new($session{'CurrentUser'});
3814             $system->LimitToSystemInternalGroups();
3815             $system->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3816             push @map, [
3817                 'System' => $system,    # loc_left_pair
3818                 'Name'   => 1,
3819             ];
3820         }
3821         elsif (/Groups/) {
3822             my $groups = RT::Groups->new($session{'CurrentUser'});
3823             $groups->LimitToUserDefinedGroups();
3824             $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3825
3826             # Only show groups who have rights granted on this object
3827             $groups->WithGroupRight(
3828                 Right   => '',
3829                 Object  => $object,
3830                 IncludeSystemRights => 0,
3831                 IncludeSubgroupMembers => 0,
3832             );
3833
3834             push @map, [
3835                 'User Groups' => $groups,   # loc_left_pair
3836                 'Name'        => 0
3837             ];
3838         }
3839         elsif (/Roles/) {
3840             my $roles = RT::Groups->new($session{'CurrentUser'});
3841
3842             if ($object->isa("RT::CustomField")) {
3843                 # If we're a custom field, show the global roles for our LookupType.
3844                 my $class = $object->RecordClassFromLookupType;
3845                 if ($class and $class->DOES("RT::Record::Role::Roles")) {
3846                     $roles->LimitToRolesForObject(RT->System);
3847                     $roles->Limit(
3848                         FIELD         => "Name",
3849                         FUNCTION      => 'LOWER(?)',
3850                         OPERATOR      => "IN",
3851                         VALUE         => [ map {lc $_} $class->Roles ],
3852                         CASESENSITIVE => 1,
3853                     );
3854                 } else {
3855                     # No roles to show; so show nothing
3856                     undef $roles;
3857                 }
3858             } else {
3859                 $roles->LimitToRolesForObject($object);
3860             }
3861
3862             if ($roles) {
3863                 $roles->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3864                 push @map, [
3865                     'Roles' => $roles,  # loc_left_pair
3866                     'Name'  => 1
3867                 ];
3868             }
3869         }
3870         elsif (/Users/) {
3871             my $Users = RT->PrivilegedUsers->UserMembersObj();
3872             $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3873
3874             # Only show users who have rights granted on this object
3875             my $group_members = $Users->WhoHaveGroupRight(
3876                 Right   => '',
3877                 Object  => $object,
3878                 IncludeSystemRights => 0,
3879                 IncludeSubgroupMembers => 0,
3880             );
3881
3882             # Limit to UserEquiv groups
3883             my $groups = $Users->Join(
3884                 ALIAS1 => $group_members,
3885                 FIELD1 => 'GroupId',
3886                 TABLE2 => 'Groups',
3887                 FIELD2 => 'id',
3888             );
3889             $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence', CASESENSITIVE => 0 );
3890             $Users->Limit( ALIAS => $groups, FIELD => 'Name', VALUE => 'UserEquiv', CASESENSITIVE => 0 );
3891
3892             push @map, [
3893                 'Users' => $Users,  # loc_left_pair
3894                 'Format' => 0
3895             ];
3896         }
3897     }
3898     return @map;
3899 }
3900
3901 =head2 _load_container_object ( $type, $id );
3902
3903 Instantiate container object for saving searches.
3904
3905 =cut
3906
3907 sub _load_container_object {
3908     my ( $obj_type, $obj_id ) = @_;
3909     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3910 }
3911
3912 =head2 _parse_saved_search ( $arg );
3913
3914 Given a serialization string for saved search, and returns the
3915 container object and the search id.
3916
3917 =cut
3918
3919 sub _parse_saved_search {
3920     my $spec = shift;
3921     return unless $spec;
3922     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3923         return;
3924     }
3925     my $obj_type  = $1;
3926     my $obj_id    = $2;
3927     my $search_id = $3;
3928
3929     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3930 }
3931
3932 =head2 ScrubHTML content
3933
3934 Removes unsafe and undesired HTML from the passed content
3935
3936 =cut
3937
3938 my $SCRUBBER;
3939 sub ScrubHTML {
3940     my $Content = shift;
3941     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3942
3943     $Content = '' if !defined($Content);
3944     return $SCRUBBER->scrub($Content);
3945 }
3946
3947 =head2 _NewScrubber
3948
3949 Returns a new L<HTML::Scrubber> object.
3950
3951 If you need to be more lax about what HTML tags and attributes are allowed,
3952 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3953 following:
3954
3955     package HTML::Mason::Commands;
3956     # Let tables through
3957     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3958     1;
3959
3960 =cut
3961
3962 our @SCRUBBER_ALLOWED_TAGS = qw(
3963     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP S DEL STRIKE H1 H2 H3 H4 H5
3964     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3965 );
3966
3967 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3968     # Match http, https, ftp, mailto and relative urls
3969     # XXX: we also scrub format strings with this module then allow simple config options
3970     href   => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|HomePath|BaseURL|URL)__)}i,
3971     face   => 1,
3972     size   => 1,
3973     color  => 1,
3974     target => 1,
3975     style  => qr{
3976         ^(?:\s*
3977             (?:(?:background-)?color: \s*
3978                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
3979                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
3980                        [\w\-]+                                  # green, light-blue, etc.
3981                        )                            |
3982                text-align: \s* \w+                  |
3983                font-size: \s* [\w.\-]+              |
3984                font-family: \s* [\w\s"',.\-]+       |
3985                font-weight: \s* [\w\-]+             |
3986
3987                border-style: \s* \w+                |
3988                border-color: \s* [#\w]+             |
3989                border-width: \s* [\s\w]+            |
3990                padding: \s* [\s\w]+                 |
3991                margin: \s* [\s\w]+                  |
3992
3993                # MS Office styles, which are probably fine.  If we don't, then any
3994                # associated styles in the same attribute get stripped.
3995                mso-[\w\-]+?: \s* [\w\s"',.\-]+
3996             )\s* ;? \s*)
3997          +$ # one or more of these allowed properties from here 'till sunset
3998     }ix,
3999     dir    => qr/^(rtl|ltr)$/i,
4000     lang   => qr/^\w+(-\w+)?$/,
4001 );
4002
4003 our %SCRUBBER_RULES = ();
4004
4005 # If we're displaying images, let embedded ones through
4006 if (RT->Config->Get('ShowTransactionImages') or RT->Config->Get('ShowRemoteImages')) {
4007     $SCRUBBER_RULES{'img'} = {
4008         '*' => 0,
4009         alt => 1,
4010     };
4011
4012     my @src;
4013     push @src, qr/^cid:/i
4014         if RT->Config->Get('ShowTransactionImages');
4015
4016     push @src, $SCRUBBER_ALLOWED_ATTRIBUTES{'href'}
4017         if RT->Config->Get('ShowRemoteImages');
4018
4019     $SCRUBBER_RULES{'img'}->{'src'} = join "|", @src;
4020 }
4021
4022 sub _NewScrubber {
4023     require HTML::Scrubber;
4024     my $scrubber = HTML::Scrubber->new();
4025
4026     if (HTML::Gumbo->require) {
4027         no warnings 'redefine';
4028         my $orig = \&HTML::Scrubber::scrub;
4029         *HTML::Scrubber::scrub = sub {
4030             my $self = shift;
4031
4032             eval { $_[0] = HTML::Gumbo->new->parse( $_[0] ); chomp $_[0] };
4033             warn "HTML::Gumbo pre-parse failed: $@" if $@;
4034             return $orig->($self, @_);
4035         };
4036         push @SCRUBBER_ALLOWED_TAGS, qw/TABLE THEAD TBODY TFOOT TR TD TH/;
4037         $SCRUBBER_ALLOWED_ATTRIBUTES{$_} = 1 for
4038             qw/colspan rowspan align valign cellspacing cellpadding border width height/;
4039     }
4040
4041     $scrubber->default(
4042         0,
4043         {
4044             %SCRUBBER_ALLOWED_ATTRIBUTES,
4045             '*' => 0, # require attributes be explicitly allowed
4046         },
4047     );
4048     $scrubber->deny(qw[*]);
4049     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
4050     $scrubber->rules(%SCRUBBER_RULES);
4051
4052     # Scrubbing comments is vital since IE conditional comments can contain
4053     # arbitrary HTML and we'd pass it right on through.
4054     $scrubber->comment(0);
4055
4056     return $scrubber;
4057 }
4058
4059 =head2 JSON
4060
4061 Redispatches to L<RT::Interface::Web/EncodeJSON>
4062
4063 =cut
4064
4065 sub JSON {
4066     RT::Interface::Web::EncodeJSON(@_);
4067 }
4068
4069 sub CSSClass {
4070     my $value = shift;
4071     return '' unless defined $value;
4072     $value =~ s/[^A-Za-z0-9_-]/_/g;
4073     return $value;
4074 }
4075
4076 sub GetCustomFieldInputName {
4077     RT::Interface::Web::GetCustomFieldInputName(@_);
4078 }
4079
4080 sub GetCustomFieldInputNamePrefix {
4081     RT::Interface::Web::GetCustomFieldInputNamePrefix(@_);
4082 }
4083
4084 package RT::Interface::Web;
4085 RT::Base->_ImportOverlays();
4086
4087 1;