lib/RT/Interface/Web.pm

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