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