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
1040 sub IsCompCSRFWhitelisted {
1041     my $comp = shift;
1042     my $ARGS = shift;
1043
1044     return 1 if $is_whitelisted_component{$comp};
1045
1046     my %args = %{ $ARGS };
1047
1048     # If the user specifies a *correct* user and pass then they are
1049     # golden.  This acts on the presumption that external forms may
1050     # hardcode a username and password -- if a malicious attacker knew
1051     # both already, CSRF is the least of your problems.
1052     my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1053     if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1054         my $user_obj = RT::CurrentUser->new();
1055         $user_obj->Load($args{user});
1056         return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1057
1058         delete $args{user};
1059         delete $args{pass};
1060     }
1061
1062     # Eliminate arguments that do not indicate an effectful request.
1063     # For example, "id" is acceptable because that is how RT retrieves a
1064     # record.
1065     delete $args{id};
1066
1067     # If they have a valid results= from MaybeRedirectForResults, that's
1068     # also fine.
1069     delete $args{results} if $args{results}
1070         and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1071
1072     # The homepage refresh, which uses the Refresh header, doesn't send
1073     # a referer in most browsers; whitelist the one parameter it reloads
1074     # with, HomeRefreshInterval, which is safe
1075     delete $args{HomeRefreshInterval};
1076
1077     # If there are no arguments, then it's likely to be an idempotent
1078     # request, which are not susceptible to CSRF
1079     return 1 if !%args;
1080
1081     return 0;
1082 }
1083
1084 sub IsRefererCSRFWhitelisted {
1085     my $referer = _NormalizeHost(shift);
1086     my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1087     $base_url = $base_url->host_port;
1088
1089     my $configs;
1090     for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1091         push @$configs,$config;
1092         return 1 if $referer->host_port eq $config;
1093     }
1094
1095     return (0,$referer,$configs);
1096 }
1097
1098 =head3 _NormalizeHost
1099
1100 Takes a URI and creates a URI object that's been normalized
1101 to handle common problems such as localhost vs 127.0.0.1
1102
1103 =cut
1104
1105 sub _NormalizeHost {
1106
1107     my $uri= URI->new(shift);
1108     $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1109
1110     return $uri;
1111
1112 }
1113
1114 sub IsPossibleCSRF {
1115     my $ARGS = shift;
1116
1117     # If first request on this session is to a REST endpoint, then
1118     # whitelist the REST endpoints -- and explicitly deny non-REST
1119     # endpoints.  We do this because using a REST cookie in a browser
1120     # would open the user to CSRF attacks to the REST endpoints.
1121     my $comp = $HTML::Mason::Commands::m->request_comp->path;
1122     $HTML::Mason::Commands::session{'REST'} = $comp =~ m{^/REST/\d+\.\d+/}
1123         unless defined $HTML::Mason::Commands::session{'REST'};
1124
1125     if ($HTML::Mason::Commands::session{'REST'}) {
1126         return 0 if $comp =~ m{^/REST/\d+\.\d+/};
1127         my $why = <<EOT;
1128 This login session belongs to a REST client, and cannot be used to
1129 access non-REST interfaces of RT for security reasons.
1130 EOT
1131         my $details = <<EOT;
1132 Please log out and back in to obtain a session for normal browsing.  If
1133 you understand the security implications, disabling RT's CSRF protection
1134 will remove this restriction.
1135 EOT
1136         chomp $details;
1137         HTML::Mason::Commands::Abort( $why, Details => $details );
1138     }
1139
1140     return 0 if IsCompCSRFWhitelisted( $comp, $ARGS );
1141
1142     # if there is no Referer header then assume the worst
1143     return (1,
1144             "your browser did not supply a Referrer header", # loc
1145         ) if !$ENV{HTTP_REFERER};
1146
1147     my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1148     return 0 if $whitelisted;
1149
1150     if ( @$configs > 1 ) {
1151         return (1,
1152                 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1153                 $browser->host_port,
1154                 shift @$configs,
1155                 join(', ', @$configs) );
1156     }
1157
1158     return (1,
1159             "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1160             $browser->host_port,
1161             $configs->[0]);
1162 }
1163
1164 sub ExpandCSRFToken {
1165     my $ARGS = shift;
1166
1167     my $token = delete $ARGS->{CSRF_Token};
1168     return unless $token;
1169
1170     my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1171     return unless $data;
1172     return unless $data->{uri} eq $HTML::Mason::Commands::r->uri;
1173
1174     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1175     return unless $user->ValidateAuthString( $data->{auth}, $token );
1176
1177     %{$ARGS} = %{$data->{args}};
1178
1179     # We explicitly stored file attachments with the request, but not in
1180     # the session yet, as that would itself be an attack.  Put them into
1181     # the session now, so they'll be visible.
1182     if ($data->{attach}) {
1183         my $filename = $data->{attach}{filename};
1184         my $mime     = $data->{attach}{mime};
1185         $HTML::Mason::Commands::session{'Attachments'}{$filename}
1186             = $mime;
1187     }
1188
1189     return 1;
1190 }
1191
1192 sub StoreRequestToken {
1193     my $ARGS = shift;
1194
1195     my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1196     my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1197     my $data = {
1198         auth => $user->GenerateAuthString( $token ),
1199         uri => $HTML::Mason::Commands::r->uri,
1200         args => $ARGS,
1201     };
1202     if ($ARGS->{Attach}) {
1203         my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1204         my $file_path = delete $ARGS->{'Attach'};
1205         $data->{attach} = {
1206             filename => Encode::decode_utf8("$file_path"),
1207             mime     => $attachment,
1208         };
1209     }
1210
1211     $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1212     $HTML::Mason::Commands::session{'i'}++;
1213     return $token;
1214 }
1215
1216 sub MaybeShowInterstitialCSRFPage {
1217     my $ARGS = shift;
1218
1219     return unless RT->Config->Get('RestrictReferrer');
1220
1221     # Deal with the form token provided by the interstitial, which lets
1222     # browsers which never set referer headers still use RT, if
1223     # painfully.  This blows values into ARGS
1224     return if ExpandCSRFToken($ARGS);
1225
1226     my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1227     return if !$is_csrf;
1228
1229     $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1230
1231     my $token = StoreRequestToken($ARGS);
1232     $HTML::Mason::Commands::m->comp(
1233         '/Elements/CSRF',
1234         OriginalURL => $HTML::Mason::Commands::r->uri,
1235         Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1236         Token => $token,
1237     );
1238     # Calls abort, never gets here
1239 }
1240
1241 package HTML::Mason::Commands;
1242
1243 use vars qw/$r $m %session/;
1244
1245 # {{{ loc
1246
1247 =head2 loc ARRAY
1248
1249 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1250 with whatever it's called with. If there is no $session{'CurrentUser'},
1251 it creates a temporary user, so we have something to get a localisation handle
1252 through
1253
1254 =cut
1255
1256 sub loc {
1257
1258     if ( $session{'CurrentUser'}
1259         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1260     {
1261         return ( $session{'CurrentUser'}->loc(@_) );
1262     } elsif (
1263         my $u = eval {
1264             RT::CurrentUser->new();
1265         }
1266         )
1267     {
1268         return ( $u->loc(@_) );
1269     } else {
1270
1271         # pathetic case -- SystemUser is gone.
1272         return $_[0];
1273     }
1274 }
1275
1276 # }}}
1277
1278 # {{{ loc_fuzzy
1279
1280 =head2 loc_fuzzy STRING
1281
1282 loc_fuzzy is for handling localizations of messages that may already
1283 contain interpolated variables, typically returned from libraries
1284 outside RT's control.  It takes the message string and extracts the
1285 variable array automatically by matching against the candidate entries
1286 inside the lexicon file.
1287
1288 =cut
1289
1290 sub loc_fuzzy {
1291     my $msg = shift;
1292
1293     if ( $session{'CurrentUser'}
1294         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1295     {
1296         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1297     } else {
1298         my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1299         return ( $u->loc_fuzzy($msg) );
1300     }
1301 }
1302
1303 # }}}
1304
1305 # {{{ sub Abort
1306 # Error - calls Error and aborts
1307 sub Abort {
1308     my $why  = shift;
1309     my %args = @_;
1310
1311     if (   $session{'ErrorDocument'}
1312         && $session{'ErrorDocumentType'} )
1313     {
1314         $r->content_type( $session{'ErrorDocumentType'} );
1315         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1316         $m->abort;
1317     } else {
1318         $m->comp( "/Elements/Error", Why => $why, %args );
1319         $m->abort;
1320     }
1321 }
1322
1323 # }}}
1324
1325 # {{{ sub CreateTicket
1326
1327 =head2 CreateTicket ARGS
1328
1329 Create a new ticket, using Mason's %ARGS.  returns @results.
1330
1331 =cut
1332
1333 sub CreateTicket {
1334     my %ARGS = (@_);
1335
1336     my (@Actions);
1337
1338     my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1339
1340     my $Queue = new RT::Queue( $session{'CurrentUser'} );
1341     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1342         Abort('Queue not found');
1343     }
1344
1345     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1346         Abort('You have no permission to create tickets in that queue.');
1347     }
1348
1349     my $due;
1350     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1351         $due = new RT::Date( $session{'CurrentUser'} );
1352         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1353     }
1354     my $starts;
1355     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1356         $starts = new RT::Date( $session{'CurrentUser'} );
1357         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1358     }
1359
1360     my $sigless = RT::Interface::Web::StripContent(
1361         Content        => $ARGS{Content},
1362         ContentType    => $ARGS{ContentType},
1363         StripSignature => 1,
1364         CurrentUser    => $session{'CurrentUser'},
1365     );
1366
1367     my $MIMEObj = MakeMIMEEntity(
1368         Subject => $ARGS{'Subject'},
1369         From    => $ARGS{'From'},
1370         Cc      => $ARGS{'Cc'},
1371         Body    => $sigless,
1372         Type    => $ARGS{'ContentType'},
1373     );
1374
1375     if ( $ARGS{'Attachments'} ) {
1376         my $rv = $MIMEObj->make_multipart;
1377         $RT::Logger->error("Couldn't make multipart message")
1378             if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1379
1380         foreach ( values %{ $ARGS{'Attachments'} } ) {
1381             unless ($_) {
1382                 $RT::Logger->error("Couldn't add empty attachemnt");
1383                 next;
1384             }
1385             $MIMEObj->add_part($_);
1386         }
1387     }
1388
1389     foreach my $argument (qw(Encrypt Sign)) {
1390         $MIMEObj->head->add(
1391             "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1392         ) if defined $ARGS{$argument};
1393     }
1394
1395     my %create_args = (
1396         Type => $ARGS{'Type'} || 'ticket',
1397         Queue => $ARGS{'Queue'},
1398         Owner => $ARGS{'Owner'},
1399
1400         # note: name change
1401         Requestor       => $ARGS{'Requestors'},
1402         Cc              => $ARGS{'Cc'},
1403         AdminCc         => $ARGS{'AdminCc'},
1404         InitialPriority => $ARGS{'InitialPriority'},
1405         FinalPriority   => $ARGS{'FinalPriority'},
1406         TimeLeft        => $ARGS{'TimeLeft'},
1407         TimeEstimated   => $ARGS{'TimeEstimated'},
1408         TimeWorked      => $ARGS{'TimeWorked'},
1409         Subject         => $ARGS{'Subject'},
1410         Status          => $ARGS{'Status'},
1411         Due             => $due ? $due->ISO : undef,
1412         Starts          => $starts ? $starts->ISO : undef,
1413         MIMEObj         => $MIMEObj
1414     );
1415
1416     my @temp_squelch;
1417     foreach my $type (qw(Requestor Cc AdminCc)) {
1418         push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1419             if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1420
1421     }
1422
1423     if (@temp_squelch) {
1424         require RT::Action::SendEmail;
1425         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1426     }
1427
1428     if ( $ARGS{'AttachTickets'} ) {
1429         require RT::Action::SendEmail;
1430         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1431             ref $ARGS{'AttachTickets'}
1432             ? @{ $ARGS{'AttachTickets'} }
1433             : ( $ARGS{'AttachTickets'} ) );
1434     }
1435
1436     foreach my $arg ( keys %ARGS ) {
1437         next if $arg =~ /-(?:Magic|Category)$/;
1438
1439         if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1440             $create_args{$arg} = $ARGS{$arg};
1441         }
1442
1443         # Object-RT::Ticket--CustomField-3-Values
1444         elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1445             my $cfid = $1;
1446
1447             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1448             $cf->SetContextObject( $Queue );
1449             $cf->Load($cfid);
1450             unless ( $cf->id ) {
1451                 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1452                 next;
1453             }
1454
1455             if ( $arg =~ /-Upload$/ ) {
1456                 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1457                 next;
1458             }
1459
1460             my $type = $cf->Type;
1461
1462             my @values = ();
1463             if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1464                 @values = @{ $ARGS{$arg} };
1465             } elsif ( $type =~ /text/i ) {
1466                 @values = ( $ARGS{$arg} );
1467             } else {
1468                 no warnings 'uninitialized';
1469                 @values = split /\r*\n/, $ARGS{$arg};
1470             }
1471             @values = grep length, map {
1472                 s/\r+\n/\n/g;
1473                 s/^\s+//;
1474                 s/\s+$//;
1475                 $_;
1476                 }
1477                 grep defined, @values;
1478
1479             $create_args{"CustomField-$cfid"} = \@values;
1480         }
1481     }
1482
1483     # turn new link lists into arrays, and pass in the proper arguments
1484     my %map = (
1485         'new-DependsOn' => 'DependsOn',
1486         'DependsOn-new' => 'DependedOnBy',
1487         'new-MemberOf'  => 'Parents',
1488         'MemberOf-new'  => 'Children',
1489         'new-RefersTo'  => 'RefersTo',
1490         'RefersTo-new'  => 'ReferredToBy',
1491     );
1492     foreach my $key ( keys %map ) {
1493         next unless $ARGS{$key};
1494         $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1495
1496     }
1497
1498     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1499     unless ($id) {
1500         Abort($ErrMsg);
1501     }
1502
1503     push( @Actions, split( "\n", $ErrMsg ) );
1504     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1505         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1506     }
1507     return ( $Ticket, @Actions );
1508
1509 }
1510
1511 # }}}
1512
1513 # {{{ sub LoadTicket - loads a ticket
1514
1515 =head2  LoadTicket id
1516
1517 Takes a ticket id as its only variable. if it's handed an array, it takes
1518 the first value.
1519
1520 Returns an RT::Ticket object as the current user.
1521
1522 =cut
1523
1524 sub LoadTicket {
1525     my $id = shift;
1526
1527     if ( ref($id) eq "ARRAY" ) {
1528         $id = $id->[0];
1529     }
1530
1531     unless ($id) {
1532         Abort("No ticket specified");
1533     }
1534
1535     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1536     $Ticket->Load($id);
1537     unless ( $Ticket->id ) {
1538         Abort("Could not load ticket $id");
1539     }
1540     return $Ticket;
1541 }
1542
1543 # }}}
1544
1545 # {{{ sub ProcessUpdateMessage
1546
1547 =head2 ProcessUpdateMessage
1548
1549 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1550
1551 Don't write message if it only contains current user's signature and
1552 SkipSignatureOnly argument is true. Function anyway adds attachments
1553 and updates time worked field even if skips message. The default value
1554 is true.
1555
1556 =cut
1557
1558 sub ProcessUpdateMessage {
1559
1560     my %args = (
1561         ARGSRef           => undef,
1562         TicketObj         => undef,
1563         SkipSignatureOnly => 1,
1564         @_
1565     );
1566
1567     if ( $args{ARGSRef}->{'UpdateAttachments'}
1568         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1569     {
1570         delete $args{ARGSRef}->{'UpdateAttachments'};
1571     }
1572
1573     # Strip the signature
1574     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1575         Content        => $args{ARGSRef}->{UpdateContent},
1576         ContentType    => $args{ARGSRef}->{UpdateContentType},
1577         StripSignature => $args{SkipSignatureOnly},
1578         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1579     );
1580
1581     # If, after stripping the signature, we have no message, move the
1582     # UpdateTimeWorked into adjusted TimeWorked, so that a later
1583     # ProcessBasics can deal -- then bail out.
1584     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1585         and not length $args{ARGSRef}->{'UpdateContent'} )
1586     {
1587         if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1588             $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1589         }
1590         return;
1591     }
1592
1593     if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1594         $args{ARGSRef}->{'UpdateSubject'} = undef;
1595     }
1596
1597     my $Message = MakeMIMEEntity(
1598         Subject => $args{ARGSRef}->{'UpdateSubject'},
1599         Body    => $args{ARGSRef}->{'UpdateContent'},
1600         Type    => $args{ARGSRef}->{'UpdateContentType'},
1601     );
1602
1603     $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1604         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1605     ) );
1606     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1607     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1608         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1609     } else {
1610         $old_txn = $args{TicketObj}->Transactions->First();
1611     }
1612
1613     if ( my $msg = $old_txn->Message->First ) {
1614         RT::Interface::Email::SetInReplyTo(
1615             Message   => $Message,
1616             InReplyTo => $msg
1617         );
1618     }
1619
1620     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1621         $Message->make_multipart;
1622         $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1623     }
1624
1625     if ( $args{ARGSRef}->{'AttachTickets'} ) {
1626         require RT::Action::SendEmail;
1627         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1628             ref $args{ARGSRef}->{'AttachTickets'}
1629             ? @{ $args{ARGSRef}->{'AttachTickets'} }
1630             : ( $args{ARGSRef}->{'AttachTickets'} ) );
1631     }
1632
1633     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1634     my $cc  = $args{ARGSRef}->{'UpdateCc'};
1635
1636     my %txn_customfields;
1637
1638     foreach my $key ( keys %{ $args{ARGSRef} } ) {
1639       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1640         $txn_customfields{$key} = $args{ARGSRef}->{$key};
1641       }
1642     }
1643
1644     my %message_args = (
1645         CcMessageTo  => $cc,
1646         BccMessageTo => $bcc,
1647         Sign         => $args{ARGSRef}->{'Sign'},
1648         Encrypt      => $args{ARGSRef}->{'Encrypt'},
1649         MIMEObj      => $Message,
1650         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
1651         CustomFields => \%txn_customfields,
1652     );
1653
1654     my @temp_squelch;
1655     foreach my $type (qw(Cc AdminCc)) {
1656         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1657             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1658             push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1659             push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1660         }
1661     }
1662     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1663             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1664             push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1665     }
1666
1667     if (@temp_squelch) {
1668         require RT::Action::SendEmail;
1669         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1670     }
1671
1672     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1673         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1674             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1675
1676             my $var   = ucfirst($1) . 'MessageTo';
1677             my $value = $2;
1678             if ( $message_args{$var} ) {
1679                 $message_args{$var} .= ", $value";
1680             } else {
1681                 $message_args{$var} = $value;
1682             }
1683         }
1684     }
1685
1686     my @results;
1687     # Do the update via the appropriate Ticket method
1688     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1689         my ( $Transaction, $Description, $Object ) =
1690             $args{TicketObj}->Comment(%message_args);
1691         push( @results, $Description );
1692         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1693     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1694         my ( $Transaction, $Description, $Object ) =
1695             $args{TicketObj}->Correspond(%message_args);
1696         push( @results, $Description );
1697         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1698     } else {
1699         push( @results,
1700             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1701     }
1702     return @results;
1703 }
1704
1705 # }}}
1706
1707 # {{{ sub MakeMIMEEntity
1708
1709 =head2 MakeMIMEEntity PARAMHASH
1710
1711 Takes a paramhash Subject, Body and AttachmentFieldName.
1712
1713 Also takes Form, Cc and Type as optional paramhash keys.
1714
1715   Returns a MIME::Entity.
1716
1717 =cut
1718
1719 sub MakeMIMEEntity {
1720
1721     #TODO document what else this takes.
1722     my %args = (
1723         Subject             => undef,
1724         From                => undef,
1725         Cc                  => undef,
1726         Body                => undef,
1727         AttachmentFieldName => undef,
1728         Type                => undef,
1729         @_,
1730     );
1731     my $Message = MIME::Entity->build(
1732         Type    => 'multipart/mixed',
1733         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1734             grep defined $args{$_}, qw(Subject From Cc)
1735     );
1736
1737     if ( defined $args{'Body'} && length $args{'Body'} ) {
1738
1739         # Make the update content have no 'weird' newlines in it
1740         $args{'Body'} =~ s/\r\n/\n/gs;
1741
1742         $Message->attach(
1743             Type    => $args{'Type'} || 'text/plain',
1744             Charset => 'UTF-8',
1745             Data    => $args{'Body'},
1746         );
1747     }
1748
1749     if ( $args{'AttachmentFieldName'} ) {
1750
1751         my $cgi_object = $m->cgi_object;
1752
1753         if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1754
1755             my ( @content, $buffer );
1756             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1757                 push @content, $buffer;
1758             }
1759
1760             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1761
1762             # Prefer the cached name first over CGI.pm stringification.
1763             my $filename = $RT::Mason::CGI::Filename;
1764             $filename = "$filehandle" unless defined $filename;
1765             $filename = Encode::encode_utf8( $filename );
1766             $filename =~ s{^.*[\\/]}{};
1767
1768             $Message->attach(
1769                 Type     => $uploadinfo->{'Content-Type'},
1770                 Filename => $filename,
1771                 Data     => \@content,
1772             );
1773             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1774                 $Message->head->set( 'Subject' => $filename );
1775             }
1776         }
1777     }
1778
1779     $Message->make_singlepart;
1780
1781     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1782
1783     return ($Message);
1784
1785 }
1786
1787 # }}}
1788
1789 # {{{ sub ParseDateToISO
1790
1791 =head2 ParseDateToISO
1792
1793 Takes a date in an arbitrary format.
1794 Returns an ISO date and time in GMT
1795
1796 =cut
1797
1798 sub ParseDateToISO {
1799     my $date = shift;
1800
1801     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1802     $date_obj->Set(
1803         Format => 'unknown',
1804         Value  => $date
1805     );
1806     return ( $date_obj->ISO );
1807 }
1808
1809 # }}}
1810
1811 # {{{ sub ProcessACLChanges
1812
1813 sub ProcessACLChanges {
1814     my $ARGSref = shift;
1815
1816     my @results;
1817
1818     foreach my $arg ( keys %$ARGSref ) {
1819         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1820
1821         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1822
1823         my @rights;
1824         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1825             @rights = @{ $ARGSref->{$arg} };
1826         } else {
1827             @rights = $ARGSref->{$arg};
1828         }
1829         @rights = grep $_, @rights;
1830         next unless @rights;
1831
1832         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1833         $principal->Load($principal_id);
1834
1835         my $obj;
1836         if ( $object_type eq 'RT::System' ) {
1837             $obj = $RT::System;
1838         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1839             $obj = $object_type->new( $session{'CurrentUser'} );
1840             $obj->Load($object_id);
1841             unless ( $obj->id ) {
1842                 $RT::Logger->error("couldn't load $object_type #$object_id");
1843                 next;
1844             }
1845         } else {
1846             $RT::Logger->error("object type '$object_type' is incorrect");
1847             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1848             next;
1849         }
1850
1851         foreach my $right (@rights) {
1852             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1853             push( @results, $msg );
1854         }
1855     }
1856
1857     return (@results);
1858 }
1859
1860 # }}}
1861
1862 # {{{ sub UpdateRecordObj
1863
1864 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1865
1866 @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.
1867
1868 Returns an array of success/failure messages
1869
1870 =cut
1871
1872 sub UpdateRecordObject {
1873     my %args = (
1874         ARGSRef         => undef,
1875         AttributesRef   => undef,
1876         Object          => undef,
1877         AttributePrefix => undef,
1878         @_
1879     );
1880
1881     my $Object  = $args{'Object'};
1882     my @results = $Object->Update(
1883         AttributesRef   => $args{'AttributesRef'},
1884         ARGSRef         => $args{'ARGSRef'},
1885         AttributePrefix => $args{'AttributePrefix'},
1886     );
1887
1888     return (@results);
1889 }
1890
1891 # }}}
1892
1893 # {{{ Sub ProcessCustomFieldUpdates
1894
1895 sub ProcessCustomFieldUpdates {
1896     my %args = (
1897         CustomFieldObj => undef,
1898         ARGSRef        => undef,
1899         @_
1900     );
1901
1902     my $Object  = $args{'CustomFieldObj'};
1903     my $ARGSRef = $args{'ARGSRef'};
1904
1905     my @attribs = qw(Name Type Description Queue SortOrder);
1906     my @results = UpdateRecordObject(
1907         AttributesRef => \@attribs,
1908         Object        => $Object,
1909         ARGSRef       => $ARGSRef
1910     );
1911
1912     my $prefix = "CustomField-" . $Object->Id;
1913     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1914         my ( $addval, $addmsg ) = $Object->AddValue(
1915             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1916             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1917             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1918         );
1919         push( @results, $addmsg );
1920     }
1921
1922     my @delete_values
1923         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1924         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1925         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1926
1927     foreach my $id (@delete_values) {
1928         next unless defined $id;
1929         my ( $err, $msg ) = $Object->DeleteValue($id);
1930         push( @results, $msg );
1931     }
1932
1933     my $vals = $Object->Values();
1934     while ( my $cfv = $vals->Next() ) {
1935         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1936             if ( $cfv->SortOrder != $so ) {
1937                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1938                 push( @results, $msg );
1939             }
1940         }
1941     }
1942
1943     return (@results);
1944 }
1945
1946 # }}}
1947
1948 # {{{ sub ProcessTicketBasics
1949
1950 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1951
1952 Returns an array of results messages.
1953
1954 =cut
1955
1956 sub ProcessTicketBasics {
1957
1958     my %args = (
1959         TicketObj => undef,
1960         ARGSRef   => undef,
1961         @_
1962     );
1963
1964     my $TicketObj = $args{'TicketObj'};
1965     my $ARGSRef   = $args{'ARGSRef'};
1966
1967     # {{{ Set basic fields
1968     my @attribs = qw(
1969         Subject
1970         FinalPriority
1971         Priority
1972         TimeEstimated
1973         TimeWorked
1974         TimeLeft
1975         Type
1976         Status
1977         Queue
1978     );
1979
1980     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1981         my $tempqueue = RT::Queue->new($RT::SystemUser);
1982         $tempqueue->Load( $ARGSRef->{'Queue'} );
1983         if ( $tempqueue->id ) {
1984             $ARGSRef->{'Queue'} = $tempqueue->id;
1985         }
1986     }
1987
1988     # Status isn't a field that can be set to a null value.
1989     # RT core complains if you try
1990     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1991
1992     my @results = UpdateRecordObject(
1993         AttributesRef => \@attribs,
1994         Object        => $TicketObj,
1995         ARGSRef       => $ARGSRef,
1996     );
1997
1998     # We special case owner changing, so we can use ForceOwnerChange
1999     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2000         my ($ChownType);
2001         if ( $ARGSRef->{'ForceOwnerChange'} ) {
2002             $ChownType = "Force";
2003         } else {
2004             $ChownType = "Give";
2005         }
2006
2007         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2008         push( @results, $msg );
2009     }
2010
2011     # }}}
2012
2013     return (@results);
2014 }
2015
2016 # }}}
2017
2018 sub ProcessTicketCustomFieldUpdates {
2019     my %args = @_;
2020     $args{'Object'} = delete $args{'TicketObj'};
2021     my $ARGSRef = { %{ $args{'ARGSRef'} } };
2022
2023     # Build up a list of objects that we want to work with
2024     my %custom_fields_to_mod;
2025     foreach my $arg ( keys %$ARGSRef ) {
2026         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2027             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2028         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2029             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2030         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2031             delete $ARGSRef->{$arg}; # don't try to update transaction fields
2032         }
2033     }
2034
2035     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2036 }
2037
2038 sub ProcessObjectCustomFieldUpdates {
2039     my %args    = @_;
2040     my $ARGSRef = $args{'ARGSRef'};
2041     my @results;
2042
2043     # Build up a list of objects that we want to work with
2044     my %custom_fields_to_mod;
2045     foreach my $arg ( keys %$ARGSRef ) {
2046
2047         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2048         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2049
2050         # For each of those objects, find out what custom fields we want to work with.
2051         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2052     }
2053
2054     # For each of those objects
2055     foreach my $class ( keys %custom_fields_to_mod ) {
2056         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2057             my $Object = $args{'Object'};
2058             $Object = $class->new( $session{'CurrentUser'} )
2059                 unless $Object && ref $Object eq $class;
2060
2061             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2062             unless ( $Object->id ) {
2063                 $RT::Logger->warning("Couldn't load object $class #$id");
2064                 next;
2065             }
2066
2067             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2068                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2069                 $CustomFieldObj->SetContextObject($Object);
2070                 $CustomFieldObj->LoadById($cf);
2071                 unless ( $CustomFieldObj->id ) {
2072                     $RT::Logger->warning("Couldn't load custom field #$cf");
2073                     next;
2074                 }
2075                 push @results,
2076                     _ProcessObjectCustomFieldUpdates(
2077                     Prefix      => "Object-$class-$id-CustomField-$cf-",
2078                     Object      => $Object,
2079                     CustomField => $CustomFieldObj,
2080                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
2081                     );
2082             }
2083         }
2084     }
2085     return @results;
2086 }
2087
2088 sub _ProcessObjectCustomFieldUpdates {
2089     my %args    = @_;
2090     my $cf      = $args{'CustomField'};
2091     my $cf_type = $cf->Type;
2092
2093     # Remove blank Values since the magic field will take care of this. Sometimes
2094     # the browser gives you a blank value which causes CFs to be processed twice
2095     if (   defined $args{'ARGS'}->{'Values'}
2096         && !length $args{'ARGS'}->{'Values'}
2097         && $args{'ARGS'}->{'Values-Magic'} )
2098     {
2099         delete $args{'ARGS'}->{'Values'};
2100     }
2101
2102     my @results;
2103     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2104
2105         # skip category argument
2106         next if $arg eq 'Category';
2107
2108         # and TimeUnits
2109         next if $arg eq 'Value-TimeUnits';
2110
2111         # since http won't pass in a form element with a null value, we need
2112         # to fake it
2113         if ( $arg eq 'Values-Magic' ) {
2114
2115             # We don't care about the magic, if there's really a values element;
2116             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
2117             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2118
2119             # "Empty" values does not mean anything for Image and Binary fields
2120             next if $cf_type =~ /^(?:Image|Binary)$/;
2121
2122             $arg = 'Values';
2123             $args{'ARGS'}->{'Values'} = undef;
2124         }
2125
2126         my @values = ();
2127         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2128             @values = @{ $args{'ARGS'}->{$arg} };
2129         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
2130             @values = ( $args{'ARGS'}->{$arg} );
2131         } else {
2132             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2133                 if defined $args{'ARGS'}->{$arg};
2134         }
2135         @values = grep length, map {
2136             s/\r+\n/\n/g;
2137             s/^\s+//;
2138             s/\s+$//;
2139             $_;
2140             }
2141             grep defined, @values;
2142
2143         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2144             foreach my $value (@values) {
2145                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2146                     Field => $cf->id,
2147                     Value => $value
2148                 );
2149                 push( @results, $msg );
2150             }
2151         } elsif ( $arg eq 'Upload' ) {
2152             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2153             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2154             push( @results, $msg );
2155         } elsif ( $arg eq 'DeleteValues' ) {
2156             foreach my $value (@values) {
2157                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2158                     Field => $cf,
2159                     Value => $value,
2160                 );
2161                 push( @results, $msg );
2162             }
2163         } elsif ( $arg eq 'DeleteValueIds' ) {
2164             foreach my $value (@values) {
2165                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2166                     Field   => $cf,
2167                     ValueId => $value,
2168                 );
2169                 push( @results, $msg );
2170             }
2171         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2172             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2173
2174             my %values_hash;
2175             foreach my $value (@values) {
2176                 if ( my $entry = $cf_values->HasEntry($value) ) {
2177                     $values_hash{ $entry->id } = 1;
2178                     next;
2179                 }
2180
2181                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2182                     Field => $cf,
2183                     Value => $value
2184                 );
2185                 push( @results, $msg );
2186                 $values_hash{$val} = 1 if $val;
2187             }
2188
2189             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2190             return @results if ( $cf->Type eq 'Date' && ! @values );
2191
2192             $cf_values->RedoSearch;
2193             while ( my $cf_value = $cf_values->Next ) {
2194                 next if $values_hash{ $cf_value->id };
2195
2196                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2197                     Field   => $cf,
2198                     ValueId => $cf_value->id
2199                 );
2200                 push( @results, $msg );
2201             }
2202         } elsif ( $arg eq 'Values' ) {
2203             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2204
2205             # keep everything up to the point of difference, delete the rest
2206             my $delete_flag;
2207             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2208                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2209                     shift @values;
2210                     next;
2211                 }
2212
2213                 $delete_flag ||= 1;
2214                 $old_cf->Delete;
2215             }
2216
2217             # now add/replace extra things, if any
2218             foreach my $value (@values) {
2219                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2220                     Field => $cf,
2221                     Value => $value
2222                 );
2223                 push( @results, $msg );
2224             }
2225         } else {
2226             push(
2227                 @results,
2228                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2229                     $cf->Name, ref $args{'Object'},
2230                     $args{'Object'}->id
2231                 )
2232             );
2233         }
2234     }
2235     return @results;
2236 }
2237
2238 # {{{ sub ProcessTicketWatchers
2239
2240 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2241
2242 Returns an array of results messages.
2243
2244 =cut
2245
2246 sub ProcessTicketWatchers {
2247     my %args = (
2248         TicketObj => undef,
2249         ARGSRef   => undef,
2250         @_
2251     );
2252     my (@results);
2253
2254     my $Ticket  = $args{'TicketObj'};
2255     my $ARGSRef = $args{'ARGSRef'};
2256
2257     # Munge watchers
2258
2259     foreach my $key ( keys %$ARGSRef ) {
2260
2261         # Delete deletable watchers
2262         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2263             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2264                 PrincipalId => $2,
2265                 Type        => $1
2266             );
2267             push @results, $msg;
2268         }
2269
2270         # Delete watchers in the simple style demanded by the bulk manipulator
2271         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2272             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2273                 Email => $ARGSRef->{$key},
2274                 Type  => $1
2275             );
2276             push @results, $msg;
2277         }
2278
2279         # Add new wathchers by email address
2280         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2281             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2282         {
2283
2284             #They're in this order because otherwise $1 gets clobbered :/
2285             my ( $code, $msg ) = $Ticket->AddWatcher(
2286                 Type  => $ARGSRef->{$key},
2287                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2288             );
2289             push @results, $msg;
2290         }
2291
2292         #Add requestors in the simple style demanded by the bulk manipulator
2293         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2294             my ( $code, $msg ) = $Ticket->AddWatcher(
2295                 Type  => $1,
2296                 Email => $ARGSRef->{$key}
2297             );
2298             push @results, $msg;
2299         }
2300
2301         # Add new  watchers by owner
2302         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2303             my $principal_id = $1;
2304             my $form         = $ARGSRef->{$key};
2305             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2306                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2307
2308                 my ( $code, $msg ) = $Ticket->AddWatcher(
2309                     Type        => $value,
2310                     PrincipalId => $principal_id
2311                 );
2312                 push @results, $msg;
2313             }
2314         }
2315
2316     }
2317     return (@results);
2318 }
2319
2320 # }}}
2321
2322 # {{{ sub ProcessTicketDates
2323
2324 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2325
2326 Returns an array of results messages.
2327
2328 =cut
2329
2330 sub ProcessTicketDates {
2331     my %args = (
2332         TicketObj => undef,
2333         ARGSRef   => undef,
2334         @_
2335     );
2336
2337     my $Ticket  = $args{'TicketObj'};
2338     my $ARGSRef = $args{'ARGSRef'};
2339
2340     my (@results);
2341
2342     # {{{ Set date fields
2343     my @date_fields = qw(
2344         Told
2345         Resolved
2346         Starts
2347         Started
2348         Due
2349     );
2350
2351     #Run through each field in this list. update the value if apropriate
2352     foreach my $field (@date_fields) {
2353         next unless exists $ARGSRef->{ $field . '_Date' };
2354         next if $ARGSRef->{ $field . '_Date' } eq '';
2355
2356         my ( $code, $msg );
2357
2358         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2359         $DateObj->Set(
2360             Format => 'unknown',
2361             Value  => $ARGSRef->{ $field . '_Date' }
2362         );
2363
2364         my $obj = $field . "Obj";
2365         if (    ( defined $DateObj->Unix )
2366             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2367         {
2368             my $method = "Set$field";
2369             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2370             push @results, "$msg";
2371         }
2372     }
2373
2374     # }}}
2375     return (@results);
2376 }
2377
2378 # }}}
2379
2380 # {{{ sub ProcessTicketLinks
2381
2382 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2383
2384 Returns an array of results messages.
2385
2386 =cut
2387
2388 sub ProcessTicketLinks {
2389     my %args = (
2390         TicketObj => undef,
2391         ARGSRef   => undef,
2392         @_
2393     );
2394
2395     my $Ticket  = $args{'TicketObj'};
2396     my $ARGSRef = $args{'ARGSRef'};
2397
2398     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2399
2400     #Merge if we need to
2401     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2402         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2403         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2404         push @results, $msg;
2405     }
2406
2407     return (@results);
2408 }
2409
2410 # }}}
2411
2412 sub ProcessRecordLinks {
2413     my %args = (
2414         RecordObj => undef,
2415         ARGSRef   => undef,
2416         @_
2417     );
2418
2419     my $Record  = $args{'RecordObj'};
2420     my $ARGSRef = $args{'ARGSRef'};
2421
2422     my (@results);
2423
2424     # Delete links that are gone gone gone.
2425     foreach my $arg ( keys %$ARGSRef ) {
2426         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2427             my $base   = $1;
2428             my $type   = $2;
2429             my $target = $3;
2430
2431             my ( $val, $msg ) = $Record->DeleteLink(
2432                 Base   => $base,
2433                 Type   => $type,
2434                 Target => $target
2435             );
2436
2437             push @results, $msg;
2438
2439         }
2440
2441     }
2442
2443     my @linktypes = qw( DependsOn MemberOf RefersTo );
2444
2445     foreach my $linktype (@linktypes) {
2446         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2447             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2448                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2449
2450             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2451                 next unless $luri;
2452                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2453                 my ( $val, $msg ) = $Record->AddLink(
2454                     Target => $luri,
2455                     Type   => $linktype
2456                 );
2457                 push @results, $msg;
2458             }
2459         }
2460         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2461             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2462                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2463
2464             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2465                 next unless $luri;
2466                 my ( $val, $msg ) = $Record->AddLink(
2467                     Base => $luri,
2468                     Type => $linktype
2469                 );
2470
2471                 push @results, $msg;
2472             }
2473         }
2474     }
2475
2476     return (@results);
2477 }
2478
2479 =head2 _UploadedFile ( $arg );
2480
2481 Takes a CGI parameter name; if a file is uploaded under that name,
2482 return a hash reference suitable for AddCustomFieldValue's use:
2483 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2484
2485 Returns C<undef> if no files were uploaded in the C<$arg> field.
2486
2487 =cut
2488
2489 sub _UploadedFile {
2490     my $arg         = shift;
2491     my $cgi_object  = $m->cgi_object;
2492     my $fh          = $cgi_object->upload($arg) or return undef;
2493     my $upload_info = $cgi_object->uploadInfo($fh);
2494
2495     my $filename = "$fh";
2496     $filename =~ s#^.*[\\/]##;
2497     binmode($fh);
2498
2499     return {
2500         Value        => $filename,
2501         LargeContent => do { local $/; scalar <$fh> },
2502         ContentType  => $upload_info->{'Content-Type'},
2503     };
2504 }
2505
2506 sub GetColumnMapEntry {
2507     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2508
2509     # deal with the simplest thing first
2510     if ( $args{'Map'}{ $args{'Name'} } ) {
2511         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2512     }
2513
2514     # complex things
2515     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2516         return undef unless $args{'Map'}->{$mainkey};
2517         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2518             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2519
2520         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2521     }
2522     return undef;
2523 }
2524
2525 sub ProcessColumnMapValue {
2526     my $value = shift;
2527     my %args = ( Arguments => [], Escape => 1, @_ );
2528
2529     if ( ref $value ) {
2530         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2531             my @tmp = $value->( @{ $args{'Arguments'} } );
2532             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2533         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2534             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2535         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2536             return $$value;
2537         }
2538     }
2539
2540     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2541     return $value;
2542 }
2543
2544 =head2 _load_container_object ( $type, $id );
2545
2546 Instantiate container object for saving searches.
2547
2548 =cut
2549
2550 sub _load_container_object {
2551     my ( $obj_type, $obj_id ) = @_;
2552     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2553 }
2554
2555 =head2 _parse_saved_search ( $arg );
2556
2557 Given a serialization string for saved search, and returns the
2558 container object and the search id.
2559
2560 =cut
2561
2562 sub _parse_saved_search {
2563     my $spec = shift;
2564     return unless $spec;
2565     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2566         return;
2567     }
2568     my $obj_type  = $1;
2569     my $obj_id    = $2;
2570     my $search_id = $3;
2571
2572     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2573 }
2574
2575 =head2 ScrubHTML content
2576
2577 Removes unsafe and undesired HTML from the passed content
2578
2579 =cut
2580
2581 my $SCRUBBER;
2582 sub ScrubHTML {
2583     my $Content = shift;
2584     $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2585
2586     $Content = '' if !defined($Content);
2587     return $SCRUBBER->scrub($Content);
2588 }
2589
2590 =head2 _NewScrubber
2591
2592 Returns a new L<HTML::Scrubber> object.
2593
2594 If you need to be more lax about what HTML tags and attributes are allowed,
2595 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2596 following:
2597
2598     package HTML::Mason::Commands;
2599     # Let tables through
2600     push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2601     1;
2602
2603 =cut
2604
2605 our @SCRUBBER_ALLOWED_TAGS = qw(
2606     A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2607     H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2608 );
2609
2610 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2611     # Match http, ftp and relative urls
2612     # XXX: we also scrub format strings with this module then allow simple config options
2613     href   => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2614     face   => 1,
2615     size   => 1,
2616     target => 1,
2617     style  => qr{
2618         ^(?:\s*
2619             (?:(?:background-)?color: \s*
2620                     (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) |   # rgb(d,d,d)
2621                        \#[a-f0-9]{3,6}                      |   # #fff or #ffffff
2622                        [\w\-]+                                  # green, light-blue, etc.
2623                        )                            |
2624                text-align: \s* \w+                  |
2625                font-size: \s* [\w.\-]+              |
2626                font-family: \s* [\w\s"',.\-]+       |
2627                font-weight: \s* [\w\-]+             |
2628
2629                # MS Office styles, which are probably fine.  If we don't, then any
2630                # associated styles in the same attribute get stripped.
2631                mso-[\w\-]+?: \s* [\w\s"',.\-]+
2632             )\s* ;? \s*)
2633          +$ # one or more of these allowed properties from here 'till sunset
2634     }ix,
2635 );
2636
2637 our %SCRUBBER_RULES = ();
2638
2639 sub _NewScrubber {
2640     require HTML::Scrubber;
2641     my $scrubber = HTML::Scrubber->new();
2642     $scrubber->default(
2643         0,
2644         {
2645             %SCRUBBER_ALLOWED_ATTRIBUTES,
2646             '*' => 0, # require attributes be explicitly allowed
2647         },
2648     );
2649     $scrubber->deny(qw[*]);
2650     $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2651     $scrubber->rules(%SCRUBBER_RULES);
2652
2653     # Scrubbing comments is vital since IE conditional comments can contain
2654     # arbitrary HTML and we'd pass it right on through.
2655     $scrubber->comment(0);
2656
2657     return $scrubber;
2658 }
2659
2660 package RT::Interface::Web;
2661 RT::Base->_ImportOverlays();
2662
2663 1;