rt/lib/RT/Interface/Web.pm

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