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