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 %message_args = (
1338         CcMessageTo  => $cc,
1339         BccMessageTo => $bcc,
1340         Sign         => $args{ARGSRef}->{'Sign'},
1341         Encrypt      => $args{ARGSRef}->{'Encrypt'},
1342         MIMEObj      => $Message,
1343         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'}
1344     );
1345
1346     my @temp_squelch;
1347     foreach my $type (qw(Cc AdminCc)) {
1348         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1349             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1350             push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1351             push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1352         }
1353     }
1354     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1355             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1356             push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1357     }
1358
1359     if (@temp_squelch) {
1360         require RT::Action::SendEmail;
1361         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1362     }
1363
1364     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1365         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1366             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1367
1368             my $var   = ucfirst($1) . 'MessageTo';
1369             my $value = $2;
1370             if ( $message_args{$var} ) {
1371                 $message_args{$var} .= ", $value";
1372             } else {
1373                 $message_args{$var} = $value;
1374             }
1375         }
1376     }
1377
1378     my @results;
1379     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1380         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1381         push( @results, $Description );
1382         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1383     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1384         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1385         push( @results, $Description );
1386         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1387     } else {
1388         push( @results,
1389             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1390     }
1391     return @results;
1392 }
1393
1394 # }}}
1395
1396 # {{{ sub MakeMIMEEntity
1397
1398 =head2 MakeMIMEEntity PARAMHASH
1399
1400 Takes a paramhash Subject, Body and AttachmentFieldName.
1401
1402 Also takes Form, Cc and Type as optional paramhash keys.
1403
1404   Returns a MIME::Entity.
1405
1406 =cut
1407
1408 sub MakeMIMEEntity {
1409
1410     #TODO document what else this takes.
1411     my %args = (
1412         Subject             => undef,
1413         From                => undef,
1414         Cc                  => undef,
1415         Body                => undef,
1416         AttachmentFieldName => undef,
1417         Type                => undef,
1418         @_,
1419     );
1420     my $Message = MIME::Entity->build(
1421         Type    => 'multipart/mixed',
1422         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1423             grep defined $args{$_}, qw(Subject From Cc)
1424     );
1425
1426     if ( defined $args{'Body'} && length $args{'Body'} ) {
1427
1428         # Make the update content have no 'weird' newlines in it
1429         $args{'Body'} =~ s/\r\n/\n/gs;
1430
1431         $Message->attach(
1432             Type    => $args{'Type'} || 'text/plain',
1433             Charset => 'UTF-8',
1434             Data    => $args{'Body'},
1435         );
1436     }
1437
1438     if ( $args{'AttachmentFieldName'} ) {
1439
1440         my $cgi_object = $m->cgi_object;
1441
1442         if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1443
1444             my ( @content, $buffer );
1445             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1446                 push @content, $buffer;
1447             }
1448
1449             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1450
1451             # Prefer the cached name first over CGI.pm stringification.
1452             my $filename = $RT::Mason::CGI::Filename;
1453             $filename = "$filehandle" unless defined $filename;
1454             $filename = Encode::encode_utf8( $filename );
1455             $filename =~ s{^.*[\\/]}{};
1456
1457             $Message->attach(
1458                 Type     => $uploadinfo->{'Content-Type'},
1459                 Filename => $filename,
1460                 Data     => \@content,
1461             );
1462             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1463                 $Message->head->set( 'Subject' => $filename );
1464             }
1465         }
1466     }
1467
1468     $Message->make_singlepart;
1469
1470     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1471
1472     return ($Message);
1473
1474 }
1475
1476 # }}}
1477
1478 # {{{ sub ParseDateToISO
1479
1480 =head2 ParseDateToISO
1481
1482 Takes a date in an arbitrary format.
1483 Returns an ISO date and time in GMT
1484
1485 =cut
1486
1487 sub ParseDateToISO {
1488     my $date = shift;
1489
1490     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1491     $date_obj->Set(
1492         Format => 'unknown',
1493         Value  => $date
1494     );
1495     return ( $date_obj->ISO );
1496 }
1497
1498 # }}}
1499
1500 # {{{ sub ProcessACLChanges
1501
1502 sub ProcessACLChanges {
1503     my $ARGSref = shift;
1504
1505     #XXX: why don't we get ARGSref like in other Process* subs?
1506
1507     my @results;
1508
1509     foreach my $arg ( keys %$ARGSref ) {
1510         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1511
1512         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1513
1514         my @rights;
1515         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1516             @rights = @{ $ARGSref->{$arg} };
1517         } else {
1518             @rights = $ARGSref->{$arg};
1519         }
1520         @rights = grep $_, @rights;
1521         next unless @rights;
1522
1523         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1524         $principal->Load($principal_id);
1525
1526         my $obj;
1527         if ( $object_type eq 'RT::System' ) {
1528             $obj = $RT::System;
1529         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1530             $obj = $object_type->new( $session{'CurrentUser'} );
1531             $obj->Load($object_id);
1532             unless ( $obj->id ) {
1533                 $RT::Logger->error("couldn't load $object_type #$object_id");
1534                 next;
1535             }
1536         } else {
1537             $RT::Logger->error("object type '$object_type' is incorrect");
1538             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1539             next;
1540         }
1541
1542         foreach my $right (@rights) {
1543             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1544             push( @results, $msg );
1545         }
1546     }
1547
1548     return (@results);
1549 }
1550
1551 # }}}
1552
1553 # {{{ sub UpdateRecordObj
1554
1555 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1556
1557 @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.
1558
1559 Returns an array of success/failure messages
1560
1561 =cut
1562
1563 sub UpdateRecordObject {
1564     my %args = (
1565         ARGSRef         => undef,
1566         AttributesRef   => undef,
1567         Object          => undef,
1568         AttributePrefix => undef,
1569         @_
1570     );
1571
1572     my $Object  = $args{'Object'};
1573     my @results = $Object->Update(
1574         AttributesRef   => $args{'AttributesRef'},
1575         ARGSRef         => $args{'ARGSRef'},
1576         AttributePrefix => $args{'AttributePrefix'},
1577     );
1578
1579     return (@results);
1580 }
1581
1582 # }}}
1583
1584 # {{{ Sub ProcessCustomFieldUpdates
1585
1586 sub ProcessCustomFieldUpdates {
1587     my %args = (
1588         CustomFieldObj => undef,
1589         ARGSRef        => undef,
1590         @_
1591     );
1592
1593     my $Object  = $args{'CustomFieldObj'};
1594     my $ARGSRef = $args{'ARGSRef'};
1595
1596     my @attribs = qw(Name Type Description Queue SortOrder);
1597     my @results = UpdateRecordObject(
1598         AttributesRef => \@attribs,
1599         Object        => $Object,
1600         ARGSRef       => $ARGSRef
1601     );
1602
1603     my $prefix = "CustomField-" . $Object->Id;
1604     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1605         my ( $addval, $addmsg ) = $Object->AddValue(
1606             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1607             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1608             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1609         );
1610         push( @results, $addmsg );
1611     }
1612
1613     my @delete_values
1614         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1615         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1616         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1617
1618     foreach my $id (@delete_values) {
1619         next unless defined $id;
1620         my ( $err, $msg ) = $Object->DeleteValue($id);
1621         push( @results, $msg );
1622     }
1623
1624     my $vals = $Object->Values();
1625     while ( my $cfv = $vals->Next() ) {
1626         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1627             if ( $cfv->SortOrder != $so ) {
1628                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1629                 push( @results, $msg );
1630             }
1631         }
1632     }
1633
1634     return (@results);
1635 }
1636
1637 # }}}
1638
1639 # {{{ sub ProcessTicketBasics
1640
1641 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1642
1643 Returns an array of results messages.
1644
1645 =cut
1646
1647 sub ProcessTicketBasics {
1648
1649     my %args = (
1650         TicketObj => undef,
1651         ARGSRef   => undef,
1652         @_
1653     );
1654
1655     my $TicketObj = $args{'TicketObj'};
1656     my $ARGSRef   = $args{'ARGSRef'};
1657
1658     # {{{ Set basic fields
1659     my @attribs = qw(
1660         Subject
1661         FinalPriority
1662         Priority
1663         TimeEstimated
1664         TimeWorked
1665         TimeLeft
1666         Type
1667         Status
1668         Queue
1669     );
1670
1671     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1672         my $tempqueue = RT::Queue->new($RT::SystemUser);
1673         $tempqueue->Load( $ARGSRef->{'Queue'} );
1674         if ( $tempqueue->id ) {
1675             $ARGSRef->{'Queue'} = $tempqueue->id;
1676         }
1677     }
1678
1679     # Status isn't a field that can be set to a null value.
1680     # RT core complains if you try
1681     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1682
1683     my @results = UpdateRecordObject(
1684         AttributesRef => \@attribs,
1685         Object        => $TicketObj,
1686         ARGSRef       => $ARGSRef,
1687     );
1688
1689     # We special case owner changing, so we can use ForceOwnerChange
1690     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1691         my ($ChownType);
1692         if ( $ARGSRef->{'ForceOwnerChange'} ) {
1693             $ChownType = "Force";
1694         } else {
1695             $ChownType = "Give";
1696         }
1697
1698         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1699         push( @results, $msg );
1700     }
1701
1702     # }}}
1703
1704     return (@results);
1705 }
1706
1707 # }}}
1708
1709 sub ProcessTicketCustomFieldUpdates {
1710     my %args = @_;
1711     $args{'Object'} = delete $args{'TicketObj'};
1712     my $ARGSRef = { %{ $args{'ARGSRef'} } };
1713
1714     # Build up a list of objects that we want to work with
1715     my %custom_fields_to_mod;
1716     foreach my $arg ( keys %$ARGSRef ) {
1717         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1718             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1719         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1720             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1721         }
1722     }
1723
1724     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1725 }
1726
1727 sub ProcessObjectCustomFieldUpdates {
1728     my %args    = @_;
1729     my $ARGSRef = $args{'ARGSRef'};
1730     my @results;
1731
1732     # Build up a list of objects that we want to work with
1733     my %custom_fields_to_mod;
1734     foreach my $arg ( keys %$ARGSRef ) {
1735
1736         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1737         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1738
1739         # For each of those objects, find out what custom fields we want to work with.
1740         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1741     }
1742
1743     # For each of those objects
1744     foreach my $class ( keys %custom_fields_to_mod ) {
1745         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1746             my $Object = $args{'Object'};
1747             $Object = $class->new( $session{'CurrentUser'} )
1748                 unless $Object && ref $Object eq $class;
1749
1750             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1751             unless ( $Object->id ) {
1752                 $RT::Logger->warning("Couldn't load object $class #$id");
1753                 next;
1754             }
1755
1756             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1757                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1758                 $CustomFieldObj->LoadById($cf);
1759                 unless ( $CustomFieldObj->id ) {
1760                     $RT::Logger->warning("Couldn't load custom field #$cf");
1761                     next;
1762                 }
1763                 push @results,
1764                     _ProcessObjectCustomFieldUpdates(
1765                     Prefix      => "Object-$class-$id-CustomField-$cf-",
1766                     Object      => $Object,
1767                     CustomField => $CustomFieldObj,
1768                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
1769                     );
1770             }
1771         }
1772     }
1773     return @results;
1774 }
1775
1776 sub _ProcessObjectCustomFieldUpdates {
1777     my %args    = @_;
1778     my $cf      = $args{'CustomField'};
1779     my $cf_type = $cf->Type;
1780
1781     # Remove blank Values since the magic field will take care of this. Sometimes
1782     # the browser gives you a blank value which causes CFs to be processed twice
1783     if (   defined $args{'ARGS'}->{'Values'}
1784         && !length $args{'ARGS'}->{'Values'}
1785         && $args{'ARGS'}->{'Values-Magic'} )
1786     {
1787         delete $args{'ARGS'}->{'Values'};
1788     }
1789
1790     my @results;
1791     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1792
1793         # skip category argument
1794         next if $arg eq 'Category';
1795
1796         # since http won't pass in a form element with a null value, we need
1797         # to fake it
1798         if ( $arg eq 'Values-Magic' ) {
1799
1800             # We don't care about the magic, if there's really a values element;
1801             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
1802             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1803
1804             # "Empty" values does not mean anything for Image and Binary fields
1805             next if $cf_type =~ /^(?:Image|Binary)$/;
1806
1807             $arg = 'Values';
1808             $args{'ARGS'}->{'Values'} = undef;
1809         }
1810
1811         my @values = ();
1812         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1813             @values = @{ $args{'ARGS'}->{$arg} };
1814         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
1815             @values = ( $args{'ARGS'}->{$arg} );
1816         } else {
1817             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1818                 if defined $args{'ARGS'}->{$arg};
1819         }
1820         @values = grep length, map {
1821             s/\r+\n/\n/g;
1822             s/^\s+//;
1823             s/\s+$//;
1824             $_;
1825             }
1826             grep defined, @values;
1827
1828         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1829             foreach my $value (@values) {
1830                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1831                     Field => $cf->id,
1832                     Value => $value
1833                 );
1834                 push( @results, $msg );
1835             }
1836         } elsif ( $arg eq 'Upload' ) {
1837             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1838             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1839             push( @results, $msg );
1840         } elsif ( $arg eq 'DeleteValues' ) {
1841             foreach my $value (@values) {
1842                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1843                     Field => $cf,
1844                     Value => $value,
1845                 );
1846                 push( @results, $msg );
1847             }
1848         } elsif ( $arg eq 'DeleteValueIds' ) {
1849             foreach my $value (@values) {
1850                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1851                     Field   => $cf,
1852                     ValueId => $value,
1853                 );
1854                 push( @results, $msg );
1855             }
1856         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1857             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1858
1859             my %values_hash;
1860             foreach my $value (@values) {
1861                 if ( my $entry = $cf_values->HasEntry($value) ) {
1862                     $values_hash{ $entry->id } = 1;
1863                     next;
1864                 }
1865
1866                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1867                     Field => $cf,
1868                     Value => $value
1869                 );
1870                 push( @results, $msg );
1871                 $values_hash{$val} = 1 if $val;
1872             }
1873
1874             $cf_values->RedoSearch;
1875             while ( my $cf_value = $cf_values->Next ) {
1876                 next if $values_hash{ $cf_value->id };
1877
1878                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1879                     Field   => $cf,
1880                     ValueId => $cf_value->id
1881                 );
1882                 push( @results, $msg );
1883             }
1884         } elsif ( $arg eq 'Values' ) {
1885             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1886
1887             # keep everything up to the point of difference, delete the rest
1888             my $delete_flag;
1889             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1890                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1891                     shift @values;
1892                     next;
1893                 }
1894
1895                 $delete_flag ||= 1;
1896                 $old_cf->Delete;
1897             }
1898
1899             # now add/replace extra things, if any
1900             foreach my $value (@values) {
1901                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1902                     Field => $cf,
1903                     Value => $value
1904                 );
1905                 push( @results, $msg );
1906             }
1907         } else {
1908             push(
1909                 @results,
1910                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1911                     $cf->Name, ref $args{'Object'},
1912                     $args{'Object'}->id
1913                 )
1914             );
1915         }
1916     }
1917     return @results;
1918 }
1919
1920 # {{{ sub ProcessTicketWatchers
1921
1922 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1923
1924 Returns an array of results messages.
1925
1926 =cut
1927
1928 sub ProcessTicketWatchers {
1929     my %args = (
1930         TicketObj => undef,
1931         ARGSRef   => undef,
1932         @_
1933     );
1934     my (@results);
1935
1936     my $Ticket  = $args{'TicketObj'};
1937     my $ARGSRef = $args{'ARGSRef'};
1938
1939     # Munge watchers
1940
1941     foreach my $key ( keys %$ARGSRef ) {
1942
1943         # Delete deletable watchers
1944         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1945             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1946                 PrincipalId => $2,
1947                 Type        => $1
1948             );
1949             push @results, $msg;
1950         }
1951
1952         # Delete watchers in the simple style demanded by the bulk manipulator
1953         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1954             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1955                 Email => $ARGSRef->{$key},
1956                 Type  => $1
1957             );
1958             push @results, $msg;
1959         }
1960
1961         # Add new wathchers by email address
1962         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1963             and $key =~ /^WatcherTypeEmail(\d*)$/ )
1964         {
1965
1966             #They're in this order because otherwise $1 gets clobbered :/
1967             my ( $code, $msg ) = $Ticket->AddWatcher(
1968                 Type  => $ARGSRef->{$key},
1969                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1970             );
1971             push @results, $msg;
1972         }
1973
1974         #Add requestors in the simple style demanded by the bulk manipulator
1975         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1976             my ( $code, $msg ) = $Ticket->AddWatcher(
1977                 Type  => $1,
1978                 Email => $ARGSRef->{$key}
1979             );
1980             push @results, $msg;
1981         }
1982
1983         # Add new  watchers by owner
1984         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1985             my $principal_id = $1;
1986             my $form         = $ARGSRef->{$key};
1987             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1988                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1989
1990                 my ( $code, $msg ) = $Ticket->AddWatcher(
1991                     Type        => $value,
1992                     PrincipalId => $principal_id
1993                 );
1994                 push @results, $msg;
1995             }
1996         }
1997
1998     }
1999     return (@results);
2000 }
2001
2002 # }}}
2003
2004 # {{{ sub ProcessTicketDates
2005
2006 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2007
2008 Returns an array of results messages.
2009
2010 =cut
2011
2012 sub ProcessTicketDates {
2013     my %args = (
2014         TicketObj => undef,
2015         ARGSRef   => undef,
2016         @_
2017     );
2018
2019     my $Ticket  = $args{'TicketObj'};
2020     my $ARGSRef = $args{'ARGSRef'};
2021
2022     my (@results);
2023
2024     # {{{ Set date fields
2025     my @date_fields = qw(
2026         Told
2027         Resolved
2028         Starts
2029         Started
2030         Due
2031     );
2032
2033     #Run through each field in this list. update the value if apropriate
2034     foreach my $field (@date_fields) {
2035         next unless exists $ARGSRef->{ $field . '_Date' };
2036         next if $ARGSRef->{ $field . '_Date' } eq '';
2037
2038         my ( $code, $msg );
2039
2040         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2041         $DateObj->Set(
2042             Format => 'unknown',
2043             Value  => $ARGSRef->{ $field . '_Date' }
2044         );
2045
2046         my $obj = $field . "Obj";
2047         if (    ( defined $DateObj->Unix )
2048             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2049         {
2050             my $method = "Set$field";
2051             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2052             push @results, "$msg";
2053         }
2054     }
2055
2056     # }}}
2057     return (@results);
2058 }
2059
2060 # }}}
2061
2062 # {{{ sub ProcessTicketLinks
2063
2064 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2065
2066 Returns an array of results messages.
2067
2068 =cut
2069
2070 sub ProcessTicketLinks {
2071     my %args = (
2072         TicketObj => undef,
2073         ARGSRef   => undef,
2074         @_
2075     );
2076
2077     my $Ticket  = $args{'TicketObj'};
2078     my $ARGSRef = $args{'ARGSRef'};
2079
2080     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2081
2082     #Merge if we need to
2083     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2084         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2085         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2086         push @results, $msg;
2087     }
2088
2089     return (@results);
2090 }
2091
2092 # }}}
2093
2094 sub ProcessRecordLinks {
2095     my %args = (
2096         RecordObj => undef,
2097         ARGSRef   => undef,
2098         @_
2099     );
2100
2101     my $Record  = $args{'RecordObj'};
2102     my $ARGSRef = $args{'ARGSRef'};
2103
2104     my (@results);
2105
2106     # Delete links that are gone gone gone.
2107     foreach my $arg ( keys %$ARGSRef ) {
2108         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2109             my $base   = $1;
2110             my $type   = $2;
2111             my $target = $3;
2112
2113             my ( $val, $msg ) = $Record->DeleteLink(
2114                 Base   => $base,
2115                 Type   => $type,
2116                 Target => $target
2117             );
2118
2119             push @results, $msg;
2120
2121         }
2122
2123     }
2124
2125     my @linktypes = qw( DependsOn MemberOf RefersTo );
2126
2127     foreach my $linktype (@linktypes) {
2128         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2129             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2130                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2131
2132             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2133                 next unless $luri;
2134                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2135                 my ( $val, $msg ) = $Record->AddLink(
2136                     Target => $luri,
2137                     Type   => $linktype
2138                 );
2139                 push @results, $msg;
2140             }
2141         }
2142         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2143             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2144                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2145
2146             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2147                 next unless $luri;
2148                 my ( $val, $msg ) = $Record->AddLink(
2149                     Base => $luri,
2150                     Type => $linktype
2151                 );
2152
2153                 push @results, $msg;
2154             }
2155         }
2156     }
2157
2158     return (@results);
2159 }
2160
2161 =head2 _UploadedFile ( $arg );
2162
2163 Takes a CGI parameter name; if a file is uploaded under that name,
2164 return a hash reference suitable for AddCustomFieldValue's use:
2165 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2166
2167 Returns C<undef> if no files were uploaded in the C<$arg> field.
2168
2169 =cut
2170
2171 sub _UploadedFile {
2172     my $arg         = shift;
2173     my $cgi_object  = $m->cgi_object;
2174     my $fh          = $cgi_object->upload($arg) or return undef;
2175     my $upload_info = $cgi_object->uploadInfo($fh);
2176
2177     my $filename = "$fh";
2178     $filename =~ s#^.*[\\/]##;
2179     binmode($fh);
2180
2181     return {
2182         Value        => $filename,
2183         LargeContent => do { local $/; scalar <$fh> },
2184         ContentType  => $upload_info->{'Content-Type'},
2185     };
2186 }
2187
2188 sub GetColumnMapEntry {
2189     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2190
2191     # deal with the simplest thing first
2192     if ( $args{'Map'}{ $args{'Name'} } ) {
2193         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2194     }
2195
2196     # complex things
2197     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2198         return undef unless $args{'Map'}->{$mainkey};
2199         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2200             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2201
2202         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2203     }
2204     return undef;
2205 }
2206
2207 sub ProcessColumnMapValue {
2208     my $value = shift;
2209     my %args = ( Arguments => [], Escape => 1, @_ );
2210
2211     if ( ref $value ) {
2212         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2213             my @tmp = $value->( @{ $args{'Arguments'} } );
2214             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2215         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2216             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2217         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2218             return $$value;
2219         }
2220     }
2221
2222     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2223     return $value;
2224 }
2225
2226 =head2 _load_container_object ( $type, $id );
2227
2228 Instantiate container object for saving searches.
2229
2230 =cut
2231
2232 sub _load_container_object {
2233     my ( $obj_type, $obj_id ) = @_;
2234     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2235 }
2236
2237 =head2 _parse_saved_search ( $arg );
2238
2239 Given a serialization string for saved search, and returns the
2240 container object and the search id.
2241
2242 =cut
2243
2244 sub _parse_saved_search {
2245     my $spec = shift;
2246     return unless $spec;
2247     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2248         return;
2249     }
2250     my $obj_type  = $1;
2251     my $obj_id    = $2;
2252     my $search_id = $3;
2253
2254     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2255 }
2256
2257 eval "require RT::Interface::Web_Vendor";
2258 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2259 eval "require RT::Interface::Web_Local";
2260 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );
2261
2262 1;