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