rt/lib/RT/Interface/Web.pm

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