rt/lib/RT/Interface/Web.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2011 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::Session;
  69 use Digest::MD5 ();
  70 use Encode qw();
  71
  72 # {{{ EscapeUTF8
  73
  74 =head2 EscapeUTF8 SCALARREF
  75
  76 does a css-busting but minimalist escaping of whatever html you're passing in.
  77
  78 =cut
  79
  80 sub EscapeUTF8 {
  81     my $ref = shift;
  82     return unless defined $$ref;
  83
  84     $$ref =~ s/&/&#38;/g;
  85     $$ref =~ s/</&lt;/g;
  86     $$ref =~ s/>/&gt;/g;
  87     $$ref =~ s/\(/&#40;/g;
  88     $$ref =~ s/\)/&#41;/g;
  89     $$ref =~ s/"/&#34;/g;
  90     $$ref =~ s/'/&#39;/g;
  91 }
  92
  93 # }}}
  94
  95 # {{{ EscapeURI
  96
  97 =head2 EscapeURI SCALARREF
  98
  99 Escapes URI component according to RFC2396
 100
 101 =cut
 102
 103 sub EscapeURI {
 104     my $ref = shift;
 105     return unless defined $$ref;
 106
 107     use bytes;
 108     $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
 109 }
 110
 111 # }}}
 112
 113 sub _encode_surrogates {
 114     my $uni = $_[0] - 0x10000;
 115     return ($uni /  0x400 + 0xD800, $uni % 0x400 + 0xDC00);
 116 }
 117
 118 sub EscapeJS {
 119     my $ref = shift;
 120     return unless defined $$ref;
 121
 122     $$ref = "'" . join('',
 123                  map {
 124                      chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
 125                      $_  <= 255   ? sprintf("\\x%02X", $_) :
 126                      $_  <= 65535 ? sprintf("\\u%04X", $_) :
 127                      sprintf("\\u%X\\u%X", _encode_surrogates($_))
 128                  } unpack('U*', $$ref))
 129         . "'";
 130 }
 131
 132 # {{{ WebCanonicalizeInfo
 133
 134 =head2 WebCanonicalizeInfo();
 135
 136 Different web servers set different environmental varibles. This
 137 function must return something suitable for REMOTE_USER. By default,
 138 just downcase $ENV{'REMOTE_USER'}
 139
 140 =cut
 141
 142 sub WebCanonicalizeInfo {
 143     return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
 144 }
 145
 146 # }}}
 147
 148 # {{{ WebExternalAutoInfo
 149
 150 =head2 WebExternalAutoInfo($user);
 151
 152 Returns a hash of user attributes, used when WebExternalAuto is set.
 153
 154 =cut
 155
 156 sub WebExternalAutoInfo {
 157     my $user = shift;
 158
 159     my %user_info;
 160
 161     # default to making Privileged users, even if they specify
 162     # some other default Attributes
 163     if ( !$RT::AutoCreate
 164         || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
 165     {
 166         $user_info{'Privileged'} = 1;
 167     }
 168
 169     if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
 170
 171         # Populate fields with information from Unix /etc/passwd
 172
 173         my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
 174         $user_info{'Comments'} = $comments if defined $comments;
 175         $user_info{'RealName'} = $realname if defined $realname;
 176     } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
 177
 178         # Populate fields with information from NT domain controller
 179     }
 180
 181     # and return the wad of stuff
 182     return {%user_info};
 183 }
 184
 185 # }}}
 186
 187 sub HandleRequest {
 188     my $ARGS = shift;
 189
 190     $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
 191
 192     $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
 193
 194     # Roll back any dangling transactions from a previous failed connection
 195     $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth;
 196
 197     MaybeEnableSQLStatementLog();
 198
 199     # avoid reentrancy, as suggested by masonbook
 200     local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
 201
 202     $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
 203         if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
 204
 205     DecodeARGS($ARGS);
 206     PreprocessTimeUpdates($ARGS);
 207
 208     MaybeShowInstallModePage();
 209
 210     $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
 211     SendSessionCookie();
 212     $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
 213
 214     # Process session-related callbacks before any auth attempts
 215     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
 216
 217     MaybeRejectPrivateComponentRequest();
 218
 219     MaybeShowNoAuthPage($ARGS);
 220
 221     AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
 222
 223     _ForceLogout() unless _UserLoggedIn();
 224
 225     # Process per-page authentication callbacks
 226     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
 227
 228     unless ( _UserLoggedIn() ) {
 229         _ForceLogout();
 230
 231         # Authenticate if the user is trying to login via user/pass query args
 232         my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
 233
 234         unless ($authed) {
 235             my $m = $HTML::Mason::Commands::m;
 236
 237             # REST urls get a special 401 response
 238             if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
 239                 $HTML::Mason::Commands::r->content_type("text/plain");
 240                 $m->error_format("text");
 241                 $m->out("RT/$RT::VERSION 401 Credentials required\n");
 242                 $m->out("\n$msg\n") if $msg;
 243                 $m->abort;
 244             }
 245             # Specially handle /index.html so that we get a nicer URL
 246             elsif ( $m->request_comp->path eq '/index.html' ) {
 247                 my $next = SetNextPage(RT->Config->Get('WebURL'));
 248                 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
 249                 $m->abort;
 250             }
 251             else {
 252                 TangentForLogin(results => ($msg ? LoginError($msg) : undef));
 253             }
 254         }
 255     }
 256
 257     MaybeShowInterstitialCSRFPage($ARGS);
 258
 259     # now it applies not only to home page, but any dashboard that can be used as a workspace
 260     $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
 261         if ( $ARGS->{'HomeRefreshInterval'} );
 262
 263     # Process per-page global callbacks
 264     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
 265
 266     ShowRequestedPage($ARGS);
 267     LogRecordedSQLStatements();
 268
 269     # Process per-page final cleanup callbacks
 270     $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
 271 }
 272
 273 sub _ForceLogout {
 274
 275     delete $HTML::Mason::Commands::session{'CurrentUser'};
 276 }
 277
 278 sub _UserLoggedIn {
 279     if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
 280         return 1;
 281     } else {
 282         return undef;
 283     }
 284
 285 }
 286
 287 =head2 LoginError ERROR
 288
 289 Pushes a login error into the Actions session store and returns the hash key.
 290
 291 =cut
 292
 293 sub LoginError {
 294     my $new = shift;
 295     my $key = Digest::MD5::md5_hex( rand(1024) );
 296     push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
 297     $HTML::Mason::Commands::session{'i'}++;
 298     return $key;
 299 }
 300
 301 =head2 SetNextPage [PATH]
 302
 303 Intuits and stashes the next page in the sesssion hash.  If PATH is
 304 specified, uses that instead of the value of L<IntuitNextPage()>.  Returns
 305 the hash value.
 306
 307 =cut
 308
 309 sub SetNextPage {
 310     my $next = shift || IntuitNextPage();
 311     my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
 312
 313     $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next;
 314     $HTML::Mason::Commands::session{'i'}++;
 315     return $hash;
 316 }
 317
 318
 319 =head2 TangentForLogin [HASH]
 320
 321 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
 322 the next page.  Optionally takes a hash which is dumped into query params.
 323
 324 =cut
 325
 326 sub TangentForLogin {
 327     my $hash  = SetNextPage();
 328     my %query = (@_, next => $hash);
 329     my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
 330     $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
 331     Redirect($login);
 332 }
 333
 334 =head2 TangentForLoginWithError ERROR
 335
 336 Localizes the passed error message, stashes it with L<LoginError> and then
 337 calls L<TangentForLogin> with the appropriate results key.
 338
 339 =cut
 340
 341 sub TangentForLoginWithError {
 342     my $key = LoginError(HTML::Mason::Commands::loc(@_));
 343     TangentForLogin( results => $key );
 344 }
 345
 346 =head2 IntuitNextPage
 347
 348 Attempt to figure out the path to which we should return the user after a
 349 tangent.  The current request URL is used, or failing that, the C<WebURL>
 350 configuration variable.
 351
 352 =cut
 353
 354 sub IntuitNextPage {
 355     my $req_uri;
 356
 357     # This includes any query parameters.  Redirect will take care of making
 358     # it an absolute URL.
 359     if ($ENV{'REQUEST_URI'}) {
 360         $req_uri = $ENV{'REQUEST_URI'};
 361
 362         # collapse multiple leading slashes so the first part doesn't look like
 363         # a hostname of a schema-less URI
 364         $req_uri =~ s{^/+}{/};
 365     }
 366
 367     my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
 368
 369     # sanitize $next
 370     my $uri = URI->new($next);
 371
 372     # You get undef scheme with a relative uri like "/Search/Build.html"
 373     unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
 374         $next = RT->Config->Get('WebURL');
 375     }
 376
 377     # Make sure we're logging in to the same domain
 378     # You can get an undef authority with a relative uri like "index.html"
 379     my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
 380     unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
 381         $next = RT->Config->Get('WebURL');
 382     }
 383
 384     return $next;
 385 }
 386
 387 =head2 MaybeShowInstallModePage
 388
 389 This function, called exclusively by RT's autohandler, dispatches
 390 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
 391
 392 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
 393
 394 =cut
 395
 396 sub MaybeShowInstallModePage {
 397     return unless RT->InstallMode;
 398
 399     my $m = $HTML::Mason::Commands::m;
 400     if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
 401         $m->call_next();
 402     } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
 403         RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
 404     } else {
 405         $m->call_next();
 406     }
 407     $m->abort();
 408 }
 409
 410 =head2 MaybeShowNoAuthPage  \%ARGS
 411
 412 This function, called exclusively by RT's autohandler, dispatches
 413 a request to the page a user requested (but only if it matches the "noauth" regex.
 414
 415 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
 416
 417 =cut
 418
 419 sub MaybeShowNoAuthPage {
 420     my $ARGS = shift;
 421
 422     my $m = $HTML::Mason::Commands::m;
 423
 424     return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
 425
 426     # Don't show the login page to logged in users
 427     Redirect(RT->Config->Get('WebURL'))
 428         if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
 429
 430     # If it's a noauth file, don't ask for auth.
 431     $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
 432     $m->abort;
 433 }
 434
 435 =head2 MaybeRejectPrivateComponentRequest
 436
 437 This function will reject calls to private components, like those under
 438 C</Elements>. If the requested path is a private component then we will
 439 abort with a C<403> error.
 440
 441 =cut
 442
 443 sub MaybeRejectPrivateComponentRequest {
 444     my $m = $HTML::Mason::Commands::m;
 445     my $path = $m->request_comp->path;
 446
 447     # We do not check for dhandler here, because requesting our dhandlers
 448     # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
 449     # 'dhandler'.
 450
 451     if ($path =~ m{
 452             / # leading slash
 453             ( Elements    |
 454               _elements   | # mobile UI
 455               Widgets     |
 456               autohandler | # requesting this directly is suspicious
 457               l (_unsafe)? ) # loc component
 458             ( $ | / ) # trailing slash or end of path
 459         }xi
 460         && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
 461       )
 462     {
 463             warn "rejecting private component $path\n";
 464             $m->abort(403);
 465     }
 466
 467     return;
 468 }
 469
 470 =head2 ShowRequestedPage  \%ARGS
 471
 472 This function, called exclusively by RT's autohandler, dispatches
 473 a request to the page a user requested (making sure that unpriviled users
 474 can only see self-service pages.
 475
 476 =cut
 477
 478 sub ShowRequestedPage {
 479     my $ARGS = shift;
 480
 481     my $m = $HTML::Mason::Commands::m;
 482
 483     # Ensure that the cookie that we send is up-to-date, in case the
 484     # session-id has been modified in any way
 485     SendSessionCookie();
 486
 487     # If the user isn't privileged, they can only see SelfService
 488     unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
 489
 490         # if the user is trying to access a ticket, redirect them
 491         if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
 492             RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
 493         }
 494
 495         # otherwise, drop the user at the SelfService default page
 496         elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
 497             RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
 498         }
 499
 500         # if user is in SelfService dir let him do anything
 501         else {
 502             $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
 503         }
 504     } else {
 505         $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
 506     }
 507
 508 }
 509
 510 sub AttemptExternalAuth {
 511     my $ARGS = shift;
 512
 513     return unless ( RT->Config->Get('WebExternalAuth') );
 514
 515     my $user = $ARGS->{user};
 516     my $m    = $HTML::Mason::Commands::m;
 517
 518     # If RT is configured for external auth, let's go through and get REMOTE_USER
 519
 520     # do we actually have a REMOTE_USER equivlent?
 521     if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
 522         my $orig_user = $user;
 523
 524         $user = RT::Interface::Web::WebCanonicalizeInfo();
 525         my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
 526
 527         if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
 528             my $NodeName = Win32::NodeName();
 529             $user =~ s/^\Q$NodeName\E\\//i;
 530         }
 531
 532         InstantiateNewSession() unless _UserLoggedIn;
 533         $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
 534         $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
 535
 536         if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
 537
 538             # Create users on-the-fly
 539             my $UserObj = RT::User->new($RT::SystemUser);
 540             my ( $val, $msg ) = $UserObj->Create(
 541                 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
 542                 Name  => $user,
 543                 Gecos => $user,
 544             );
 545
 546             if ($val) {
 547
 548                 # now get user specific information, to better create our user.
 549                 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
 550
 551                 # set the attributes that have been defined.
 552                 foreach my $attribute ( $UserObj->WritableAttributes ) {
 553                     $m->callback(
 554                         Attribute    => $attribute,
 555                         User         => $user,
 556                         UserInfo     => $new_user_info,
 557                         CallbackName => 'NewUser',
 558                         CallbackPage => '/autohandler'
 559                     );
 560                     my $method = "Set$attribute";
 561                     $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
 562                 }
 563                 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
 564             } else {
 565
 566                 # we failed to successfully create the user. abort abort abort.
 567                 delete $HTML::Mason::Commands::session{'CurrentUser'};
 568
 569                 if (RT->Config->Get('WebFallbackToInternalAuth')) {
 570                     TangentForLoginWithError('Cannot create user: [_1]', $msg);
 571                 } else {
 572                     $m->abort();
 573                 }
 574             }
 575         }
 576
 577         if ( _UserLoggedIn() ) {
 578             $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
 579         } else {
 580             delete $HTML::Mason::Commands::session{'CurrentUser'};
 581             $user = $orig_user;
 582
 583             if ( RT->Config->Get('WebExternalOnly') ) {
 584                 TangentForLoginWithError('You are not an authorized user');
 585             }
 586         }
 587     } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
 588         unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
 589             # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
 590             TangentForLoginWithError('You are not an authorized user');
 591         }
 592     } else {
 593
 594         # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
 595         # XXX: we must return AUTH_REQUIRED status or we fallback to
 596         # internal auth here too.
 597         delete $HTML::Mason::Commands::session{'CurrentUser'}
 598             if defined $HTML::Mason::Commands::session{'CurrentUser'};
 599     }
 600 }
 601
 602 sub AttemptPasswordAuthentication {
 603     my $ARGS = shift;
 604     return unless defined $ARGS->{user} && defined $ARGS->{pass};
 605
 606     my $user_obj = RT::CurrentUser->new();
 607     $user_obj->Load( $ARGS->{user} );
 608
 609     my $m = $HTML::Mason::Commands::m;
 610
 611     unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
 612         $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
 613         $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
 614         return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
 615     }
 616     else {
 617         $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
 618
 619         # It's important to nab the next page from the session before we blow
 620         # the session away
 621         my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''};
 622
 623         InstantiateNewSession();
 624         $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
 625
 626         $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
 627
 628         # Really the only time we don't want to redirect here is if we were
 629         # passed user and pass as query params in the URL.
 630         if ($next) {
 631             Redirect($next);
 632         }
 633         elsif ($ARGS->{'next'}) {
 634             # Invalid hash, but still wants to go somewhere, take them to /
 635             Redirect(RT->Config->Get('WebURL'));
 636         }
 637
 638         return (1, HTML::Mason::Commands::loc('Logged in'));
 639     }
 640 }
 641
 642 =head2 LoadSessionFromCookie
 643
 644 Load or setup a session cookie for the current user.
 645
 646 =cut
 647
 648 sub _SessionCookieName {
 649     my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
 650     $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
 651     return $cookiename;
 652 }
 653
 654 sub LoadSessionFromCookie {
 655
 656     my %cookies       = CGI::Cookie->fetch;
 657     my $cookiename    = _SessionCookieName();
 658     my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
 659     tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
 660     unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
 661         undef $cookies{$cookiename};
 662     }
 663     if ( int RT->Config->Get('AutoLogoff') ) {
 664         my $now = int( time / 60 );
 665         my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
 666
 667         if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
 668             InstantiateNewSession();
 669         }
 670
 671         # save session on each request when AutoLogoff is turned on
 672         $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
 673     }
 674 }
 675
 676 sub InstantiateNewSession {
 677     tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
 678     tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
 679     SendSessionCookie();
 680 }
 681
 682 sub SendSessionCookie {
 683     my $cookie = CGI::Cookie->new(
 684         -name     => _SessionCookieName(),
 685         -value    => $HTML::Mason::Commands::session{_session_id},
 686         -path     => RT->Config->Get('WebPath'),
 687         -secure   => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
 688         -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
 689     );
 690
 691     $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
 692 }
 693
 694 =head2 Redirect URL
 695
 696 This routine ells the current user's browser to redirect to URL.
 697 Additionally, it unties the user's currently active session, helping to avoid
 698 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
 699 a cached DBI statement handle twice at the same time.
 700
 701 =cut
 702
 703 sub Redirect {
 704     my $redir_to = shift;
 705     untie $HTML::Mason::Commands::session;
 706     my $uri        = URI->new($redir_to);
 707     my $server_uri = URI->new( RT->Config->Get('WebURL') );
 708
 709     # Make relative URIs absolute from the server host and scheme
 710     $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
 711     if (not defined $uri->host) {
 712         $uri->host($server_uri->host);
 713         $uri->port($server_uri->port);
 714     }
 715
 716     # If the user is coming in via a non-canonical
 717     # hostname, don't redirect them to the canonical host,
 718     # it will just upset them (and invalidate their credentials)
 719     # don't do this if $RT::CanoniaclRedirectURLs is true
 720     if (   !RT->Config->Get('CanonicalizeRedirectURLs')
 721         && $uri->host eq $server_uri->host
 722         && $uri->port eq $server_uri->port )
 723     {
 724         if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
 725             $uri->scheme('https');
 726         } else {
 727             $uri->scheme('http');
 728         }
 729
 730         # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
 731         $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
 732         $uri->port( $ENV{'SERVER_PORT'} );
 733     }
 734
 735     # not sure why, but on some systems without this call mason doesn't
 736     # set status to 302, but 200 instead and people see blank pages
 737     $HTML::Mason::Commands::r->status(302);
 738
 739     # Perlbal expects a status message, but Mason's default redirect status
 740     # doesn't provide one. See also rt.cpan.org #36689.
 741     $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
 742
 743     $HTML::Mason::Commands::m->abort;
 744 }
 745
 746 =head2 StaticFileHeaders
 747
 748 Send the browser a few headers to try to get it to (somewhat agressively)
 749 cache RT's static Javascript and CSS files.
 750
 751 This routine could really use _accurate_ heuristics. (XXX TODO)
 752
 753 =cut
 754
 755 sub StaticFileHeaders {
 756     my $date = RT::Date->new($RT::SystemUser);
 757
 758     # make cache public
 759     $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
 760
 761     # remove any cookie headers -- if it is cached publicly, it
 762     # shouldn't include anyone's cookie!
 763     delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
 764
 765     # Expire things in a month.
 766     $date->Set( Value => time + 30 * 24 * 60 * 60 );
 767     $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
 768
 769     # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
 770     # request, but we don't handle it and generate full reply again
 771     # Last modified at server start time
 772     # $date->Set( Value => $^T );
 773     # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
 774 }
 775
 776 =head2 ComponentPathIsSafe PATH
 777
 778 Takes C<PATH> and returns a boolean indicating that the user-specified partial
 779 component path is safe.
 780
 781 Currently "safe" means that the path does not start with a dot (C<.>) and does
 782 not contain a slash-dot C</.>.
 783
 784 =cut
 785
 786 sub ComponentPathIsSafe {
 787     my $self = shift;
 788     my $path = shift;
 789     return $path !~ m{(?:^|/)\.};
 790 }
 791
 792 =head2 PathIsSafe
 793
 794 Takes a C<< Path => path >> and returns a boolean indicating that
 795 the path is safely within RT's control or not. The path I<must> be
 796 relative.
 797
 798 This function does not consult the filesystem at all; it is merely
 799 a logical sanity checking of the path. This explicitly does not handle
 800 symlinks; if you have symlinks in RT's webroot pointing outside of it,
 801 then we assume you know what you are doing.
 802
 803 =cut
 804
 805 sub PathIsSafe {
 806     my $self = shift;
 807     my %args = @_;
 808     my $path = $args{Path};
 809
 810     # Get File::Spec to clean up extra /s, ./, etc
 811     my $cleaned_up = File::Spec->canonpath($path);
 812
 813     if (!defined($cleaned_up)) {
 814         $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
 815         return 0;
 816     }
 817
 818     # Forbid too many ..s. We can't just sum then check because
 819     # "../foo/bar/baz" should be illegal even though it has more
 820     # downdirs than updirs. So as soon as we get a negative score
 821     # (which means "breaking out" of the top level) we reject the path.
 822
 823     my @components = split '/', $cleaned_up;
 824     my $score = 0;
 825     for my $component (@components) {
 826         if ($component eq '..') {
 827             $score--;
 828             if ($score < 0) {
 829                 $RT::Logger->info("Rejecting unsafe path: $path");
 830                 return 0;
 831             }
 832         }
 833         elsif ($component eq '.' || $component eq '') {
 834             # these two have no effect on $score
 835         }
 836         else {
 837             $score++;
 838         }
 839     }
 840
 841     return 1;
 842 }
 843
 844 =head2 SendStaticFile
 845
 846 Takes a File => path and a Type => Content-type
 847
 848 If Type isn't provided and File is an image, it will
 849 figure out a sane Content-type, otherwise it will
 850 send application/octet-stream
 851
 852 Will set caching headers using StaticFileHeaders
 853
 854 =cut
 855
 856 sub SendStaticFile {
 857     my $self = shift;
 858     my %args = @_;
 859     my $file = $args{File};
 860     my $type = $args{Type};
 861     my $relfile = $args{RelativeFile};
 862
 863     if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
 864         $HTML::Mason::Commands::r->status(400);
 865         $HTML::Mason::Commands::m->abort;
 866     }
 867
 868     $self->StaticFileHeaders();
 869
 870     unless ($type) {
 871         if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
 872             $type = "image/$1";
 873             $type =~ s/jpg/jpeg/gi;
 874         }
 875         $type ||= "application/octet-stream";
 876     }
 877
 878     # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
 879     # since we don't specify a charset
 880     if ( $type =~ m{application/javascript} &&
 881          $type !~ m{charset=([\w-]+)$} ) {
 882          $type .= "; charset=utf-8";
 883     }
 884     $HTML::Mason::Commands::r->content_type($type);
 885     open( my $fh, '<', $file ) or die "couldn't open file: $!";
 886     binmode($fh);
 887     {
 888         local $/ = \16384;
 889         $HTML::Mason::Commands::m->out($_) while (<$fh>);
 890         $HTML::Mason::Commands::m->flush_buffer;
 891     }
 892     close $fh;
 893 }
 894
 895 sub StripContent {
 896     my %args    = @_;
 897     my $content = $args{Content};
 898     return '' unless $content;
 899
 900     # Make the content have no 'weird' newlines in it
 901     $content =~ s/\r+\n/\n/g;
 902
 903     my $return_content = $content;
 904
 905     my $html = $args{ContentType} && $args{ContentType} eq "text/html";
 906     my $sigonly = $args{StripSignature};
 907
 908     # massage content to easily detect if there's any real content
 909     $content =~ s/\s+//g; # yes! remove all the spaces
 910     if ( $html ) {
 911         # remove html version of spaces and newlines
 912         $content =~ s!&nbsp;!!g;
 913         $content =~ s!<br/?>!!g;
 914     }
 915
 916     # Filter empty content when type is text/html
 917     return '' if $html && $content !~ /\S/;
 918
 919     # If we aren't supposed to strip the sig, just bail now.
 920     return $return_content unless $sigonly;
 921
 922     # Find the signature
 923     my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
 924     $sig =~ s/\s+//g;
 925
 926     # Check for plaintext sig
 927     return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
 928
 929     # Check for html-formatted sig; we don't use EscapeUTF8 here
 930     # because we want to precisely match the escaping that FCKEditor
 931     # uses. see also 311223f5, which fixed this for 4.0
 932     $sig =~ s/&/&amp;/g;
 933     $sig =~ s/</&lt;/g;
 934     $sig =~ s/>/&gt;/g;
 935
 936     return ''
 937       if $html
 938           and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
 939
 940     # Pass it through
 941     return $return_content;
 942 }
 943
 944 sub DecodeARGS {
 945     my $ARGS = shift;
 946
 947     %{$ARGS} = map {
 948
 949         # if they've passed multiple values, they'll be an array. if they've
 950         # passed just one, a scalar whatever they are, mark them as utf8
 951         my $type = ref($_);
 952         ( !$type )
 953             ? Encode::is_utf8($_)
 954                 ? $_
 955                 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
 956             : ( $type eq 'ARRAY' )
 957             ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
 958                 @$_ ]
 959             : ( $type eq 'HASH' )
 960             ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
 961                 %$_ }
 962             : $_
 963     } %$ARGS;
 964 }
 965
 966 sub PreprocessTimeUpdates {
 967     my $ARGS = shift;
 968
 969     # Later in the code we use
 970     # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
 971     # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
 972     # The call_next method pass through original arguments and if you have
 973     # an argument with unicode key then in a next component you'll get two
 974     # records in the args hash: one with key without UTF8 flag and another
 975     # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
 976     # is copied from mason's source to get the same results as we get from
 977     # call_next method, this feature is not documented, so we just leave it
 978     # here to avoid possible side effects.
 979
 980     # This code canonicalizes time inputs in hours into minutes
 981     foreach my $field ( keys %$ARGS ) {
 982         next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
 983         my $local = $1;
 984         $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
 985                       {($1 || 0) + $3 ? $2 / $3 : 0}xe;
 986         if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
 987             $ARGS->{$local} *= 60;
 988         }
 989         delete $ARGS->{$field};
 990     }
 991
 992 }
 993
 994 sub MaybeEnableSQLStatementLog {
 995
 996     my $log_sql_statements = RT->Config->Get('StatementLog');
 997
 998     if ($log_sql_statements) {
 999         $RT::Handle->ClearSQLStatementLog;
1000         $RT::Handle->LogSQLStatements(1);
1001     }
1002
1003 }
1004
1005 sub LogRecordedSQLStatements {
1006     my $log_sql_statements = RT->Config->Get('StatementLog');
1007
1008     return unless ($log_sql_statements);
1009
1010     my @log = $RT::Handle->SQLStatementLog;
1011     $RT::Handle->ClearSQLStatementLog;
1012     for my $stmt (@log) {
1013         my ( $time, $sql, $bind, $duration ) = @{$stmt};
1014         my @bind;
1015         if ( ref $bind ) {
1016             @bind = @{$bind};
1017         } else {
1018
1019             # Older DBIx-SB
1020             $duration = $bind;
1021         }
1022         $RT::Logger->log(
1023             level   => $log_sql_statements,
1024             message => "SQL("
1025                 . sprintf( "%.6f", $duration )
1026                 . "s): $sql;"
1027                 . ( @bind ? "  [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
1028         );
1029     }
1030
1031 }
1032
1033 our %is_whitelisted_component = (
1034     # The RSS feed embeds an auth token in the path, but query
1035     # information for the search.  Because it's a straight-up read, in
1036     # addition to embedding its own auth, it's fine.
1037     '/NoAuth/rss/dhandler' => 1,
1038
1039     # IE doesn't send referer in window.open()
1040     # besides, as a harmless calendar select page, it's fine
1041     '/Helpers/CalPopup.html' => 1,
1042
1043     # While both of these can be used for denial-of-service against RT
1044     # (construct a very inefficient query and trick lots of users into
1045     # running them against RT) it's incredibly useful to be able to link
1046     # to a search result or bookmark a result page.
1047     '/Search/Results.html' => 1,
1048     '/Search/Simple.html'  => 1,
1049 );
1050
1051 sub IsCompCSRFWhitelisted {
1052     my $comp = shift;
1053     my $ARGS = shift;
1054
1055     return 1 if $is_whitelisted_component{$comp};
1056
1057     my %args = %{ $ARGS };
1058
1059     # If the user specifies a *correct* user and pass then they are
1060     # golden.  This acts on the presumption that external forms may
1061     # hardcode a username and password -- if a malicious attacker knew
1062     # both already, CSRF is the least of your problems.
1063     my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1064     if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1065         my $user_obj = RT::CurrentUser->new();
1066         $user_obj->Load($args{user});
1067         return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1068
1069         delete $args{user};
1070         delete $args{pass};
1071     }
1072
1073     # Eliminate arguments that do not indicate an effectful request.
1074     # For example, "id" is acceptable because that is how RT retrieves a
1075     # record.
1076     delete $args{id};
1077
1078     # If they have a valid results= from MaybeRedirectForResults, that's
1079     # also fine.
1080     delete $args{results} if $args{results}
1081         and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1082
1083     # The homepage refresh, which uses the Refresh header, doesn't send
1084     # a referer in most browsers; whitelist the one parameter it reloads
1085     # with, HomeRefreshInterval, which is safe
1086     delete $args{HomeRefreshInterval};
1087
1088     # If there are no arguments, then it's likely to be an idempotent
1089     # request, which are not susceptible to CSRF
1090     return 1 if !%args;
1091
1092     return 0;
1093 }
1094
1095 sub IsRefererCSRFWhitelisted {
1096     my $referer = _NormalizeHost(shift);
1097     my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1098     $base_url = $base_url->host_port;
1099
1100     my $configs;
1101     for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1102         push @$configs,$config;
1103         return 1 if $referer->host_port eq $config;
1104     }
1105
1106     return (0,$referer,$configs);
1107 }
1108
1109 =head3 _NormalizeHost
1110
1111 Takes a URI and creates a URI object that's been normalized
1112 to handle common problems such as localhost vs 127.0.0.1
1113
1114 =cut
1115
1116 sub _NormalizeHost {
1117
1118     my $uri= URI->new(shift);
1119     $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1120
1121     return $uri;
1122
1123 }
1124
1125 sub IsPossibleCSRF {
1126     my $ARGS = shift;
1127
1128     # If first request on this session is to a REST endpoint, then
1129     # whitelist the REST endpoints -- and explicitly deny non-REST
1130     # endpoints.  We do this because using a REST cookie in a browser
1131     # would open the user to CSRF attacks to the REST endpoints.
1132     my $comp = $HTML::Mason::Commands::m->request_comp->path;
1133     $HTML::Mason::Commands::session{'REST'} = $comp =~ m{^/REST/\d+\.\d+/}
1134         unless defined $HTML::Mason::Commands::session{'REST'};
1135
1136     if ($HTML::Mason::Commands::session{'REST'}) {
1137         return 0 if $comp =~ m{^/REST/\d+\.\d+/};
1138         my $why = <<EOT;
1139 This login session belongs to a REST client, and cannot be used to
1140 access non-REST interfaces of RT for security reasons.
1141 EOT
1142         my $details = <<EOT;
1143 Please log out and back in to obtain a session for normal browsing.  If
1144 you understand the security implications, disabling RT's CSRF protection
1145 will remove this restriction.
1146 EOT
1147         chomp $details;
1148         HTML::Mason::Commands::Abort( $why, Details => $details );
1149     }
1150
1151     return 0 if IsCompCSRFWhitelisted( $comp, $ARGS );
1152
1153     # if there is no Referer header then assume the worst
1154     return (1,
1155             "your browser did not supply a Referrer header", # loc
1156         ) if !$ENV{HTTP_REFERER};
1157
1158     my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1159     return 0 if $whitelisted;
1160
1161     if ( @$configs > 1 ) {
1162         return (1,
1163                 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1164                 $browser->host_port,
1165                 shift @$configs,
1166                 join(', ', @$configs) );
1167     }
1168
1169     return (1,
1170             "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1171             $browser->host_port,
1172             $configs->[0]);
1173 }
1174
1175 sub ExpandCSRFToken {
1176     my $ARGS = shift;
1177
1178     my $token = delete $ARGS->{CSRF_Token};
1179     return unless $token;
1180
1181     my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1182     return unless $data;
1183     return unless $data->{uri} eq $HTML::Mason::Commands::r->uri;
1184
1185     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1186     return unless $user->ValidateAuthString( $data->{auth}, $token );
1187
1188     %{$ARGS} = %{$data->{args}};
1189
1190     # We explicitly stored file attachments with the request, but not in
1191     # the session yet, as that would itself be an attack.  Put them into
1192     # the session now, so they'll be visible.
1193     if ($data->{attach}) {
1194         my $filename = $data->{attach}{filename};
1195         my $mime     = $data->{attach}{mime};
1196         $HTML::Mason::Commands::session{'Attachments'}{$filename}
1197             = $mime;
1198     }
1199
1200     return 1;
1201 }
1202
1203 sub StoreRequestToken {
1204     my $ARGS = shift;
1205
1206     my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1207     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1208     my $data = {
1209         auth => $user->GenerateAuthString( $token ),
1210         uri => $HTML::Mason::Commands::r->uri,
1211         args => $ARGS,
1212     };
1213     if ($ARGS->{Attach}) {
1214         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1215         my $file_path = delete $ARGS->{'Attach'};
1216         $data->{attach} = {
1217             filename => Encode::decode_utf8("$file_path"),
1218             mime     => $attachment,
1219         };
1220     }
1221
1222     $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1223     $HTML::Mason::Commands::session{'i'}++;
1224     return $token;
1225 }
1226
1227 sub MaybeShowInterstitialCSRFPage {
1228     my $ARGS = shift;
1229
1230     return unless RT->Config->Get('RestrictReferrer');
1231
1232     # Deal with the form token provided by the interstitial, which lets
1233     # browsers which never set referer headers still use RT, if
1234     # painfully.  This blows values into ARGS
1235     return if ExpandCSRFToken($ARGS);
1236
1237     my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1238     return if !$is_csrf;
1239
1240     $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1241
1242     my $token = StoreRequestToken($ARGS);
1243     $HTML::Mason::Commands::m->comp(
1244         '/Elements/CSRF',
1245         OriginalURL => $HTML::Mason::Commands::r->uri,
1246         Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1247         Token => $token,
1248     );
1249     # Calls abort, never gets here
1250 }
1251
1252 package HTML::Mason::Commands;
1253
1254 use vars qw/$r $m %session/;
1255
1256 # {{{ loc
1257
1258 =head2 loc ARRAY
1259
1260 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1261 with whatever it's called with. If there is no $session{'CurrentUser'},
1262 it creates a temporary user, so we have something to get a localisation handle
1263 through
1264
1265 =cut
1266
1267 sub loc {
1268
1269     if ( $session{'CurrentUser'}
1270         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1271     {
1272         return ( $session{'CurrentUser'}->loc(@_) );
1273     } elsif (
1274         my $u = eval {
1275             RT::CurrentUser->new();
1276         }
1277         )
1278     {
1279         return ( $u->loc(@_) );
1280     } else {
1281
1282         # pathetic case -- SystemUser is gone.
1283         return $_[0];
1284     }
1285 }
1286
1287 # }}}
1288
1289 # {{{ loc_fuzzy
1290
1291 =head2 loc_fuzzy STRING
1292
1293 loc_fuzzy is for handling localizations of messages that may already
1294 contain interpolated variables, typically returned from libraries
1295 outside RT's control.  It takes the message string and extracts the
1296 variable array automatically by matching against the candidate entries
1297 inside the lexicon file.
1298
1299 =cut
1300
1301 sub loc_fuzzy {
1302     my $msg = shift;
1303
1304     if ( $session{'CurrentUser'}
1305         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1306     {
1307         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1308     } else {
1309         my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1310         return ( $u->loc_fuzzy($msg) );
1311     }
1312 }
1313
1314 # }}}
1315
1316 # {{{ sub Abort
1317 # Error - calls Error and aborts
1318 sub Abort {
1319     my $why  = shift;
1320     my %args = @_;
1321
1322     if (   $session{'ErrorDocument'}
1323         && $session{'ErrorDocumentType'} )
1324     {
1325         $r->content_type( $session{'ErrorDocumentType'} );
1326         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1327         $m->abort;
1328     } else {
1329         $m->comp( "/Elements/Error", Why => $why, %args );
1330         $m->abort;
1331     }
1332 }
1333
1334 # }}}
1335
1336 # {{{ sub CreateTicket
1337
1338 =head2 CreateTicket ARGS
1339
1340 Create a new ticket, using Mason's %ARGS.  returns @results.
1341
1342 =cut
1343
1344 sub CreateTicket {
1345     my %ARGS = (@_);
1346
1347     my (@Actions);
1348
1349     my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1350
1351     my $Queue = new RT::Queue( $session{'CurrentUser'} );
1352     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1353         Abort('Queue not found');
1354     }
1355
1356     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1357         Abort('You have no permission to create tickets in that queue.');
1358     }
1359
1360     my $due;
1361     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1362         $due = new RT::Date( $session{'CurrentUser'} );
1363         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1364     }
1365     my $starts;
1366     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1367         $starts = new RT::Date( $session{'CurrentUser'} );
1368         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1369     }
1370
1371     my $sigless = RT::Interface::Web::StripContent(
1372         Content        => $ARGS{Content},
1373         ContentType    => $ARGS{ContentType},
1374         StripSignature => 1,
1375         CurrentUser    => $session{'CurrentUser'},
1376     );
1377
1378     my $MIMEObj = MakeMIMEEntity(
1379         Subject => $ARGS{'Subject'},
1380         From    => $ARGS{'From'},
1381         Cc      => $ARGS{'Cc'},
1382         Body    => $sigless,
1383         Type    => $ARGS{'ContentType'},
1384     );
1385
1386     if ( $ARGS{'Attachments'} ) {
1387         my $rv = $MIMEObj->make_multipart;
1388         $RT::Logger->error("Couldn't make multipart message")
1389             if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1390
1391         foreach ( values %{ $ARGS{'Attachments'} } ) {
1392             unless ($_) {
1393                 $RT::Logger->error("Couldn't add empty attachemnt");
1394                 next;
1395             }
1396             $MIMEObj->add_part($_);
1397         }
1398     }
1399
1400     foreach my $argument (qw(Encrypt Sign)) {
1401         $MIMEObj->head->add(
1402             "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1403         ) if defined $ARGS{$argument};
1404     }
1405
1406     my %create_args = (
1407         Type => $ARGS{'Type'} || 'ticket',
1408         Queue => $ARGS{'Queue'},
1409         Owner => $ARGS{'Owner'},
1410
1411         # note: name change
1412         Requestor       => $ARGS{'Requestors'},
1413         Cc              => $ARGS{'Cc'},
1414         AdminCc         => $ARGS{'AdminCc'},
1415         InitialPriority => $ARGS{'InitialPriority'},
1416         FinalPriority   => $ARGS{'FinalPriority'},
1417         TimeLeft        => $ARGS{'TimeLeft'},
1418         TimeEstimated   => $ARGS{'TimeEstimated'},
1419         TimeWorked      => $ARGS{'TimeWorked'},
1420         Subject         => $ARGS{'Subject'},
1421         Status          => $ARGS{'Status'},
1422         Due             => $due ? $due->ISO : undef,
1423         Starts          => $starts ? $starts->ISO : undef,
1424         MIMEObj         => $MIMEObj
1425     );
1426
1427     my @temp_squelch;
1428     foreach my $type (qw(Requestor Cc AdminCc)) {
1429         push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1430             if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1431
1432     }
1433
1434     if (@temp_squelch) {
1435         require RT::Action::SendEmail;
1436         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1437     }
1438
1439     if ( $ARGS{'AttachTickets'} ) {
1440         require RT::Action::SendEmail;
1441         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1442             ref $ARGS{'AttachTickets'}
1443             ? @{ $ARGS{'AttachTickets'} }
1444             : ( $ARGS{'AttachTickets'} ) );
1445     }
1446
1447     foreach my $arg ( keys %ARGS ) {
1448         next if $arg =~ /-(?:Magic|Category)$/;
1449
1450         if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1451             $create_args{$arg} = $ARGS{$arg};
1452         }
1453
1454         # Object-RT::Ticket--CustomField-3-Values
1455         elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1456             my $cfid = $1;
1457
1458             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1459             $cf->SetContextObject( $Queue );
1460             $cf->Load($cfid);
1461             unless ( $cf->id ) {
1462                 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1463                 next;
1464             }
1465
1466             if ( $arg =~ /-Upload$/ ) {
1467                 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1468                 next;
1469             }
1470
1471             my $type = $cf->Type;
1472
1473             my @values = ();
1474             if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1475                 @values = @{ $ARGS{$arg} };
1476             } elsif ( $type =~ /text/i ) {
1477                 @values = ( $ARGS{$arg} );
1478             } else {
1479                 no warnings 'uninitialized';
1480                 @values = split /\r*\n/, $ARGS{$arg};
1481             }
1482             @values = grep length, map {
1483                 s/\r+\n/\n/g;
1484                 s/^\s+//;
1485                 s/\s+$//;
1486                 $_;
1487                 }
1488                 grep defined, @values;
1489
1490             $create_args{"CustomField-$cfid"} = \@values;
1491         }
1492     }
1493
1494     # turn new link lists into arrays, and pass in the proper arguments
1495     my %map = (
1496         'new-DependsOn' => 'DependsOn',
1497         'DependsOn-new' => 'DependedOnBy',
1498         'new-MemberOf'  => 'Parents',
1499         'MemberOf-new'  => 'Children',
1500         'new-RefersTo'  => 'RefersTo',
1501         'RefersTo-new'  => 'ReferredToBy',
1502     );
1503     foreach my $key ( keys %map ) {
1504         next unless $ARGS{$key};
1505         $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1506
1507     }
1508
1509     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1510     unless ($id) {
1511         Abort($ErrMsg);
1512     }
1513
1514     push( @Actions, split( "\n", $ErrMsg ) );
1515     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1516         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1517     }
1518     return ( $Ticket, @Actions );
1519
1520 }
1521
1522 # }}}
1523
1524 # {{{ sub LoadTicket - loads a ticket
1525
1526 =head2  LoadTicket id
1527
1528 Takes a ticket id as its only variable. if it's handed an array, it takes
1529 the first value.
1530
1531 Returns an RT::Ticket object as the current user.
1532
1533 =cut
1534
1535 sub LoadTicket {
1536     my $id = shift;
1537
1538     if ( ref($id) eq "ARRAY" ) {
1539         $id = $id->[0];
1540     }
1541
1542     unless ($id) {
1543         Abort("No ticket specified");
1544     }
1545
1546     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1547     $Ticket->Load($id);
1548     unless ( $Ticket->id ) {
1549         Abort("Could not load ticket $id");
1550     }
1551     return $Ticket;
1552 }
1553
1554 # }}}
1555
1556 # {{{ sub ProcessUpdateMessage
1557
1558 =head2 ProcessUpdateMessage
1559
1560 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1561
1562 Don't write message if it only contains current user's signature and
1563 SkipSignatureOnly argument is true. Function anyway adds attachments
1564 and updates time worked field even if skips message. The default value
1565 is true.
1566
1567 =cut
1568
1569 sub ProcessUpdateMessage {
1570
1571     my %args = (
1572         ARGSRef           => undef,
1573         TicketObj         => undef,
1574         SkipSignatureOnly => 1,
1575         @_
1576     );
1577
1578     if ( $args{ARGSRef}->{'UpdateAttachments'}
1579         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1580     {
1581         delete $args{ARGSRef}->{'UpdateAttachments'};
1582     }
1583
1584     # Strip the signature
1585     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1586         Content        => $args{ARGSRef}->{UpdateContent},
1587         ContentType    => $args{ARGSRef}->{UpdateContentType},
1588         StripSignature => $args{SkipSignatureOnly},
1589         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1590     );
1591
1592     # If, after stripping the signature, we have no message, move the
1593     # UpdateTimeWorked into adjusted TimeWorked, so that a later
1594     # ProcessBasics can deal -- then bail out.
1595     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1596         and not length $args{ARGSRef}->{'UpdateContent'} )
1597     {
1598         if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1599             $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1600         }
1601         return;
1602     }
1603
1604     if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1605         $args{ARGSRef}->{'UpdateSubject'} = undef;
1606     }
1607
1608     my $Message = MakeMIMEEntity(
1609         Subject => $args{ARGSRef}->{'UpdateSubject'},
1610         Body    => $args{ARGSRef}->{'UpdateContent'},
1611         Type    => $args{ARGSRef}->{'UpdateContentType'},
1612     );
1613
1614     $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1615         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1616     ) );
1617     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1618     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1619         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1620     } else {
1621         $old_txn = $args{TicketObj}->Transactions->First();
1622     }
1623
1624     if ( my $msg = $old_txn->Message->First ) {
1625         RT::Interface::Email::SetInReplyTo(
1626             Message   => $Message,
1627             InReplyTo => $msg
1628         );
1629     }
1630
1631     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1632         $Message->make_multipart;
1633         $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1634     }
1635
1636     if ( $args{ARGSRef}->{'AttachTickets'} ) {
1637         require RT::Action::SendEmail;
1638         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1639             ref $args{ARGSRef}->{'AttachTickets'}
1640             ? @{ $args{ARGSRef}->{'AttachTickets'} }
1641             : ( $args{ARGSRef}->{'AttachTickets'} ) );
1642     }
1643
1644     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1645     my $cc  = $args{ARGSRef}->{'UpdateCc'};
1646
1647     my %txn_customfields;
1648
1649     foreach my $key ( keys %{ $args{ARGSRef} } ) {
1650       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1651         $txn_customfields{$key} = $args{ARGSRef}->{$key};
1652       }
1653     }
1654
1655     my %message_args = (
1656         CcMessageTo  => $cc,
1657         BccMessageTo => $bcc,
1658         Sign         => $args{ARGSRef}->{'Sign'},
1659         Encrypt      => $args{ARGSRef}->{'Encrypt'},
1660         MIMEObj      => $Message,
1661         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
1662         CustomFields => \%txn_customfields,
1663     );
1664
1665     my @temp_squelch;
1666     foreach my $type (qw(Cc AdminCc)) {
1667         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1668             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1669             push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1670             push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1671         }
1672     }
1673     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1674             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1675             push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1676     }
1677
1678     if (@temp_squelch) {
1679         require RT::Action::SendEmail;
1680         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1681     }
1682
1683     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1684         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1685             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1686
1687             my $var   = ucfirst($1) . 'MessageTo';
1688             my $value = $2;
1689             if ( $message_args{$var} ) {
1690                 $message_args{$var} .= ", $value";
1691             } else {
1692                 $message_args{$var} = $value;
1693             }
1694         }
1695     }
1696
1697     my @results;
1698     # Do the update via the appropriate Ticket method
1699     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1700         my ( $Transaction, $Description, $Object ) =
1701             $args{TicketObj}->Comment(%message_args);
1702         push( @results, $Description );
1703         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1704     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1705         my ( $Transaction, $Description, $Object ) =
1706             $args{TicketObj}->Correspond(%message_args);
1707         push( @results, $Description );
1708         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1709     } else {
1710         push( @results,
1711             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1712     }
1713     return @results;
1714 }
1715
1716 # }}}
1717
1718 # {{{ sub MakeMIMEEntity
1719
1720 =head2 MakeMIMEEntity PARAMHASH
1721
1722 Takes a paramhash Subject, Body and AttachmentFieldName.
1723
1724 Also takes Form, Cc and Type as optional paramhash keys.
1725
1726   Returns a MIME::Entity.
1727
1728 =cut
1729
1730 sub MakeMIMEEntity {
1731
1732     #TODO document what else this takes.
1733     my %args = (
1734         Subject             => undef,
1735         From                => undef,
1736         Cc                  => undef,
1737         Body                => undef,
1738         AttachmentFieldName => undef,
1739         Type                => undef,
1740         @_,
1741     );
1742     my $Message = MIME::Entity->build(
1743         Type    => 'multipart/mixed',
1744         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1745             grep defined $args{$_}, qw(Subject From Cc)
1746     );
1747
1748     if ( defined $args{'Body'} && length $args{'Body'} ) {
1749
1750         # Make the update content have no 'weird' newlines in it
1751         $args{'Body'} =~ s/\r\n/\n/gs;
1752
1753         $Message->attach(
1754             Type    => $args{'Type'} || 'text/plain',
1755             Charset => 'UTF-8',
1756             Data    => $args{'Body'},
1757         );
1758     }
1759
1760     if ( $args{'AttachmentFieldName'} ) {
1761
1762         my $cgi_object = $m->cgi_object;
1763
1764         if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1765
1766             my ( @content, $buffer );
1767             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1768                 push @content, $buffer;
1769             }
1770
1771             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1772
1773             # Prefer the cached name first over CGI.pm stringification.
1774             my $filename = $RT::Mason::CGI::Filename;
1775             $filename = "$filehandle" unless defined $filename;
1776             $filename = Encode::encode_utf8( $filename );
1777             $filename =~ s{^.*[\\/]}{};
1778
1779             $Message->attach(
1780                 Type     => $uploadinfo->{'Content-Type'},
1781                 Filename => $filename,
1782                 Data     => \@content,
1783             );
1784             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1785                 $Message->head->set( 'Subject' => $filename );
1786             }
1787         }
1788     }
1789
1790     $Message->make_singlepart;
1791
1792     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1793
1794     return ($Message);
1795
1796 }
1797
1798 # }}}
1799
1800 # {{{ sub ParseDateToISO
1801
1802 =head2 ParseDateToISO
1803
1804 Takes a date in an arbitrary format.
1805 Returns an ISO date and time in GMT
1806
1807 =cut
1808
1809 sub ParseDateToISO {
1810     my $date = shift;
1811
1812     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1813     $date_obj->Set(
1814         Format => 'unknown',
1815         Value  => $date
1816     );
1817     return ( $date_obj->ISO );
1818 }
1819
1820 # }}}
1821
1822 # {{{ sub ProcessACLChanges
1823
1824 sub ProcessACLChanges {
1825     my $ARGSref = shift;
1826
1827     my @results;
1828
1829     foreach my $arg ( keys %$ARGSref ) {
1830         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1831
1832         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1833
1834         my @rights;
1835         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1836             @rights = @{ $ARGSref->{$arg} };
1837         } else {
1838             @rights = $ARGSref->{$arg};
1839         }
1840         @rights = grep $_, @rights;
1841         next unless @rights;
1842
1843         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1844         $principal->Load($principal_id);
1845
1846         my $obj;
1847         if ( $object_type eq 'RT::System' ) {
1848             $obj = $RT::System;
1849         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1850             $obj = $object_type->new( $session{'CurrentUser'} );
1851             $obj->Load($object_id);
1852             unless ( $obj->id ) {
1853                 $RT::Logger->error("couldn't load $object_type #$object_id");
1854                 next;
1855             }
1856         } else {
1857             $RT::Logger->error("object type '$object_type' is incorrect");
1858             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1859             next;
1860         }
1861
1862         foreach my $right (@rights) {
1863             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1864             push( @results, $msg );
1865         }
1866     }
1867
1868     return (@results);
1869 }
1870
1871 # }}}
1872
1873 # {{{ sub UpdateRecordObj
1874
1875 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1876
1877 @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.
1878
1879 Returns an array of success/failure messages
1880
1881 =cut
1882
1883 sub UpdateRecordObject {
1884     my %args = (
1885         ARGSRef         => undef,
1886         AttributesRef   => undef,
1887         Object          => undef,
1888         AttributePrefix => undef,
1889         @_
1890     );
1891
1892     my $Object  = $args{'Object'};
1893     my @results = $Object->Update(
1894         AttributesRef   => $args{'AttributesRef'},
1895         ARGSRef         => $args{'ARGSRef'},
1896         AttributePrefix => $args{'AttributePrefix'},
1897     );
1898
1899     return (@results);
1900 }
1901
1902 # }}}
1903
1904 # {{{ Sub ProcessCustomFieldUpdates
1905
1906 sub ProcessCustomFieldUpdates {
1907     my %args = (
1908         CustomFieldObj => undef,
1909         ARGSRef        => undef,
1910         @_
1911     );
1912
1913     my $Object  = $args{'CustomFieldObj'};
1914     my $ARGSRef = $args{'ARGSRef'};
1915
1916     my @attribs = qw(Name Type Description Queue SortOrder);
1917     my @results = UpdateRecordObject(
1918         AttributesRef => \@attribs,
1919         Object        => $Object,
1920         ARGSRef       => $ARGSRef
1921     );
1922
1923     my $prefix = "CustomField-" . $Object->Id;
1924     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1925         my ( $addval, $addmsg ) = $Object->AddValue(
1926             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1927             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1928             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1929         );
1930         push( @results, $addmsg );
1931     }
1932
1933     my @delete_values
1934         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1935         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1936         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1937
1938     foreach my $id (@delete_values) {
1939         next unless defined $id;
1940         my ( $err, $msg ) = $Object->DeleteValue($id);
1941         push( @results, $msg );
1942     }
1943
1944     my $vals = $Object->Values();
1945     while ( my $cfv = $vals->Next() ) {
1946         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1947             if ( $cfv->SortOrder != $so ) {
1948                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1949                 push( @results, $msg );
1950             }
1951         }
1952     }
1953
1954     return (@results);
1955 }
1956
1957 # }}}
1958
1959 # {{{ sub ProcessTicketBasics
1960
1961 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1962
1963 Returns an array of results messages.
1964
1965 =cut
1966
1967 sub ProcessTicketBasics {
1968
1969     my %args = (
1970         TicketObj => undef,
1971         ARGSRef   => undef,
1972         @_
1973     );
1974
1975     my $TicketObj = $args{'TicketObj'};
1976     my $ARGSRef   = $args{'ARGSRef'};
1977
1978     # {{{ Set basic fields
1979     my @attribs = qw(
1980         Subject
1981         FinalPriority
1982         Priority
1983         TimeEstimated
1984         TimeWorked
1985         TimeLeft
1986         Type
1987         Status
1988         Queue
1989     );
1990
1991     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1992         my $tempqueue = RT::Queue->new($RT::SystemUser);
1993         $tempqueue->Load( $ARGSRef->{'Queue'} );
1994         if ( $tempqueue->id ) {
1995             $ARGSRef->{'Queue'} = $tempqueue->id;
1996         }
1997     }
1998
1999     # Status isn't a field that can be set to a null value.
2000     # RT core complains if you try
2001     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2002
2003     my @results = UpdateRecordObject(
2004         AttributesRef => \@attribs,
2005         Object        => $TicketObj,
2006         ARGSRef       => $ARGSRef,
2007     );
2008
2009     # We special case owner changing, so we can use ForceOwnerChange
2010     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2011         my ($ChownType);
2012         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2013             $ChownType = "Force";
2014         } else {
2015             $ChownType = "Give";
2016         }
2017
2018         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2019         push( @results, $msg );
2020     }
2021
2022     # }}}
2023
2024     return (@results);
2025 }
2026
2027 # }}}
2028
2029 sub ProcessTicketCustomFieldUpdates {
2030     my %args = @_;
2031     $args{'Object'} = delete $args{'TicketObj'};
2032     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2033
2034     # Build up a list of objects that we want to work with
2035     my %custom_fields_to_mod;
2036     foreach my $arg ( keys %$ARGSRef ) {
2037         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2038             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2039         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2040             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2041         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2042             delete $ARGSRef->{$arg}; # don't try to update transaction fields
2043         }
2044     }
2045
2046     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2047 }
2048
2049 sub ProcessObjectCustomFieldUpdates {
2050     my %args    = @_;
2051     my $ARGSRef = $args{'ARGSRef'};
2052     my @results;
2053
2054     # Build up a list of objects that we want to work with
2055     my %custom_fields_to_mod;
2056     foreach my $arg ( keys %$ARGSRef ) {
2057
2058         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2059         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2060
2061         # For each of those objects, find out what custom fields we want to work with.
2062         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2063     }
2064
2065     # For each of those objects
2066     foreach my $class ( keys %custom_fields_to_mod ) {
2067         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2068             my $Object = $args{'Object'};
2069             $Object = $class->new( $session{'CurrentUser'} )
2070                 unless $Object && ref $Object eq $class;
2071
2072             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2073             unless ( $Object->id ) {
2074                 $RT::Logger->warning("Couldn't load object $class #$id");
2075                 next;
2076             }
2077
2078             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2079                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2080                 $CustomFieldObj->SetContextObject($Object);
2081                 $CustomFieldObj->LoadById($cf);
2082                 unless ( $CustomFieldObj->id ) {
2083                     $RT::Logger->warning("Couldn't load custom field #$cf");
2084                     next;
2085                 }
2086                 push @results,
2087                     _ProcessObjectCustomFieldUpdates(
2088                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2089                     Object      => $Object,
2090                     CustomField => $CustomFieldObj,
2091                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2092                     );
2093             }
2094         }
2095     }
2096     return @results;
2097 }
2098
2099 sub _ProcessObjectCustomFieldUpdates {
2100     my %args    = @_;
2101     my $cf      = $args{'CustomField'};
2102     my $cf_type = $cf->Type;
2103
2104     # Remove blank Values since the magic field will take care of this. Sometimes
2105     # the browser gives you a blank value which causes CFs to be processed twice
2106     if (   defined $args{'ARGS'}->{'Values'}
2107         && !length $args{'ARGS'}->{'Values'}
2108         && $args{'ARGS'}->{'Values-Magic'} )
2109     {
2110         delete $args{'ARGS'}->{'Values'};
2111     }
2112
2113     my @results;
2114     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2115
2116         # skip category argument
2117         next if $arg eq 'Category';
2118
2119         # and TimeUnits
2120         next if $arg eq 'Value-TimeUnits';
2121
2122         # since http won't pass in a form element with a null value, we need
2123         # to fake it
2124         if ( $arg eq 'Values-Magic' ) {
2125
2126             # We don't care about the magic, if there's really a values element;
2127             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2128             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2129
2130             # "Empty" values does not mean anything for Image and Binary fields
2131             next if $cf_type =~ /^(?:Image|Binary)$/;
2132
2133             $arg = 'Values';
2134             $args{'ARGS'}->{'Values'} = undef;
2135         }
2136
2137         my @values = ();
2138         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2139             @values = @{ $args{'ARGS'}->{$arg} };
2140         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2141             @values = ( $args{'ARGS'}->{$arg} );
2142         } else {
2143             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2144                 if defined $args{'ARGS'}->{$arg};
2145         }
2146         @values = grep length, map {
2147             s/\r+\n/\n/g;
2148             s/^\s+//;
2149             s/\s+$//;
2150             $_;
2151             }
2152             grep defined, @values;
2153
2154         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2155             foreach my $value (@values) {
2156                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2157                     Field => $cf->id,
2158                     Value => $value
2159                 );
2160                 push( @results, $msg );
2161             }
2162         } elsif ( $arg eq 'Upload' ) {
2163             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2164             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2165             push( @results, $msg );
2166         } elsif ( $arg eq 'DeleteValues' ) {
2167             foreach my $value (@values) {
2168                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2169                     Field => $cf,
2170                     Value => $value,
2171                 );
2172                 push( @results, $msg );
2173             }
2174         } elsif ( $arg eq 'DeleteValueIds' ) {
2175             foreach my $value (@values) {
2176                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2177                     Field   => $cf,
2178                     ValueId => $value,
2179                 );
2180                 push( @results, $msg );
2181             }
2182         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2183             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2184
2185             my %values_hash;
2186             foreach my $value (@values) {
2187                 if ( my $entry = $cf_values->HasEntry($value) ) {
2188                     $values_hash{ $entry->id } = 1;
2189                     next;
2190                 }
2191
2192                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2193                     Field => $cf,
2194                     Value => $value
2195                 );
2196                 push( @results, $msg );
2197                 $values_hash{$val} = 1 if $val;
2198             }
2199
2200             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2201             return @results if ( $cf->Type eq 'Date' && ! @values );
2202
2203             $cf_values->RedoSearch;
2204             while ( my $cf_value = $cf_values->Next ) {
2205                 next if $values_hash{ $cf_value->id };
2206
2207                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2208                     Field   => $cf,
2209                     ValueId => $cf_value->id
2210                 );
2211                 push( @results, $msg );
2212             }
2213         } elsif ( $arg eq 'Values' ) {
2214             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2215
2216             # keep everything up to the point of difference, delete the rest
2217             my $delete_flag;
2218             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2219                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2220                     shift @values;
2221                     next;
2222                 }
2223
2224                 $delete_flag ||= 1;
2225                 $old_cf->Delete;
2226             }
2227
2228             # now add/replace extra things, if any
2229             foreach my $value (@values) {
2230                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2231                     Field => $cf,
2232                     Value => $value
2233                 );
2234                 push( @results, $msg );
2235             }
2236         } else {
2237             push(
2238                 @results,
2239                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2240                     $cf->Name, ref $args{'Object'},
2241                     $args{'Object'}->id
2242                 )
2243             );
2244         }
2245     }
2246     return @results;
2247 }
2248
2249 # {{{ sub ProcessTicketWatchers
2250
2251 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2252
2253 Returns an array of results messages.
2254
2255 =cut
2256
2257 sub ProcessTicketWatchers {
2258     my %args = (
2259         TicketObj => undef,
2260         ARGSRef   => undef,
2261         @_
2262     );
2263     my (@results);
2264
2265     my $Ticket  = $args{'TicketObj'};
2266     my $ARGSRef = $args{'ARGSRef'};
2267
2268     # Munge watchers
2269
2270     foreach my $key ( keys %$ARGSRef ) {
2271
2272         # Delete deletable watchers
2273         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2274             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2275                 PrincipalId => $2,
2276                 Type        => $1
2277             );
2278             push @results, $msg;
2279         }
2280
2281         # Delete watchers in the simple style demanded by the bulk manipulator
2282         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2283             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2284                 Email => $ARGSRef->{$key},
2285                 Type  => $1
2286             );
2287             push @results, $msg;
2288         }
2289
2290         # Add new wathchers by email address
2291         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2292             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2293         {
2294
2295             #They're in this order because otherwise $1 gets clobbered :/
2296             my ( $code, $msg ) = $Ticket->AddWatcher(
2297                 Type  => $ARGSRef->{$key},
2298                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2299             );
2300             push @results, $msg;
2301         }
2302
2303         #Add requestors in the simple style demanded by the bulk manipulator
2304         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2305             my ( $code, $msg ) = $Ticket->AddWatcher(
2306                 Type  => $1,
2307                 Email => $ARGSRef->{$key}
2308             );
2309             push @results, $msg;
2310         }
2311
2312         # Add new  watchers by owner
2313         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2314             my $principal_id = $1;
2315             my $form         = $ARGSRef->{$key};
2316             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2317                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2318
2319                 my ( $code, $msg ) = $Ticket->AddWatcher(
2320                     Type        => $value,
2321                     PrincipalId => $principal_id
2322                 );
2323                 push @results, $msg;
2324             }
2325         }
2326
2327     }
2328     return (@results);
2329 }
2330
2331 # }}}
2332
2333 # {{{ sub ProcessTicketDates
2334
2335 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2336
2337 Returns an array of results messages.
2338
2339 =cut
2340
2341 sub ProcessTicketDates {
2342     my %args = (
2343         TicketObj => undef,
2344         ARGSRef   => undef,
2345         @_
2346     );
2347
2348     my $Ticket  = $args{'TicketObj'};
2349     my $ARGSRef = $args{'ARGSRef'};
2350
2351     my (@results);
2352
2353     # {{{ Set date fields
2354     my @date_fields = qw(
2355         Told
2356         Resolved
2357         Starts
2358         Started
2359         Due
2360     );
2361
2362     #Run through each field in this list. update the value if apropriate
2363     foreach my $field (@date_fields) {
2364         next unless exists $ARGSRef->{ $field . '_Date' };
2365         next if $ARGSRef->{ $field . '_Date' } eq '';
2366
2367         my ( $code, $msg );
2368
2369         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2370         $DateObj->Set(
2371             Format => 'unknown',
2372             Value  => $ARGSRef->{ $field . '_Date' }
2373         );
2374
2375         my $obj = $field . "Obj";
2376         if (    ( defined $DateObj->Unix )
2377             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2378         {
2379             my $method = "Set$field";
2380             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2381             push @results, "$msg";
2382         }
2383     }
2384
2385     # }}}
2386     return (@results);
2387 }
2388
2389 # }}}
2390
2391 # {{{ sub ProcessTicketLinks
2392
2393 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2394
2395 Returns an array of results messages.
2396
2397 =cut
2398
2399 sub ProcessTicketLinks {
2400     my %args = (
2401         TicketObj => undef,
2402         ARGSRef   => undef,
2403         @_
2404     );
2405
2406     my $Ticket  = $args{'TicketObj'};
2407     my $ARGSRef = $args{'ARGSRef'};
2408
2409     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2410
2411     #Merge if we need to
2412     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2413         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2414         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2415         push @results, $msg;
2416     }
2417
2418     return (@results);
2419 }
2420
2421 # }}}
2422
2423 sub ProcessRecordLinks {
2424     my %args = (
2425         RecordObj => undef,
2426         ARGSRef   => undef,
2427         @_
2428     );
2429
2430     my $Record  = $args{'RecordObj'};
2431     my $ARGSRef = $args{'ARGSRef'};
2432
2433     my (@results);
2434
2435     # Delete links that are gone gone gone.
2436     foreach my $arg ( keys %$ARGSRef ) {
2437         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2438             my $base   = $1;
2439             my $type   = $2;
2440             my $target = $3;
2441
2442             my ( $val, $msg ) = $Record->DeleteLink(
2443                 Base   => $base,
2444                 Type   => $type,
2445                 Target => $target
2446             );
2447
2448             push @results, $msg;
2449
2450         }
2451
2452     }
2453
2454     my @linktypes = qw( DependsOn MemberOf RefersTo );
2455
2456     foreach my $linktype (@linktypes) {
2457         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2458             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2459                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2460
2461             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2462                 next unless $luri;
2463                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2464                 my ( $val, $msg ) = $Record->AddLink(
2465                     Target => $luri,
2466                     Type   => $linktype
2467                 );
2468                 push @results, $msg;
2469             }
2470         }
2471         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2472             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2473                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2474
2475             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2476                 next unless $luri;
2477                 my ( $val, $msg ) = $Record->AddLink(
2478                     Base => $luri,
2479                     Type => $linktype
2480                 );
2481
2482                 push @results, $msg;
2483             }
2484         }
2485     }
2486
2487     return (@results);
2488 }
2489
2490 =head2 _UploadedFile ( $arg );
2491
2492 Takes a CGI parameter name; if a file is uploaded under that name,
2493 return a hash reference suitable for AddCustomFieldValue's use:
2494 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2495
2496 Returns C<undef> if no files were uploaded in the C<$arg> field.
2497
2498 =cut
2499
2500 sub _UploadedFile {
2501     my $arg         = shift;
2502     my $cgi_object  = $m->cgi_object;
2503     my $fh          = $cgi_object->upload($arg) or return undef;
2504     my $upload_info = $cgi_object->uploadInfo($fh);
2505
2506     my $filename = "$fh";
2507     $filename =~ s#^.*[\\/]##;
2508     binmode($fh);
2509
2510     return {
2511         Value        => $filename,
2512         LargeContent => do { local $/; scalar <$fh> },
2513         ContentType  => $upload_info->{'Content-Type'},
2514     };
2515 }
2516
2517 sub GetColumnMapEntry {
2518     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2519
2520     # deal with the simplest thing first
2521     if ( $args{'Map'}{ $args{'Name'} } ) {
2522         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2523     }
2524
2525     # complex things
2526     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2527         return undef unless $args{'Map'}->{$mainkey};
2528         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2529             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2530
2531         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2532     }
2533     return undef;
2534 }
2535
2536 sub ProcessColumnMapValue {
2537     my $value = shift;
2538     my %args = ( Arguments => [], Escape => 1, @_ );
2539
2540     if ( ref $value ) {
2541         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2542             my @tmp = $value->( @{ $args{'Arguments'} } );
2543             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2544         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2545             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2546         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2547             return $$value;
2548         }
2549     }
2550
2551     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2552     return $value;
2553 }
2554
2555 =head2 _load_container_object ( $type, $id );
2556
2557 Instantiate container object for saving searches.
2558
2559 =cut
2560
2561 sub _load_container_object {
2562     my ( $obj_type, $obj_id ) = @_;
2563     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2564 }
2565
2566 =head2 _parse_saved_search ( $arg );
2567
2568 Given a serialization string for saved search, and returns the
2569 container object and the search id.
2570
2571 =cut
2572
2573 sub _parse_saved_search {
2574     my $spec = shift;
2575     return unless $spec;
2576     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2577         return;
2578     }
2579     my $obj_type  = $1;
2580     my $obj_id    = $2;
2581     my $search_id = $3;
2582
2583     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2584 }
2585
2586 =head2 ScrubHTML content
2587
2588 Removes unsafe and undesired HTML from the passed content
2589
2590 =cut
2591
2592 my $SCRUBBER;
2593 sub ScrubHTML {
2594     my $Content = shift;
2595     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2596
2597     $Content = '' if !defined($Content);
2598     return $SCRUBBER->scrub($Content);
2599 }
2600
2601 =head2 _NewScrubber
2602
2603 Returns a new L<HTML::Scrubber> object.
2604
2605 If you need to be more lax about what HTML tags and attributes are allowed,
2606 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2607 following:
2608
2609     package HTML::Mason::Commands;
2610     # Let tables through
2611     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2612     1;
2613
2614 =cut
2615
2616 our @SCRUBBER_ALLOWED_TAGS = qw(
2617     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2618     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2619 );
2620
2621 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2622     # Match http, ftp and relative urls
2623     # XXX: we also scrub format strings with this module then allow simple config options
2624     href   => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2625     face   => 1,
2626     size   => 1,
2627     target => 1,
2628     style  => qr{
2629         ^(?:\s*
2630             (?:(?:background-)?color: \s*
2631                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
2632                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
2633                        [\w\-]+                                  # green, light-blue, etc.
2634                        )                            |
2635                text-align: \s* \w+                  |
2636                font-size: \s* [\w.\-]+              |
2637                font-family: \s* [\w\s"',.\-]+       |
2638                font-weight: \s* [\w\-]+             |
2639
2640                # MS Office styles, which are probably fine.  If we don't, then any
2641                # associated styles in the same attribute get stripped.
2642                mso-[\w\-]+?: \s* [\w\s"',.\-]+
2643             )\s* ;? \s*)
2644          +$ # one or more of these allowed properties from here 'till sunset
2645     }ix,
2646 );
2647
2648 our %SCRUBBER_RULES = ();
2649
2650 sub _NewScrubber {
2651     require HTML::Scrubber;
2652     my $scrubber = HTML::Scrubber->new();
2653     $scrubber->default(
2654         0,
2655         {
2656             %SCRUBBER_ALLOWED_ATTRIBUTES,
2657             '*' => 0, # require attributes be explicitly allowed
2658         },
2659     );
2660     $scrubber->deny(qw[*]);
2661     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2662     $scrubber->rules(%SCRUBBER_RULES);
2663
2664     # Scrubbing comments is vital since IE conditional comments can contain
2665     # arbitrary HTML and we'd pass it right on through.
2666     $scrubber->comment(0);
2667
2668     return $scrubber;
2669 }
2670
2671 package RT::Interface::Web;
2672 RT::Base->_ImportOverlays();
2673
2674 1;