rt/lib/RT/Interface/Web.pm

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