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