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     my @results;
1551
1552     foreach my $arg ( keys %$ARGSref ) {
1553         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1554
1555         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1556
1557         my @rights;
1558         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1559             @rights = @{ $ARGSref->{$arg} };
1560         } else {
1561             @rights = $ARGSref->{$arg};
1562         }
1563         @rights = grep $_, @rights;
1564         next unless @rights;
1565
1566         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1567         $principal->Load($principal_id);
1568
1569         my $obj;
1570         if ( $object_type eq 'RT::System' ) {
1571             $obj = $RT::System;
1572         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1573             $obj = $object_type->new( $session{'CurrentUser'} );
1574             $obj->Load($object_id);
1575             unless ( $obj->id ) {
1576                 $RT::Logger->error("couldn't load $object_type #$object_id");
1577                 next;
1578             }
1579         } else {
1580             $RT::Logger->error("object type '$object_type' is incorrect");
1581             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1582             next;
1583         }
1584
1585         foreach my $right (@rights) {
1586             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1587             push( @results, $msg );
1588         }
1589     }
1590
1591     return (@results);
1592 }
1593
1594 # }}}
1595
1596 # {{{ sub UpdateRecordObj
1597
1598 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1599
1600 @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.
1601
1602 Returns an array of success/failure messages
1603
1604 =cut
1605
1606 sub UpdateRecordObject {
1607     my %args = (
1608         ARGSRef         => undef,
1609         AttributesRef   => undef,
1610         Object          => undef,
1611         AttributePrefix => undef,
1612         @_
1613     );
1614
1615     my $Object  = $args{'Object'};
1616     my @results = $Object->Update(
1617         AttributesRef   => $args{'AttributesRef'},
1618         ARGSRef         => $args{'ARGSRef'},
1619         AttributePrefix => $args{'AttributePrefix'},
1620     );
1621
1622     return (@results);
1623 }
1624
1625 # }}}
1626
1627 # {{{ Sub ProcessCustomFieldUpdates
1628
1629 sub ProcessCustomFieldUpdates {
1630     my %args = (
1631         CustomFieldObj => undef,
1632         ARGSRef        => undef,
1633         @_
1634     );
1635
1636     my $Object  = $args{'CustomFieldObj'};
1637     my $ARGSRef = $args{'ARGSRef'};
1638
1639     my @attribs = qw(Name Type Description Queue SortOrder);
1640     my @results = UpdateRecordObject(
1641         AttributesRef => \@attribs,
1642         Object        => $Object,
1643         ARGSRef       => $ARGSRef
1644     );
1645
1646     my $prefix = "CustomField-" . $Object->Id;
1647     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1648         my ( $addval, $addmsg ) = $Object->AddValue(
1649             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1650             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1651             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1652         );
1653         push( @results, $addmsg );
1654     }
1655
1656     my @delete_values
1657         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1658         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1659         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1660
1661     foreach my $id (@delete_values) {
1662         next unless defined $id;
1663         my ( $err, $msg ) = $Object->DeleteValue($id);
1664         push( @results, $msg );
1665     }
1666
1667     my $vals = $Object->Values();
1668     while ( my $cfv = $vals->Next() ) {
1669         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1670             if ( $cfv->SortOrder != $so ) {
1671                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1672                 push( @results, $msg );
1673             }
1674         }
1675     }
1676
1677     return (@results);
1678 }
1679
1680 # }}}
1681
1682 # {{{ sub ProcessTicketBasics
1683
1684 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1685
1686 Returns an array of results messages.
1687
1688 =cut
1689
1690 sub ProcessTicketBasics {
1691
1692     my %args = (
1693         TicketObj => undef,
1694         ARGSRef   => undef,
1695         @_
1696     );
1697
1698     my $TicketObj = $args{'TicketObj'};
1699     my $ARGSRef   = $args{'ARGSRef'};
1700
1701     # {{{ Set basic fields
1702     my @attribs = qw(
1703         Subject
1704         FinalPriority
1705         Priority
1706         TimeEstimated
1707         TimeWorked
1708         TimeLeft
1709         Type
1710         Status
1711         Queue
1712     );
1713
1714     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1715         my $tempqueue = RT::Queue->new($RT::SystemUser);
1716         $tempqueue->Load( $ARGSRef->{'Queue'} );
1717         if ( $tempqueue->id ) {
1718             $ARGSRef->{'Queue'} = $tempqueue->id;
1719         }
1720     }
1721
1722     # Status isn't a field that can be set to a null value.
1723     # RT core complains if you try
1724     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1725
1726     my @results = UpdateRecordObject(
1727         AttributesRef => \@attribs,
1728         Object        => $TicketObj,
1729         ARGSRef       => $ARGSRef,
1730     );
1731
1732     # We special case owner changing, so we can use ForceOwnerChange
1733     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1734         my ($ChownType);
1735         if ( $ARGSRef->{'ForceOwnerChange'} ) {
1736             $ChownType = "Force";
1737         } else {
1738             $ChownType = "Give";
1739         }
1740
1741         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1742         push( @results, $msg );
1743     }
1744
1745     # }}}
1746
1747     return (@results);
1748 }
1749
1750 # }}}
1751
1752 sub ProcessTicketCustomFieldUpdates {
1753     my %args = @_;
1754     $args{'Object'} = delete $args{'TicketObj'};
1755     my $ARGSRef = { %{ $args{'ARGSRef'} } };
1756
1757     # Build up a list of objects that we want to work with
1758     my %custom_fields_to_mod;
1759     foreach my $arg ( keys %$ARGSRef ) {
1760         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1761             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1762         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1763             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1764         }
1765     }
1766
1767     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1768 }
1769
1770 sub ProcessObjectCustomFieldUpdates {
1771     my %args    = @_;
1772     my $ARGSRef = $args{'ARGSRef'};
1773     my @results;
1774
1775     # Build up a list of objects that we want to work with
1776     my %custom_fields_to_mod;
1777     foreach my $arg ( keys %$ARGSRef ) {
1778
1779         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1780         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1781
1782         # For each of those objects, find out what custom fields we want to work with.
1783         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1784     }
1785
1786     # For each of those objects
1787     foreach my $class ( keys %custom_fields_to_mod ) {
1788         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1789             my $Object = $args{'Object'};
1790             $Object = $class->new( $session{'CurrentUser'} )
1791                 unless $Object && ref $Object eq $class;
1792
1793             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1794             unless ( $Object->id ) {
1795                 $RT::Logger->warning("Couldn't load object $class #$id");
1796                 next;
1797             }
1798
1799             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1800                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1801                 $CustomFieldObj->LoadById($cf);
1802                 unless ( $CustomFieldObj->id ) {
1803                     $RT::Logger->warning("Couldn't load custom field #$cf");
1804                     next;
1805                 }
1806                 push @results,
1807                     _ProcessObjectCustomFieldUpdates(
1808                     Prefix      => "Object-$class-$id-CustomField-$cf-",
1809                     Object      => $Object,
1810                     CustomField => $CustomFieldObj,
1811                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
1812                     );
1813             }
1814         }
1815     }
1816     return @results;
1817 }
1818
1819 sub _ProcessObjectCustomFieldUpdates {
1820     my %args    = @_;
1821     my $cf      = $args{'CustomField'};
1822     my $cf_type = $cf->Type;
1823
1824     # Remove blank Values since the magic field will take care of this. Sometimes
1825     # the browser gives you a blank value which causes CFs to be processed twice
1826     if (   defined $args{'ARGS'}->{'Values'}
1827         && !length $args{'ARGS'}->{'Values'}
1828         && $args{'ARGS'}->{'Values-Magic'} )
1829     {
1830         delete $args{'ARGS'}->{'Values'};
1831     }
1832
1833     my @results;
1834     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1835
1836         # skip category argument
1837         next if $arg eq 'Category';
1838
1839         # since http won't pass in a form element with a null value, we need
1840         # to fake it
1841         if ( $arg eq 'Values-Magic' ) {
1842
1843             # We don't care about the magic, if there's really a values element;
1844             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
1845             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1846
1847             # "Empty" values does not mean anything for Image and Binary fields
1848             next if $cf_type =~ /^(?:Image|Binary)$/;
1849
1850             $arg = 'Values';
1851             $args{'ARGS'}->{'Values'} = undef;
1852         }
1853
1854         my @values = ();
1855         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1856             @values = @{ $args{'ARGS'}->{$arg} };
1857         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
1858             @values = ( $args{'ARGS'}->{$arg} );
1859         } else {
1860             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1861                 if defined $args{'ARGS'}->{$arg};
1862         }
1863         @values = grep length, map {
1864             s/\r+\n/\n/g;
1865             s/^\s+//;
1866             s/\s+$//;
1867             $_;
1868             }
1869             grep defined, @values;
1870
1871         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1872             foreach my $value (@values) {
1873                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1874                     Field => $cf->id,
1875                     Value => $value
1876                 );
1877                 push( @results, $msg );
1878             }
1879         } elsif ( $arg eq 'Upload' ) {
1880             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1881             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1882             push( @results, $msg );
1883         } elsif ( $arg eq 'DeleteValues' ) {
1884             foreach my $value (@values) {
1885                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1886                     Field => $cf,
1887                     Value => $value,
1888                 );
1889                 push( @results, $msg );
1890             }
1891         } elsif ( $arg eq 'DeleteValueIds' ) {
1892             foreach my $value (@values) {
1893                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1894                     Field   => $cf,
1895                     ValueId => $value,
1896                 );
1897                 push( @results, $msg );
1898             }
1899         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1900             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1901
1902             my %values_hash;
1903             foreach my $value (@values) {
1904                 if ( my $entry = $cf_values->HasEntry($value) ) {
1905                     $values_hash{ $entry->id } = 1;
1906                     next;
1907                 }
1908
1909                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1910                     Field => $cf,
1911                     Value => $value
1912                 );
1913                 push( @results, $msg );
1914                 $values_hash{$val} = 1 if $val;
1915             }
1916
1917             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1918             return @results if ( $cf->Type eq 'Date' && ! @values );
1919
1920             $cf_values->RedoSearch;
1921             while ( my $cf_value = $cf_values->Next ) {
1922                 next if $values_hash{ $cf_value->id };
1923
1924                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1925                     Field   => $cf,
1926                     ValueId => $cf_value->id
1927                 );
1928                 push( @results, $msg );
1929             }
1930         } elsif ( $arg eq 'Values' ) {
1931             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1932
1933             # keep everything up to the point of difference, delete the rest
1934             my $delete_flag;
1935             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1936                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1937                     shift @values;
1938                     next;
1939                 }
1940
1941                 $delete_flag ||= 1;
1942                 $old_cf->Delete;
1943             }
1944
1945             # now add/replace extra things, if any
1946             foreach my $value (@values) {
1947                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1948                     Field => $cf,
1949                     Value => $value
1950                 );
1951                 push( @results, $msg );
1952             }
1953         } else {
1954             push(
1955                 @results,
1956                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1957                     $cf->Name, ref $args{'Object'},
1958                     $args{'Object'}->id
1959                 )
1960             );
1961         }
1962     }
1963     return @results;
1964 }
1965
1966 # {{{ sub ProcessTicketWatchers
1967
1968 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1969
1970 Returns an array of results messages.
1971
1972 =cut
1973
1974 sub ProcessTicketWatchers {
1975     my %args = (
1976         TicketObj => undef,
1977         ARGSRef   => undef,
1978         @_
1979     );
1980     my (@results);
1981
1982     my $Ticket  = $args{'TicketObj'};
1983     my $ARGSRef = $args{'ARGSRef'};
1984
1985     # Munge watchers
1986
1987     foreach my $key ( keys %$ARGSRef ) {
1988
1989         # Delete deletable watchers
1990         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1991             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1992                 PrincipalId => $2,
1993                 Type        => $1
1994             );
1995             push @results, $msg;
1996         }
1997
1998         # Delete watchers in the simple style demanded by the bulk manipulator
1999         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2000             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2001                 Email => $ARGSRef->{$key},
2002                 Type  => $1
2003             );
2004             push @results, $msg;
2005         }
2006
2007         # Add new wathchers by email address
2008         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2009             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2010         {
2011
2012             #They're in this order because otherwise $1 gets clobbered :/
2013             my ( $code, $msg ) = $Ticket->AddWatcher(
2014                 Type  => $ARGSRef->{$key},
2015                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2016             );
2017             push @results, $msg;
2018         }
2019
2020         #Add requestors in the simple style demanded by the bulk manipulator
2021         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2022             my ( $code, $msg ) = $Ticket->AddWatcher(
2023                 Type  => $1,
2024                 Email => $ARGSRef->{$key}
2025             );
2026             push @results, $msg;
2027         }
2028
2029         # Add new  watchers by owner
2030         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2031             my $principal_id = $1;
2032             my $form         = $ARGSRef->{$key};
2033             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2034                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2035
2036                 my ( $code, $msg ) = $Ticket->AddWatcher(
2037                     Type        => $value,
2038                     PrincipalId => $principal_id
2039                 );
2040                 push @results, $msg;
2041             }
2042         }
2043
2044     }
2045     return (@results);
2046 }
2047
2048 # }}}
2049
2050 # {{{ sub ProcessTicketDates
2051
2052 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2053
2054 Returns an array of results messages.
2055
2056 =cut
2057
2058 sub ProcessTicketDates {
2059     my %args = (
2060         TicketObj => undef,
2061         ARGSRef   => undef,
2062         @_
2063     );
2064
2065     my $Ticket  = $args{'TicketObj'};
2066     my $ARGSRef = $args{'ARGSRef'};
2067
2068     my (@results);
2069
2070     # {{{ Set date fields
2071     my @date_fields = qw(
2072         Told
2073         Resolved
2074         Starts
2075         Started
2076         Due
2077     );
2078
2079     #Run through each field in this list. update the value if apropriate
2080     foreach my $field (@date_fields) {
2081         next unless exists $ARGSRef->{ $field . '_Date' };
2082         next if $ARGSRef->{ $field . '_Date' } eq '';
2083
2084         my ( $code, $msg );
2085
2086         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2087         $DateObj->Set(
2088             Format => 'unknown',
2089             Value  => $ARGSRef->{ $field . '_Date' }
2090         );
2091
2092         my $obj = $field . "Obj";
2093         if (    ( defined $DateObj->Unix )
2094             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2095         {
2096             my $method = "Set$field";
2097             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2098             push @results, "$msg";
2099         }
2100     }
2101
2102     # }}}
2103     return (@results);
2104 }
2105
2106 # }}}
2107
2108 # {{{ sub ProcessTicketLinks
2109
2110 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2111
2112 Returns an array of results messages.
2113
2114 =cut
2115
2116 sub ProcessTicketLinks {
2117     my %args = (
2118         TicketObj => undef,
2119         ARGSRef   => undef,
2120         @_
2121     );
2122
2123     my $Ticket  = $args{'TicketObj'};
2124     my $ARGSRef = $args{'ARGSRef'};
2125
2126     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2127
2128     #Merge if we need to
2129     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2130         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2131         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2132         push @results, $msg;
2133     }
2134
2135     return (@results);
2136 }
2137
2138 # }}}
2139
2140 sub ProcessRecordLinks {
2141     my %args = (
2142         RecordObj => undef,
2143         ARGSRef   => undef,
2144         @_
2145     );
2146
2147     my $Record  = $args{'RecordObj'};
2148     my $ARGSRef = $args{'ARGSRef'};
2149
2150     my (@results);
2151
2152     # Delete links that are gone gone gone.
2153     foreach my $arg ( keys %$ARGSRef ) {
2154         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2155             my $base   = $1;
2156             my $type   = $2;
2157             my $target = $3;
2158
2159             my ( $val, $msg ) = $Record->DeleteLink(
2160                 Base   => $base,
2161                 Type   => $type,
2162                 Target => $target
2163             );
2164
2165             push @results, $msg;
2166
2167         }
2168
2169     }
2170
2171     my @linktypes = qw( DependsOn MemberOf RefersTo );
2172
2173     foreach my $linktype (@linktypes) {
2174         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2175             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2176                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2177
2178             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2179                 next unless $luri;
2180                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2181                 my ( $val, $msg ) = $Record->AddLink(
2182                     Target => $luri,
2183                     Type   => $linktype
2184                 );
2185                 push @results, $msg;
2186             }
2187         }
2188         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2189             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2190                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2191
2192             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2193                 next unless $luri;
2194                 my ( $val, $msg ) = $Record->AddLink(
2195                     Base => $luri,
2196                     Type => $linktype
2197                 );
2198
2199                 push @results, $msg;
2200             }
2201         }
2202     }
2203
2204     return (@results);
2205 }
2206
2207 =head2 _UploadedFile ( $arg );
2208
2209 Takes a CGI parameter name; if a file is uploaded under that name,
2210 return a hash reference suitable for AddCustomFieldValue's use:
2211 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2212
2213 Returns C<undef> if no files were uploaded in the C<$arg> field.
2214
2215 =cut
2216
2217 sub _UploadedFile {
2218     my $arg         = shift;
2219     my $cgi_object  = $m->cgi_object;
2220     my $fh          = $cgi_object->upload($arg) or return undef;
2221     my $upload_info = $cgi_object->uploadInfo($fh);
2222
2223     my $filename = "$fh";
2224     $filename =~ s#^.*[\\/]##;
2225     binmode($fh);
2226
2227     return {
2228         Value        => $filename,
2229         LargeContent => do { local $/; scalar <$fh> },
2230         ContentType  => $upload_info->{'Content-Type'},
2231     };
2232 }
2233
2234 sub GetColumnMapEntry {
2235     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2236
2237     # deal with the simplest thing first
2238     if ( $args{'Map'}{ $args{'Name'} } ) {
2239         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2240     }
2241
2242     # complex things
2243     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2244         return undef unless $args{'Map'}->{$mainkey};
2245         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2246             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2247
2248         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2249     }
2250     return undef;
2251 }
2252
2253 sub ProcessColumnMapValue {
2254     my $value = shift;
2255     my %args = ( Arguments => [], Escape => 1, @_ );
2256
2257     if ( ref $value ) {
2258         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2259             my @tmp = $value->( @{ $args{'Arguments'} } );
2260             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2261         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2262             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2263         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2264             return $$value;
2265         }
2266     }
2267
2268     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2269     return $value;
2270 }
2271
2272 =head2 _load_container_object ( $type, $id );
2273
2274 Instantiate container object for saving searches.
2275
2276 =cut
2277
2278 sub _load_container_object {
2279     my ( $obj_type, $obj_id ) = @_;
2280     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2281 }
2282
2283 =head2 _parse_saved_search ( $arg );
2284
2285 Given a serialization string for saved search, and returns the
2286 container object and the search id.
2287
2288 =cut
2289
2290 sub _parse_saved_search {
2291     my $spec = shift;
2292     return unless $spec;
2293     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2294         return;
2295     }
2296     my $obj_type  = $1;
2297     my $obj_id    = $2;
2298     my $search_id = $3;
2299
2300     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2301 }
2302
2303 package RT::Interface::Web;
2304 RT::Base->_ImportOverlays();
2305
2306 1;