lib/RT/Interface/Web.pm

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