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         -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
 665     );
 666
 667     $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
 668 }
 669
 670 =head2 Redirect URL
 671
 672 This routine ells the current user's browser to redirect to URL.
 673 Additionally, it unties the user's currently active session, helping to avoid
 674 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
 675 a cached DBI statement handle twice at the same time.
 676
 677 =cut
 678
 679 sub Redirect {
 680     my $redir_to = shift;
 681     untie $HTML::Mason::Commands::session;
 682     my $uri        = URI->new($redir_to);
 683     my $server_uri = URI->new( RT->Config->Get('WebURL') );
 684
 685     # Make relative URIs absolute from the server host and scheme
 686     $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
 687     if (not defined $uri->host) {
 688         $uri->host($server_uri->host);
 689         $uri->port($server_uri->port);
 690     }
 691
 692     # If the user is coming in via a non-canonical
 693     # hostname, don't redirect them to the canonical host,
 694     # it will just upset them (and invalidate their credentials)
 695     # don't do this if $RT::CanoniaclRedirectURLs is true
 696     if (   !RT->Config->Get('CanonicalizeRedirectURLs')
 697         && $uri->host eq $server_uri->host
 698         && $uri->port eq $server_uri->port )
 699     {
 700         if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
 701             $uri->scheme('https');
 702         } else {
 703             $uri->scheme('http');
 704         }
 705
 706         # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
 707         $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
 708         $uri->port( $ENV{'SERVER_PORT'} );
 709     }
 710
 711     # not sure why, but on some systems without this call mason doesn't
 712     # set status to 302, but 200 instead and people see blank pages
 713     $HTML::Mason::Commands::r->status(302);
 714
 715     # Perlbal expects a status message, but Mason's default redirect status
 716     # doesn't provide one. See also rt.cpan.org #36689.
 717     $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
 718
 719     $HTML::Mason::Commands::m->abort;
 720 }
 721
 722 =head2 StaticFileHeaders
 723
 724 Send the browser a few headers to try to get it to (somewhat agressively)
 725 cache RT's static Javascript and CSS files.
 726
 727 This routine could really use _accurate_ heuristics. (XXX TODO)
 728
 729 =cut
 730
 731 sub StaticFileHeaders {
 732     my $date = RT::Date->new($RT::SystemUser);
 733
 734     # make cache public
 735     $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
 736
 737     # Expire things in a month.
 738     $date->Set( Value => time + 30 * 24 * 60 * 60 );
 739     $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
 740
 741     # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
 742     # request, but we don't handle it and generate full reply again
 743     # Last modified at server start time
 744     # $date->Set( Value => $^T );
 745     # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
 746 }
 747
 748 =head2 PathIsSafe
 749
 750 Takes a C<< Path => path >> and returns a boolean indicating that
 751 the path is safely within RT's control or not. The path I<must> be
 752 relative.
 753
 754 This function does not consult the filesystem at all; it is merely
 755 a logical sanity checking of the path. This explicitly does not handle
 756 symlinks; if you have symlinks in RT's webroot pointing outside of it,
 757 then we assume you know what you are doing.
 758
 759 =cut
 760
 761 sub PathIsSafe {
 762     my $self = shift;
 763     my %args = @_;
 764     my $path = $args{Path};
 765
 766     # Get File::Spec to clean up extra /s, ./, etc
 767     my $cleaned_up = File::Spec->canonpath($path);
 768
 769     if (!defined($cleaned_up)) {
 770         $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
 771         return 0;
 772     }
 773
 774     # Forbid too many ..s. We can't just sum then check because
 775     # "../foo/bar/baz" should be illegal even though it has more
 776     # downdirs than updirs. So as soon as we get a negative score
 777     # (which means "breaking out" of the top level) we reject the path.
 778
 779     my @components = split '/', $cleaned_up;
 780     my $score = 0;
 781     for my $component (@components) {
 782         if ($component eq '..') {
 783             $score--;
 784             if ($score < 0) {
 785                 $RT::Logger->info("Rejecting unsafe path: $path");
 786                 return 0;
 787             }
 788         }
 789         elsif ($component eq '.' || $component eq '') {
 790             # these two have no effect on $score
 791         }
 792         else {
 793             $score++;
 794         }
 795     }
 796
 797     return 1;
 798 }
 799
 800 =head2 SendStaticFile
 801
 802 Takes a File => path and a Type => Content-type
 803
 804 If Type isn't provided and File is an image, it will
 805 figure out a sane Content-type, otherwise it will
 806 send application/octet-stream
 807
 808 Will set caching headers using StaticFileHeaders
 809
 810 =cut
 811
 812 sub SendStaticFile {
 813     my $self = shift;
 814     my %args = @_;
 815     my $file = $args{File};
 816     my $type = $args{Type};
 817     my $relfile = $args{RelativeFile};
 818
 819     if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
 820         $HTML::Mason::Commands::r->status(400);
 821         $HTML::Mason::Commands::m->abort;
 822     }
 823
 824     $self->StaticFileHeaders();
 825
 826     unless ($type) {
 827         if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
 828             $type = "image/$1";
 829             $type =~ s/jpg/jpeg/gi;
 830         }
 831         $type ||= "application/octet-stream";
 832     }
 833
 834     # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
 835     # since we don't specify a charset
 836     if ( $type =~ m{application/javascript} &&
 837          $type !~ m{charset=([\w-]+)$} ) {
 838          $type .= "; charset=utf-8";
 839     }
 840     $HTML::Mason::Commands::r->content_type($type);
 841     open( my $fh, '<', $file ) or die "couldn't open file: $!";
 842     binmode($fh);
 843     {
 844         local $/ = \16384;
 845         $HTML::Mason::Commands::m->out($_) while (<$fh>);
 846         $HTML::Mason::Commands::m->flush_buffer;
 847     }
 848     close $fh;
 849 }
 850
 851 sub StripContent {
 852     my %args    = @_;
 853     my $content = $args{Content};
 854     return '' unless $content;
 855
 856     # Make the content have no 'weird' newlines in it
 857     $content =~ s/\r+\n/\n/g;
 858
 859     my $return_content = $content;
 860
 861     my $html = $args{ContentType} && $args{ContentType} eq "text/html";
 862     my $sigonly = $args{StripSignature};
 863
 864     # massage content to easily detect if there's any real content
 865     $content =~ s/\s+//g; # yes! remove all the spaces
 866     if ( $html ) {
 867         # remove html version of spaces and newlines
 868         $content =~ s!&nbsp;!!g;
 869         $content =~ s!<br/?>!!g;
 870     }
 871
 872     # Filter empty content when type is text/html
 873     return '' if $html && $content !~ /\S/;
 874
 875     # If we aren't supposed to strip the sig, just bail now.
 876     return $return_content unless $sigonly;
 877
 878     # Find the signature
 879     my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
 880     $sig =~ s/\s+//g;
 881
 882     # Check for plaintext sig
 883     return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
 884
 885     # Check for html-formatted sig; we don't use EscapeUTF8 here
 886     # because we want to precisely match the escaping that FCKEditor
 887     # uses. see also 311223f5, which fixed this for 4.0
 888     $sig =~ s/&/&amp;/g;
 889     $sig =~ s/</&lt;/g;
 890     $sig =~ s/>/&gt;/g;
 891
 892     return ''
 893       if $html
 894           and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
 895
 896     # Pass it through
 897     return $return_content;
 898 }
 899
 900 sub DecodeARGS {
 901     my $ARGS = shift;
 902
 903     %{$ARGS} = map {
 904
 905         # if they've passed multiple values, they'll be an array. if they've
 906         # passed just one, a scalar whatever they are, mark them as utf8
 907         my $type = ref($_);
 908         ( !$type )
 909             ? Encode::is_utf8($_)
 910                 ? $_
 911                 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
 912             : ( $type eq 'ARRAY' )
 913             ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
 914                 @$_ ]
 915             : ( $type eq 'HASH' )
 916             ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
 917                 %$_ }
 918             : $_
 919     } %$ARGS;
 920 }
 921
 922 sub PreprocessTimeUpdates {
 923     my $ARGS = shift;
 924
 925     # Later in the code we use
 926     # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
 927     # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
 928     # The call_next method pass through original arguments and if you have
 929     # an argument with unicode key then in a next component you'll get two
 930     # records in the args hash: one with key without UTF8 flag and another
 931     # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
 932     # is copied from mason's source to get the same results as we get from
 933     # call_next method, this feature is not documented, so we just leave it
 934     # here to avoid possible side effects.
 935
 936     # This code canonicalizes time inputs in hours into minutes
 937     foreach my $field ( keys %$ARGS ) {
 938         next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
 939         my $local = $1;
 940         $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
 941                       {($1 || 0) + $3 ? $2 / $3 : 0}xe;
 942         if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
 943             $ARGS->{$local} *= 60;
 944         }
 945         delete $ARGS->{$field};
 946     }
 947
 948 }
 949
 950 sub MaybeEnableSQLStatementLog {
 951
 952     my $log_sql_statements = RT->Config->Get('StatementLog');
 953
 954     if ($log_sql_statements) {
 955         $RT::Handle->ClearSQLStatementLog;
 956         $RT::Handle->LogSQLStatements(1);
 957     }
 958
 959 }
 960
 961 sub LogRecordedSQLStatements {
 962     my $log_sql_statements = RT->Config->Get('StatementLog');
 963
 964     return unless ($log_sql_statements);
 965
 966     my @log = $RT::Handle->SQLStatementLog;
 967     $RT::Handle->ClearSQLStatementLog;
 968     for my $stmt (@log) {
 969         my ( $time, $sql, $bind, $duration ) = @{$stmt};
 970         my @bind;
 971         if ( ref $bind ) {
 972             @bind = @{$bind};
 973         } else {
 974
 975             # Older DBIx-SB
 976             $duration = $bind;
 977         }
 978         $RT::Logger->log(
 979             level   => $log_sql_statements,
 980             message => "SQL("
 981                 . sprintf( "%.6f", $duration )
 982                 . "s): $sql;"
 983                 . ( @bind ? "  [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
 984         );
 985     }
 986
 987 }
 988
 989 package HTML::Mason::Commands;
 990
 991 use vars qw/$r $m %session/;
 992
 993 # {{{ loc
 994
 995 =head2 loc ARRAY
 996
 997 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
 998 with whatever it's called with. If there is no $session{'CurrentUser'},
 999 it creates a temporary user, so we have something to get a localisation handle
1000 through
1001
1002 =cut
1003
1004 sub loc {
1005
1006     if ( $session{'CurrentUser'}
1007         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1008     {
1009         return ( $session{'CurrentUser'}->loc(@_) );
1010     } elsif (
1011         my $u = eval {
1012             RT::CurrentUser->new();
1013         }
1014         )
1015     {
1016         return ( $u->loc(@_) );
1017     } else {
1018
1019         # pathetic case -- SystemUser is gone.
1020         return $_[0];
1021     }
1022 }
1023
1024 # }}}
1025
1026 # {{{ loc_fuzzy
1027
1028 =head2 loc_fuzzy STRING
1029
1030 loc_fuzzy is for handling localizations of messages that may already
1031 contain interpolated variables, typically returned from libraries
1032 outside RT's control.  It takes the message string and extracts the
1033 variable array automatically by matching against the candidate entries
1034 inside the lexicon file.
1035
1036 =cut
1037
1038 sub loc_fuzzy {
1039     my $msg = shift;
1040
1041     if ( $session{'CurrentUser'}
1042         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1043     {
1044         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1045     } else {
1046         my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1047         return ( $u->loc_fuzzy($msg) );
1048     }
1049 }
1050
1051 # }}}
1052
1053 # {{{ sub Abort
1054 # Error - calls Error and aborts
1055 sub Abort {
1056     my $why  = shift;
1057     my %args = @_;
1058
1059     if (   $session{'ErrorDocument'}
1060         && $session{'ErrorDocumentType'} )
1061     {
1062         $r->content_type( $session{'ErrorDocumentType'} );
1063         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1064         $m->abort;
1065     } else {
1066         $m->comp( "/Elements/Error", Why => $why, %args );
1067         $m->abort;
1068     }
1069 }
1070
1071 # }}}
1072
1073 # {{{ sub CreateTicket
1074
1075 =head2 CreateTicket ARGS
1076
1077 Create a new ticket, using Mason's %ARGS.  returns @results.
1078
1079 =cut
1080
1081 sub CreateTicket {
1082     my %ARGS = (@_);
1083
1084     my (@Actions);
1085
1086     my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1087
1088     my $Queue = new RT::Queue( $session{'CurrentUser'} );
1089     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1090         Abort('Queue not found');
1091     }
1092
1093     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1094         Abort('You have no permission to create tickets in that queue.');
1095     }
1096
1097     my $due;
1098     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1099         $due = new RT::Date( $session{'CurrentUser'} );
1100         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1101     }
1102     my $starts;
1103     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1104         $starts = new RT::Date( $session{'CurrentUser'} );
1105         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1106     }
1107
1108     my $sigless = RT::Interface::Web::StripContent(
1109         Content        => $ARGS{Content},
1110         ContentType    => $ARGS{ContentType},
1111         StripSignature => 1,
1112         CurrentUser    => $session{'CurrentUser'},
1113     );
1114
1115     my $MIMEObj = MakeMIMEEntity(
1116         Subject => $ARGS{'Subject'},
1117         From    => $ARGS{'From'},
1118         Cc      => $ARGS{'Cc'},
1119         Body    => $sigless,
1120         Type    => $ARGS{'ContentType'},
1121     );
1122
1123     if ( $ARGS{'Attachments'} ) {
1124         my $rv = $MIMEObj->make_multipart;
1125         $RT::Logger->error("Couldn't make multipart message")
1126             if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1127
1128         foreach ( values %{ $ARGS{'Attachments'} } ) {
1129             unless ($_) {
1130                 $RT::Logger->error("Couldn't add empty attachemnt");
1131                 next;
1132             }
1133             $MIMEObj->add_part($_);
1134         }
1135     }
1136
1137     foreach my $argument (qw(Encrypt Sign)) {
1138         $MIMEObj->head->add(
1139             "X-RT-$argument" => Encode::encode_utf8( $ARGS{$argument} )
1140         ) if defined $ARGS{$argument};
1141     }
1142
1143     my %create_args = (
1144         Type => $ARGS{'Type'} || 'ticket',
1145         Queue => $ARGS{'Queue'},
1146         Owner => $ARGS{'Owner'},
1147
1148         # note: name change
1149         Requestor       => $ARGS{'Requestors'},
1150         Cc              => $ARGS{'Cc'},
1151         AdminCc         => $ARGS{'AdminCc'},
1152         InitialPriority => $ARGS{'InitialPriority'},
1153         FinalPriority   => $ARGS{'FinalPriority'},
1154         TimeLeft        => $ARGS{'TimeLeft'},
1155         TimeEstimated   => $ARGS{'TimeEstimated'},
1156         TimeWorked      => $ARGS{'TimeWorked'},
1157         Subject         => $ARGS{'Subject'},
1158         Status          => $ARGS{'Status'},
1159         Due             => $due ? $due->ISO : undef,
1160         Starts          => $starts ? $starts->ISO : undef,
1161         MIMEObj         => $MIMEObj
1162     );
1163
1164     my @temp_squelch;
1165     foreach my $type (qw(Requestor Cc AdminCc)) {
1166         push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1167             if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1168
1169     }
1170
1171     if (@temp_squelch) {
1172         require RT::Action::SendEmail;
1173         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1174     }
1175
1176     if ( $ARGS{'AttachTickets'} ) {
1177         require RT::Action::SendEmail;
1178         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1179             ref $ARGS{'AttachTickets'}
1180             ? @{ $ARGS{'AttachTickets'} }
1181             : ( $ARGS{'AttachTickets'} ) );
1182     }
1183
1184     foreach my $arg ( keys %ARGS ) {
1185         next if $arg =~ /-(?:Magic|Category)$/;
1186
1187         if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1188             $create_args{$arg} = $ARGS{$arg};
1189         }
1190
1191         # Object-RT::Ticket--CustomField-3-Values
1192         elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1193             my $cfid = $1;
1194
1195             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1196             $cf->Load($cfid);
1197             unless ( $cf->id ) {
1198                 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1199                 next;
1200             }
1201
1202             if ( $arg =~ /-Upload$/ ) {
1203                 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1204                 next;
1205             }
1206
1207             my $type = $cf->Type;
1208
1209             my @values = ();
1210             if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1211                 @values = @{ $ARGS{$arg} };
1212             } elsif ( $type =~ /text/i ) {
1213                 @values = ( $ARGS{$arg} );
1214             } else {
1215                 no warnings 'uninitialized';
1216                 @values = split /\r*\n/, $ARGS{$arg};
1217             }
1218             @values = grep length, map {
1219                 s/\r+\n/\n/g;
1220                 s/^\s+//;
1221                 s/\s+$//;
1222                 $_;
1223                 }
1224                 grep defined, @values;
1225
1226             $create_args{"CustomField-$cfid"} = \@values;
1227         }
1228     }
1229
1230     # turn new link lists into arrays, and pass in the proper arguments
1231     my %map = (
1232         'new-DependsOn' => 'DependsOn',
1233         'DependsOn-new' => 'DependedOnBy',
1234         'new-MemberOf'  => 'Parents',
1235         'MemberOf-new'  => 'Children',
1236         'new-RefersTo'  => 'RefersTo',
1237         'RefersTo-new'  => 'ReferredToBy',
1238     );
1239     foreach my $key ( keys %map ) {
1240         next unless $ARGS{$key};
1241         $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1242
1243     }
1244
1245     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1246     unless ($id) {
1247         Abort($ErrMsg);
1248     }
1249
1250     push( @Actions, split( "\n", $ErrMsg ) );
1251     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1252         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1253     }
1254     return ( $Ticket, @Actions );
1255
1256 }
1257
1258 # }}}
1259
1260 # {{{ sub LoadTicket - loads a ticket
1261
1262 =head2  LoadTicket id
1263
1264 Takes a ticket id as its only variable. if it's handed an array, it takes
1265 the first value.
1266
1267 Returns an RT::Ticket object as the current user.
1268
1269 =cut
1270
1271 sub LoadTicket {
1272     my $id = shift;
1273
1274     if ( ref($id) eq "ARRAY" ) {
1275         $id = $id->[0];
1276     }
1277
1278     unless ($id) {
1279         Abort("No ticket specified");
1280     }
1281
1282     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1283     $Ticket->Load($id);
1284     unless ( $Ticket->id ) {
1285         Abort("Could not load ticket $id");
1286     }
1287     return $Ticket;
1288 }
1289
1290 # }}}
1291
1292 # {{{ sub ProcessUpdateMessage
1293
1294 =head2 ProcessUpdateMessage
1295
1296 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1297
1298 Don't write message if it only contains current user's signature and
1299 SkipSignatureOnly argument is true. Function anyway adds attachments
1300 and updates time worked field even if skips message. The default value
1301 is true.
1302
1303 =cut
1304
1305 sub ProcessUpdateMessage {
1306
1307     my %args = (
1308         ARGSRef           => undef,
1309         TicketObj         => undef,
1310         SkipSignatureOnly => 1,
1311         @_
1312     );
1313
1314     if ( $args{ARGSRef}->{'UpdateAttachments'}
1315         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1316     {
1317         delete $args{ARGSRef}->{'UpdateAttachments'};
1318     }
1319
1320     # Strip the signature
1321     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1322         Content        => $args{ARGSRef}->{UpdateContent},
1323         ContentType    => $args{ARGSRef}->{UpdateContentType},
1324         StripSignature => $args{SkipSignatureOnly},
1325         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1326     );
1327
1328     # If, after stripping the signature, we have no message, move the
1329     # UpdateTimeWorked into adjusted TimeWorked, so that a later
1330     # ProcessBasics can deal -- then bail out.
1331     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1332         and not length $args{ARGSRef}->{'UpdateContent'} )
1333     {
1334         if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1335             $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1336         }
1337         return;
1338     }
1339
1340     if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1341         $args{ARGSRef}->{'UpdateSubject'} = undef;
1342     }
1343
1344     my $Message = MakeMIMEEntity(
1345         Subject => $args{ARGSRef}->{'UpdateSubject'},
1346         Body    => $args{ARGSRef}->{'UpdateContent'},
1347         Type    => $args{ARGSRef}->{'UpdateContentType'},
1348     );
1349
1350     $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1351         RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1352     ) );
1353     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1354     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1355         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1356     } else {
1357         $old_txn = $args{TicketObj}->Transactions->First();
1358     }
1359
1360     if ( my $msg = $old_txn->Message->First ) {
1361         RT::Interface::Email::SetInReplyTo(
1362             Message   => $Message,
1363             InReplyTo => $msg
1364         );
1365     }
1366
1367     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1368         $Message->make_multipart;
1369         $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1370     }
1371
1372     if ( $args{ARGSRef}->{'AttachTickets'} ) {
1373         require RT::Action::SendEmail;
1374         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1375             ref $args{ARGSRef}->{'AttachTickets'}
1376             ? @{ $args{ARGSRef}->{'AttachTickets'} }
1377             : ( $args{ARGSRef}->{'AttachTickets'} ) );
1378     }
1379
1380     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1381     my $cc  = $args{ARGSRef}->{'UpdateCc'};
1382
1383     my %message_args = (
1384         CcMessageTo  => $cc,
1385         BccMessageTo => $bcc,
1386         Sign         => $args{ARGSRef}->{'Sign'},
1387         Encrypt      => $args{ARGSRef}->{'Encrypt'},
1388         MIMEObj      => $Message,
1389         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'}
1390     );
1391
1392     my @temp_squelch;
1393     foreach my $type (qw(Cc AdminCc)) {
1394         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1395             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1396             push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1397             push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1398         }
1399     }
1400     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1401             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1402             push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1403     }
1404
1405     if (@temp_squelch) {
1406         require RT::Action::SendEmail;
1407         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1408     }
1409
1410     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1411         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1412             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1413
1414             my $var   = ucfirst($1) . 'MessageTo';
1415             my $value = $2;
1416             if ( $message_args{$var} ) {
1417                 $message_args{$var} .= ", $value";
1418             } else {
1419                 $message_args{$var} = $value;
1420             }
1421         }
1422     }
1423
1424     my @results;
1425     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1426         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1427         push( @results, $Description );
1428         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1429     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1430         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1431         push( @results, $Description );
1432         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1433     } else {
1434         push( @results,
1435             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1436     }
1437     return @results;
1438 }
1439
1440 # }}}
1441
1442 # {{{ sub MakeMIMEEntity
1443
1444 =head2 MakeMIMEEntity PARAMHASH
1445
1446 Takes a paramhash Subject, Body and AttachmentFieldName.
1447
1448 Also takes Form, Cc and Type as optional paramhash keys.
1449
1450   Returns a MIME::Entity.
1451
1452 =cut
1453
1454 sub MakeMIMEEntity {
1455
1456     #TODO document what else this takes.
1457     my %args = (
1458         Subject             => undef,
1459         From                => undef,
1460         Cc                  => undef,
1461         Body                => undef,
1462         AttachmentFieldName => undef,
1463         Type                => undef,
1464         @_,
1465     );
1466     my $Message = MIME::Entity->build(
1467         Type    => 'multipart/mixed',
1468         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1469             grep defined $args{$_}, qw(Subject From Cc)
1470     );
1471
1472     if ( defined $args{'Body'} && length $args{'Body'} ) {
1473
1474         # Make the update content have no 'weird' newlines in it
1475         $args{'Body'} =~ s/\r\n/\n/gs;
1476
1477         $Message->attach(
1478             Type    => $args{'Type'} || 'text/plain',
1479             Charset => 'UTF-8',
1480             Data    => $args{'Body'},
1481         );
1482     }
1483
1484     if ( $args{'AttachmentFieldName'} ) {
1485
1486         my $cgi_object = $m->cgi_object;
1487
1488         if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1489
1490             my ( @content, $buffer );
1491             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1492                 push @content, $buffer;
1493             }
1494
1495             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1496
1497             # Prefer the cached name first over CGI.pm stringification.
1498             my $filename = $RT::Mason::CGI::Filename;
1499             $filename = "$filehandle" unless defined $filename;
1500             $filename = Encode::encode_utf8( $filename );
1501             $filename =~ s{^.*[\\/]}{};
1502
1503             $Message->attach(
1504                 Type     => $uploadinfo->{'Content-Type'},
1505                 Filename => $filename,
1506                 Data     => \@content,
1507             );
1508             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1509                 $Message->head->set( 'Subject' => $filename );
1510             }
1511         }
1512     }
1513
1514     $Message->make_singlepart;
1515
1516     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1517
1518     return ($Message);
1519
1520 }
1521
1522 # }}}
1523
1524 # {{{ sub ParseDateToISO
1525
1526 =head2 ParseDateToISO
1527
1528 Takes a date in an arbitrary format.
1529 Returns an ISO date and time in GMT
1530
1531 =cut
1532
1533 sub ParseDateToISO {
1534     my $date = shift;
1535
1536     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1537     $date_obj->Set(
1538         Format => 'unknown',
1539         Value  => $date
1540     );
1541     return ( $date_obj->ISO );
1542 }
1543
1544 # }}}
1545
1546 # {{{ sub ProcessACLChanges
1547
1548 sub ProcessACLChanges {
1549     my $ARGSref = shift;
1550
1551     #XXX: why don't we get ARGSref like in other Process* subs?
1552
1553     my @results;
1554
1555     foreach my $arg ( keys %$ARGSref ) {
1556         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1557
1558         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1559
1560         my @rights;
1561         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1562             @rights = @{ $ARGSref->{$arg} };
1563         } else {
1564             @rights = $ARGSref->{$arg};
1565         }
1566         @rights = grep $_, @rights;
1567         next unless @rights;
1568
1569         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1570         $principal->Load($principal_id);
1571
1572         my $obj;
1573         if ( $object_type eq 'RT::System' ) {
1574             $obj = $RT::System;
1575         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1576             $obj = $object_type->new( $session{'CurrentUser'} );
1577             $obj->Load($object_id);
1578             unless ( $obj->id ) {
1579                 $RT::Logger->error("couldn't load $object_type #$object_id");
1580                 next;
1581             }
1582         } else {
1583             $RT::Logger->error("object type '$object_type' is incorrect");
1584             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1585             next;
1586         }
1587
1588         foreach my $right (@rights) {
1589             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1590             push( @results, $msg );
1591         }
1592     }
1593
1594     return (@results);
1595 }
1596
1597 # }}}
1598
1599 # {{{ sub UpdateRecordObj
1600
1601 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1602
1603 @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.
1604
1605 Returns an array of success/failure messages
1606
1607 =cut
1608
1609 sub UpdateRecordObject {
1610     my %args = (
1611         ARGSRef         => undef,
1612         AttributesRef   => undef,
1613         Object          => undef,
1614         AttributePrefix => undef,
1615         @_
1616     );
1617
1618     my $Object  = $args{'Object'};
1619     my @results = $Object->Update(
1620         AttributesRef   => $args{'AttributesRef'},
1621         ARGSRef         => $args{'ARGSRef'},
1622         AttributePrefix => $args{'AttributePrefix'},
1623     );
1624
1625     return (@results);
1626 }
1627
1628 # }}}
1629
1630 # {{{ Sub ProcessCustomFieldUpdates
1631
1632 sub ProcessCustomFieldUpdates {
1633     my %args = (
1634         CustomFieldObj => undef,
1635         ARGSRef        => undef,
1636         @_
1637     );
1638
1639     my $Object  = $args{'CustomFieldObj'};
1640     my $ARGSRef = $args{'ARGSRef'};
1641
1642     my @attribs = qw(Name Type Description Queue SortOrder);
1643     my @results = UpdateRecordObject(
1644         AttributesRef => \@attribs,
1645         Object        => $Object,
1646         ARGSRef       => $ARGSRef
1647     );
1648
1649     my $prefix = "CustomField-" . $Object->Id;
1650     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1651         my ( $addval, $addmsg ) = $Object->AddValue(
1652             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1653             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1654             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1655         );
1656         push( @results, $addmsg );
1657     }
1658
1659     my @delete_values
1660         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1661         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1662         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1663
1664     foreach my $id (@delete_values) {
1665         next unless defined $id;
1666         my ( $err, $msg ) = $Object->DeleteValue($id);
1667         push( @results, $msg );
1668     }
1669
1670     my $vals = $Object->Values();
1671     while ( my $cfv = $vals->Next() ) {
1672         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1673             if ( $cfv->SortOrder != $so ) {
1674                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1675                 push( @results, $msg );
1676             }
1677         }
1678     }
1679
1680     return (@results);
1681 }
1682
1683 # }}}
1684
1685 # {{{ sub ProcessTicketBasics
1686
1687 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1688
1689 Returns an array of results messages.
1690
1691 =cut
1692
1693 sub ProcessTicketBasics {
1694
1695     my %args = (
1696         TicketObj => undef,
1697         ARGSRef   => undef,
1698         @_
1699     );
1700
1701     my $TicketObj = $args{'TicketObj'};
1702     my $ARGSRef   = $args{'ARGSRef'};
1703
1704     # {{{ Set basic fields
1705     my @attribs = qw(
1706         Subject
1707         FinalPriority
1708         Priority
1709         TimeEstimated
1710         TimeWorked
1711         TimeLeft
1712         Type
1713         Status
1714         Queue
1715     );
1716
1717     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1718         my $tempqueue = RT::Queue->new($RT::SystemUser);
1719         $tempqueue->Load( $ARGSRef->{'Queue'} );
1720         if ( $tempqueue->id ) {
1721             $ARGSRef->{'Queue'} = $tempqueue->id;
1722         }
1723     }
1724
1725     # Status isn't a field that can be set to a null value.
1726     # RT core complains if you try
1727     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1728
1729     my @results = UpdateRecordObject(
1730         AttributesRef => \@attribs,
1731         Object        => $TicketObj,
1732         ARGSRef       => $ARGSRef,
1733     );
1734
1735     # We special case owner changing, so we can use ForceOwnerChange
1736     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1737         my ($ChownType);
1738         if ( $ARGSRef->{'ForceOwnerChange'} ) {
1739             $ChownType = "Force";
1740         } else {
1741             $ChownType = "Give";
1742         }
1743
1744         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1745         push( @results, $msg );
1746     }
1747
1748     # }}}
1749
1750     return (@results);
1751 }
1752
1753 # }}}
1754
1755 sub ProcessTicketCustomFieldUpdates {
1756     my %args = @_;
1757     $args{'Object'} = delete $args{'TicketObj'};
1758     my $ARGSRef = { %{ $args{'ARGSRef'} } };
1759
1760     # Build up a list of objects that we want to work with
1761     my %custom_fields_to_mod;
1762     foreach my $arg ( keys %$ARGSRef ) {
1763         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1764             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1765         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1766             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1767         }
1768     }
1769
1770     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1771 }
1772
1773 sub ProcessObjectCustomFieldUpdates {
1774     my %args    = @_;
1775     my $ARGSRef = $args{'ARGSRef'};
1776     my @results;
1777
1778     # Build up a list of objects that we want to work with
1779     my %custom_fields_to_mod;
1780     foreach my $arg ( keys %$ARGSRef ) {
1781
1782         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1783         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1784
1785         # For each of those objects, find out what custom fields we want to work with.
1786         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1787     }
1788
1789     # For each of those objects
1790     foreach my $class ( keys %custom_fields_to_mod ) {
1791         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1792             my $Object = $args{'Object'};
1793             $Object = $class->new( $session{'CurrentUser'} )
1794                 unless $Object && ref $Object eq $class;
1795
1796             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1797             unless ( $Object->id ) {
1798                 $RT::Logger->warning("Couldn't load object $class #$id");
1799                 next;
1800             }
1801
1802             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1803                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1804                 $CustomFieldObj->LoadById($cf);
1805                 unless ( $CustomFieldObj->id ) {
1806                     $RT::Logger->warning("Couldn't load custom field #$cf");
1807                     next;
1808                 }
1809                 push @results,
1810                     _ProcessObjectCustomFieldUpdates(
1811                     Prefix      => "Object-$class-$id-CustomField-$cf-",
1812                     Object      => $Object,
1813                     CustomField => $CustomFieldObj,
1814                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
1815                     );
1816             }
1817         }
1818     }
1819     return @results;
1820 }
1821
1822 sub _ProcessObjectCustomFieldUpdates {
1823     my %args    = @_;
1824     my $cf      = $args{'CustomField'};
1825     my $cf_type = $cf->Type;
1826
1827     # Remove blank Values since the magic field will take care of this. Sometimes
1828     # the browser gives you a blank value which causes CFs to be processed twice
1829     if (   defined $args{'ARGS'}->{'Values'}
1830         && !length $args{'ARGS'}->{'Values'}
1831         && $args{'ARGS'}->{'Values-Magic'} )
1832     {
1833         delete $args{'ARGS'}->{'Values'};
1834     }
1835
1836     my @results;
1837     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1838
1839         # skip category argument
1840         next if $arg eq 'Category';
1841
1842         # since http won't pass in a form element with a null value, we need
1843         # to fake it
1844         if ( $arg eq 'Values-Magic' ) {
1845
1846             # We don't care about the magic, if there's really a values element;
1847             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
1848             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1849
1850             # "Empty" values does not mean anything for Image and Binary fields
1851             next if $cf_type =~ /^(?:Image|Binary)$/;
1852
1853             $arg = 'Values';
1854             $args{'ARGS'}->{'Values'} = undef;
1855         }
1856
1857         my @values = ();
1858         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1859             @values = @{ $args{'ARGS'}->{$arg} };
1860         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
1861             @values = ( $args{'ARGS'}->{$arg} );
1862         } else {
1863             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1864                 if defined $args{'ARGS'}->{$arg};
1865         }
1866         @values = grep length, map {
1867             s/\r+\n/\n/g;
1868             s/^\s+//;
1869             s/\s+$//;
1870             $_;
1871             }
1872             grep defined, @values;
1873
1874         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1875             foreach my $value (@values) {
1876                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1877                     Field => $cf->id,
1878                     Value => $value
1879                 );
1880                 push( @results, $msg );
1881             }
1882         } elsif ( $arg eq 'Upload' ) {
1883             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1884             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1885             push( @results, $msg );
1886         } elsif ( $arg eq 'DeleteValues' ) {
1887             foreach my $value (@values) {
1888                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1889                     Field => $cf,
1890                     Value => $value,
1891                 );
1892                 push( @results, $msg );
1893             }
1894         } elsif ( $arg eq 'DeleteValueIds' ) {
1895             foreach my $value (@values) {
1896                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1897                     Field   => $cf,
1898                     ValueId => $value,
1899                 );
1900                 push( @results, $msg );
1901             }
1902         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1903             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1904
1905             my %values_hash;
1906             foreach my $value (@values) {
1907                 if ( my $entry = $cf_values->HasEntry($value) ) {
1908                     $values_hash{ $entry->id } = 1;
1909                     next;
1910                 }
1911
1912                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1913                     Field => $cf,
1914                     Value => $value
1915                 );
1916                 push( @results, $msg );
1917                 $values_hash{$val} = 1 if $val;
1918             }
1919
1920             $cf_values->RedoSearch;
1921             while ( my $cf_value = $cf_values->Next ) {
1922                 next if $values_hash{ $cf_value->id };
1923
1924                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1925                     Field   => $cf,
1926                     ValueId => $cf_value->id
1927                 );
1928                 push( @results, $msg );
1929             }
1930         } elsif ( $arg eq 'Values' ) {
1931             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1932
1933             # keep everything up to the point of difference, delete the rest
1934             my $delete_flag;
1935             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1936                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1937                     shift @values;
1938                     next;
1939                 }
1940
1941                 $delete_flag ||= 1;
1942                 $old_cf->Delete;
1943             }
1944
1945             # now add/replace extra things, if any
1946             foreach my $value (@values) {
1947                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1948                     Field => $cf,
1949                     Value => $value
1950                 );
1951                 push( @results, $msg );
1952             }
1953         } else {
1954             push(
1955                 @results,
1956                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1957                     $cf->Name, ref $args{'Object'},
1958                     $args{'Object'}->id
1959                 )
1960             );
1961         }
1962     }
1963     return @results;
1964 }
1965
1966 # {{{ sub ProcessTicketWatchers
1967
1968 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1969
1970 Returns an array of results messages.
1971
1972 =cut
1973
1974 sub ProcessTicketWatchers {
1975     my %args = (
1976         TicketObj => undef,
1977         ARGSRef   => undef,
1978         @_
1979     );
1980     my (@results);
1981
1982     my $Ticket  = $args{'TicketObj'};
1983     my $ARGSRef = $args{'ARGSRef'};
1984
1985     # Munge watchers
1986
1987     foreach my $key ( keys %$ARGSRef ) {
1988
1989         # Delete deletable watchers
1990         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1991             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1992                 PrincipalId => $2,
1993                 Type        => $1
1994             );
1995             push @results, $msg;
1996         }
1997
1998         # Delete watchers in the simple style demanded by the bulk manipulator
1999         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2000             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2001                 Email => $ARGSRef->{$key},
2002                 Type  => $1
2003             );
2004             push @results, $msg;
2005         }
2006
2007         # Add new wathchers by email address
2008         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2009             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2010         {
2011
2012             #They're in this order because otherwise $1 gets clobbered :/
2013             my ( $code, $msg ) = $Ticket->AddWatcher(
2014                 Type  => $ARGSRef->{$key},
2015                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2016             );
2017             push @results, $msg;
2018         }
2019
2020         #Add requestors in the simple style demanded by the bulk manipulator
2021         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2022             my ( $code, $msg ) = $Ticket->AddWatcher(
2023                 Type  => $1,
2024                 Email => $ARGSRef->{$key}
2025             );
2026             push @results, $msg;
2027         }
2028
2029         # Add new  watchers by owner
2030         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2031             my $principal_id = $1;
2032             my $form         = $ARGSRef->{$key};
2033             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2034                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2035
2036                 my ( $code, $msg ) = $Ticket->AddWatcher(
2037                     Type        => $value,
2038                     PrincipalId => $principal_id
2039                 );
2040                 push @results, $msg;
2041             }
2042         }
2043
2044     }
2045     return (@results);
2046 }
2047
2048 # }}}
2049
2050 # {{{ sub ProcessTicketDates
2051
2052 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2053
2054 Returns an array of results messages.
2055
2056 =cut
2057
2058 sub ProcessTicketDates {
2059     my %args = (
2060         TicketObj => undef,
2061         ARGSRef   => undef,
2062         @_
2063     );
2064
2065     my $Ticket  = $args{'TicketObj'};
2066     my $ARGSRef = $args{'ARGSRef'};
2067
2068     my (@results);
2069
2070     # {{{ Set date fields
2071     my @date_fields = qw(
2072         Told
2073         Resolved
2074         Starts
2075         Started
2076         Due
2077     );
2078
2079     #Run through each field in this list. update the value if apropriate
2080     foreach my $field (@date_fields) {
2081         next unless exists $ARGSRef->{ $field . '_Date' };
2082         next if $ARGSRef->{ $field . '_Date' } eq '';
2083
2084         my ( $code, $msg );
2085
2086         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2087         $DateObj->Set(
2088             Format => 'unknown',
2089             Value  => $ARGSRef->{ $field . '_Date' }
2090         );
2091
2092         my $obj = $field . "Obj";
2093         if (    ( defined $DateObj->Unix )
2094             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2095         {
2096             my $method = "Set$field";
2097             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2098             push @results, "$msg";
2099         }
2100     }
2101
2102     # }}}
2103     return (@results);
2104 }
2105
2106 # }}}
2107
2108 # {{{ sub ProcessTicketLinks
2109
2110 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2111
2112 Returns an array of results messages.
2113
2114 =cut
2115
2116 sub ProcessTicketLinks {
2117     my %args = (
2118         TicketObj => undef,
2119         ARGSRef   => undef,
2120         @_
2121     );
2122
2123     my $Ticket  = $args{'TicketObj'};
2124     my $ARGSRef = $args{'ARGSRef'};
2125
2126     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2127
2128     #Merge if we need to
2129     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2130         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2131         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2132         push @results, $msg;
2133     }
2134
2135     return (@results);
2136 }
2137
2138 # }}}
2139
2140 sub ProcessRecordLinks {
2141     my %args = (
2142         RecordObj => undef,
2143         ARGSRef   => undef,
2144         @_
2145     );
2146
2147     my $Record  = $args{'RecordObj'};
2148     my $ARGSRef = $args{'ARGSRef'};
2149
2150     my (@results);
2151
2152     # Delete links that are gone gone gone.
2153     foreach my $arg ( keys %$ARGSRef ) {
2154         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2155             my $base   = $1;
2156             my $type   = $2;
2157             my $target = $3;
2158
2159             my ( $val, $msg ) = $Record->DeleteLink(
2160                 Base   => $base,
2161                 Type   => $type,
2162                 Target => $target
2163             );
2164
2165             push @results, $msg;
2166
2167         }
2168
2169     }
2170
2171     my @linktypes = qw( DependsOn MemberOf RefersTo );
2172
2173     foreach my $linktype (@linktypes) {
2174         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2175             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2176                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2177
2178             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2179                 next unless $luri;
2180                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2181                 my ( $val, $msg ) = $Record->AddLink(
2182                     Target => $luri,
2183                     Type   => $linktype
2184                 );
2185                 push @results, $msg;
2186             }
2187         }
2188         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2189             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2190                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2191
2192             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2193                 next unless $luri;
2194                 my ( $val, $msg ) = $Record->AddLink(
2195                     Base => $luri,
2196                     Type => $linktype
2197                 );
2198
2199                 push @results, $msg;
2200             }
2201         }
2202     }
2203
2204     return (@results);
2205 }
2206
2207 =head2 _UploadedFile ( $arg );
2208
2209 Takes a CGI parameter name; if a file is uploaded under that name,
2210 return a hash reference suitable for AddCustomFieldValue's use:
2211 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2212
2213 Returns C<undef> if no files were uploaded in the C<$arg> field.
2214
2215 =cut
2216
2217 sub _UploadedFile {
2218     my $arg         = shift;
2219     my $cgi_object  = $m->cgi_object;
2220     my $fh          = $cgi_object->upload($arg) or return undef;
2221     my $upload_info = $cgi_object->uploadInfo($fh);
2222
2223     my $filename = "$fh";
2224     $filename =~ s#^.*[\\/]##;
2225     binmode($fh);
2226
2227     return {
2228         Value        => $filename,
2229         LargeContent => do { local $/; scalar <$fh> },
2230         ContentType  => $upload_info->{'Content-Type'},
2231     };
2232 }
2233
2234 sub GetColumnMapEntry {
2235     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2236
2237     # deal with the simplest thing first
2238     if ( $args{'Map'}{ $args{'Name'} } ) {
2239         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2240     }
2241
2242     # complex things
2243     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2244         return undef unless $args{'Map'}->{$mainkey};
2245         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2246             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2247
2248         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2249     }
2250     return undef;
2251 }
2252
2253 sub ProcessColumnMapValue {
2254     my $value = shift;
2255     my %args = ( Arguments => [], Escape => 1, @_ );
2256
2257     if ( ref $value ) {
2258         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2259             my @tmp = $value->( @{ $args{'Arguments'} } );
2260             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2261         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2262             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2263         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2264             return $$value;
2265         }
2266     }
2267
2268     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2269     return $value;
2270 }
2271
2272 =head2 _load_container_object ( $type, $id );
2273
2274 Instantiate container object for saving searches.
2275
2276 =cut
2277
2278 sub _load_container_object {
2279     my ( $obj_type, $obj_id ) = @_;
2280     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2281 }
2282
2283 =head2 _parse_saved_search ( $arg );
2284
2285 Given a serialization string for saved search, and returns the
2286 container object and the search id.
2287
2288 =cut
2289
2290 sub _parse_saved_search {
2291     my $spec = shift;
2292     return unless $spec;
2293     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2294         return;
2295     }
2296     my $obj_type  = $1;
2297     my $obj_id    = $2;
2298     my $search_id = $3;
2299
2300     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2301 }
2302
2303 package RT::Interface::Web;
2304 RT::Base->_ImportOverlays();
2305
2306 1;