lib/RT/Interface/Web.pm

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