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