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 %txn_customfields;
1387
1388     foreach my $key ( keys %{ $args{ARGSRef} } ) {
1389       if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1390         $txn_customfields{$key} = $args{ARGSRef}->{$key};
1391       }
1392     }
1393
1394     my %message_args = (
1395         CcMessageTo  => $cc,
1396         BccMessageTo => $bcc,
1397         Sign         => $args{ARGSRef}->{'Sign'},
1398         Encrypt      => $args{ARGSRef}->{'Encrypt'},
1399         MIMEObj      => $Message,
1400         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'},
1401         CustomFields => \%txn_customfields,
1402     );
1403
1404     my @temp_squelch;
1405     foreach my $type (qw(Cc AdminCc)) {
1406         if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1407             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1408             push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1409             push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1410         }
1411     }
1412     if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1413             push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1414             push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1415     }
1416
1417     if (@temp_squelch) {
1418         require RT::Action::SendEmail;
1419         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1420     }
1421
1422     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1423         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1424             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1425
1426             my $var   = ucfirst($1) . 'MessageTo';
1427             my $value = $2;
1428             if ( $message_args{$var} ) {
1429                 $message_args{$var} .= ", $value";
1430             } else {
1431                 $message_args{$var} = $value;
1432             }
1433         }
1434     }
1435
1436     my @results;
1437     # Do the update via the appropriate Ticket method
1438     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1439         my ( $Transaction, $Description, $Object ) =
1440             $args{TicketObj}->Comment(%message_args);
1441         push( @results, $Description );
1442         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1443     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1444         my ( $Transaction, $Description, $Object ) =
1445             $args{TicketObj}->Correspond(%message_args);
1446         push( @results, $Description );
1447         #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1448     } else {
1449         push( @results,
1450             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1451     }
1452     return @results;
1453 }
1454
1455 # }}}
1456
1457 # {{{ sub MakeMIMEEntity
1458
1459 =head2 MakeMIMEEntity PARAMHASH
1460
1461 Takes a paramhash Subject, Body and AttachmentFieldName.
1462
1463 Also takes Form, Cc and Type as optional paramhash keys.
1464
1465   Returns a MIME::Entity.
1466
1467 =cut
1468
1469 sub MakeMIMEEntity {
1470
1471     #TODO document what else this takes.
1472     my %args = (
1473         Subject             => undef,
1474         From                => undef,
1475         Cc                  => undef,
1476         Body                => undef,
1477         AttachmentFieldName => undef,
1478         Type                => undef,
1479         @_,
1480     );
1481     my $Message = MIME::Entity->build(
1482         Type    => 'multipart/mixed',
1483         map { $_ => Encode::encode_utf8( $args{ $_} ) }
1484             grep defined $args{$_}, qw(Subject From Cc)
1485     );
1486
1487     if ( defined $args{'Body'} && length $args{'Body'} ) {
1488
1489         # Make the update content have no 'weird' newlines in it
1490         $args{'Body'} =~ s/\r\n/\n/gs;
1491
1492         $Message->attach(
1493             Type    => $args{'Type'} || 'text/plain',
1494             Charset => 'UTF-8',
1495             Data    => $args{'Body'},
1496         );
1497     }
1498
1499     if ( $args{'AttachmentFieldName'} ) {
1500
1501         my $cgi_object = $m->cgi_object;
1502
1503         if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1504
1505             my ( @content, $buffer );
1506             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1507                 push @content, $buffer;
1508             }
1509
1510             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1511
1512             # Prefer the cached name first over CGI.pm stringification.
1513             my $filename = $RT::Mason::CGI::Filename;
1514             $filename = "$filehandle" unless defined $filename;
1515             $filename = Encode::encode_utf8( $filename );
1516             $filename =~ s{^.*[\\/]}{};
1517
1518             $Message->attach(
1519                 Type     => $uploadinfo->{'Content-Type'},
1520                 Filename => $filename,
1521                 Data     => \@content,
1522             );
1523             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1524                 $Message->head->set( 'Subject' => $filename );
1525             }
1526         }
1527     }
1528
1529     $Message->make_singlepart;
1530
1531     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1532
1533     return ($Message);
1534
1535 }
1536
1537 # }}}
1538
1539 # {{{ sub ParseDateToISO
1540
1541 =head2 ParseDateToISO
1542
1543 Takes a date in an arbitrary format.
1544 Returns an ISO date and time in GMT
1545
1546 =cut
1547
1548 sub ParseDateToISO {
1549     my $date = shift;
1550
1551     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1552     $date_obj->Set(
1553         Format => 'unknown',
1554         Value  => $date
1555     );
1556     return ( $date_obj->ISO );
1557 }
1558
1559 # }}}
1560
1561 # {{{ sub ProcessACLChanges
1562
1563 sub ProcessACLChanges {
1564     my $ARGSref = shift;
1565
1566     my @results;
1567
1568     foreach my $arg ( keys %$ARGSref ) {
1569         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1570
1571         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1572
1573         my @rights;
1574         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1575             @rights = @{ $ARGSref->{$arg} };
1576         } else {
1577             @rights = $ARGSref->{$arg};
1578         }
1579         @rights = grep $_, @rights;
1580         next unless @rights;
1581
1582         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1583         $principal->Load($principal_id);
1584
1585         my $obj;
1586         if ( $object_type eq 'RT::System' ) {
1587             $obj = $RT::System;
1588         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1589             $obj = $object_type->new( $session{'CurrentUser'} );
1590             $obj->Load($object_id);
1591             unless ( $obj->id ) {
1592                 $RT::Logger->error("couldn't load $object_type #$object_id");
1593                 next;
1594             }
1595         } else {
1596             $RT::Logger->error("object type '$object_type' is incorrect");
1597             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1598             next;
1599         }
1600
1601         foreach my $right (@rights) {
1602             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1603             push( @results, $msg );
1604         }
1605     }
1606
1607     return (@results);
1608 }
1609
1610 # }}}
1611
1612 # {{{ sub UpdateRecordObj
1613
1614 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1615
1616 @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.
1617
1618 Returns an array of success/failure messages
1619
1620 =cut
1621
1622 sub UpdateRecordObject {
1623     my %args = (
1624         ARGSRef         => undef,
1625         AttributesRef   => undef,
1626         Object          => undef,
1627         AttributePrefix => undef,
1628         @_
1629     );
1630
1631     my $Object  = $args{'Object'};
1632     my @results = $Object->Update(
1633         AttributesRef   => $args{'AttributesRef'},
1634         ARGSRef         => $args{'ARGSRef'},
1635         AttributePrefix => $args{'AttributePrefix'},
1636     );
1637
1638     return (@results);
1639 }
1640
1641 # }}}
1642
1643 # {{{ Sub ProcessCustomFieldUpdates
1644
1645 sub ProcessCustomFieldUpdates {
1646     my %args = (
1647         CustomFieldObj => undef,
1648         ARGSRef        => undef,
1649         @_
1650     );
1651
1652     my $Object  = $args{'CustomFieldObj'};
1653     my $ARGSRef = $args{'ARGSRef'};
1654
1655     my @attribs = qw(Name Type Description Queue SortOrder);
1656     my @results = UpdateRecordObject(
1657         AttributesRef => \@attribs,
1658         Object        => $Object,
1659         ARGSRef       => $ARGSRef
1660     );
1661
1662     my $prefix = "CustomField-" . $Object->Id;
1663     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1664         my ( $addval, $addmsg ) = $Object->AddValue(
1665             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1666             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1667             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1668         );
1669         push( @results, $addmsg );
1670     }
1671
1672     my @delete_values
1673         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1674         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1675         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1676
1677     foreach my $id (@delete_values) {
1678         next unless defined $id;
1679         my ( $err, $msg ) = $Object->DeleteValue($id);
1680         push( @results, $msg );
1681     }
1682
1683     my $vals = $Object->Values();
1684     while ( my $cfv = $vals->Next() ) {
1685         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1686             if ( $cfv->SortOrder != $so ) {
1687                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1688                 push( @results, $msg );
1689             }
1690         }
1691     }
1692
1693     return (@results);
1694 }
1695
1696 # }}}
1697
1698 # {{{ sub ProcessTicketBasics
1699
1700 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1701
1702 Returns an array of results messages.
1703
1704 =cut
1705
1706 sub ProcessTicketBasics {
1707
1708     my %args = (
1709         TicketObj => undef,
1710         ARGSRef   => undef,
1711         @_
1712     );
1713
1714     my $TicketObj = $args{'TicketObj'};
1715     my $ARGSRef   = $args{'ARGSRef'};
1716
1717     # {{{ Set basic fields
1718     my @attribs = qw(
1719         Subject
1720         FinalPriority
1721         Priority
1722         TimeEstimated
1723         TimeWorked
1724         TimeLeft
1725         Type
1726         Status
1727         Queue
1728     );
1729
1730     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1731         my $tempqueue = RT::Queue->new($RT::SystemUser);
1732         $tempqueue->Load( $ARGSRef->{'Queue'} );
1733         if ( $tempqueue->id ) {
1734             $ARGSRef->{'Queue'} = $tempqueue->id;
1735         }
1736     }
1737
1738     # Status isn't a field that can be set to a null value.
1739     # RT core complains if you try
1740     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1741
1742     my @results = UpdateRecordObject(
1743         AttributesRef => \@attribs,
1744         Object        => $TicketObj,
1745         ARGSRef       => $ARGSRef,
1746     );
1747
1748     # We special case owner changing, so we can use ForceOwnerChange
1749     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1750         my ($ChownType);
1751         if ( $ARGSRef->{'ForceOwnerChange'} ) {
1752             $ChownType = "Force";
1753         } else {
1754             $ChownType = "Give";
1755         }
1756
1757         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1758         push( @results, $msg );
1759     }
1760
1761     # }}}
1762
1763     return (@results);
1764 }
1765
1766 # }}}
1767
1768 sub ProcessTicketCustomFieldUpdates {
1769     my %args = @_;
1770     $args{'Object'} = delete $args{'TicketObj'};
1771     my $ARGSRef = { %{ $args{'ARGSRef'} } };
1772
1773     # Build up a list of objects that we want to work with
1774     my %custom_fields_to_mod;
1775     foreach my $arg ( keys %$ARGSRef ) {
1776         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1777             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1778         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1779             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1780         } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
1781             delete $ARGSRef->{$arg}; # don't try to update transaction fields
1782         }
1783     }
1784
1785     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1786 }
1787
1788 sub ProcessObjectCustomFieldUpdates {
1789     my %args    = @_;
1790     my $ARGSRef = $args{'ARGSRef'};
1791     my @results;
1792
1793     # Build up a list of objects that we want to work with
1794     my %custom_fields_to_mod;
1795     foreach my $arg ( keys %$ARGSRef ) {
1796
1797         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1798         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1799
1800         # For each of those objects, find out what custom fields we want to work with.
1801         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1802     }
1803
1804     # For each of those objects
1805     foreach my $class ( keys %custom_fields_to_mod ) {
1806         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1807             my $Object = $args{'Object'};
1808             $Object = $class->new( $session{'CurrentUser'} )
1809                 unless $Object && ref $Object eq $class;
1810
1811             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1812             unless ( $Object->id ) {
1813                 $RT::Logger->warning("Couldn't load object $class #$id");
1814                 next;
1815             }
1816
1817             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1818                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1819                 $CustomFieldObj->LoadById($cf);
1820                 unless ( $CustomFieldObj->id ) {
1821                     $RT::Logger->warning("Couldn't load custom field #$cf");
1822                     next;
1823                 }
1824                 push @results,
1825                     _ProcessObjectCustomFieldUpdates(
1826                     Prefix      => "Object-$class-$id-CustomField-$cf-",
1827                     Object      => $Object,
1828                     CustomField => $CustomFieldObj,
1829                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
1830                     );
1831             }
1832         }
1833     }
1834     return @results;
1835 }
1836
1837 sub _ProcessObjectCustomFieldUpdates {
1838     my %args    = @_;
1839     my $cf      = $args{'CustomField'};
1840     my $cf_type = $cf->Type;
1841
1842     # Remove blank Values since the magic field will take care of this. Sometimes
1843     # the browser gives you a blank value which causes CFs to be processed twice
1844     if (   defined $args{'ARGS'}->{'Values'}
1845         && !length $args{'ARGS'}->{'Values'}
1846         && $args{'ARGS'}->{'Values-Magic'} )
1847     {
1848         delete $args{'ARGS'}->{'Values'};
1849     }
1850
1851     my @results;
1852     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1853
1854         # skip category argument
1855         next if $arg eq 'Category';
1856
1857         # and TimeUnits
1858         next if $arg eq 'Value-TimeUnits';
1859
1860         # since http won't pass in a form element with a null value, we need
1861         # to fake it
1862         if ( $arg eq 'Values-Magic' ) {
1863
1864             # We don't care about the magic, if there's really a values element;
1865             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
1866             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1867
1868             # "Empty" values does not mean anything for Image and Binary fields
1869             next if $cf_type =~ /^(?:Image|Binary)$/;
1870
1871             $arg = 'Values';
1872             $args{'ARGS'}->{'Values'} = undef;
1873         }
1874
1875         my @values = ();
1876         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1877             @values = @{ $args{'ARGS'}->{$arg} };
1878         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
1879             @values = ( $args{'ARGS'}->{$arg} );
1880         } else {
1881             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1882                 if defined $args{'ARGS'}->{$arg};
1883         }
1884         @values = grep length, map {
1885             s/\r+\n/\n/g;
1886             s/^\s+//;
1887             s/\s+$//;
1888             $_;
1889             }
1890             grep defined, @values;
1891
1892         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1893             foreach my $value (@values) {
1894                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1895                     Field => $cf->id,
1896                     Value => $value
1897                 );
1898                 push( @results, $msg );
1899             }
1900         } elsif ( $arg eq 'Upload' ) {
1901             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1902             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1903             push( @results, $msg );
1904         } elsif ( $arg eq 'DeleteValues' ) {
1905             foreach my $value (@values) {
1906                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1907                     Field => $cf,
1908                     Value => $value,
1909                 );
1910                 push( @results, $msg );
1911             }
1912         } elsif ( $arg eq 'DeleteValueIds' ) {
1913             foreach my $value (@values) {
1914                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1915                     Field   => $cf,
1916                     ValueId => $value,
1917                 );
1918                 push( @results, $msg );
1919             }
1920         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1921             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1922
1923             my %values_hash;
1924             foreach my $value (@values) {
1925                 if ( my $entry = $cf_values->HasEntry($value) ) {
1926                     $values_hash{ $entry->id } = 1;
1927                     next;
1928                 }
1929
1930                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1931                     Field => $cf,
1932                     Value => $value
1933                 );
1934                 push( @results, $msg );
1935                 $values_hash{$val} = 1 if $val;
1936             }
1937
1938             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1939             return @results if ( $cf->Type eq 'Date' && ! @values );
1940
1941             $cf_values->RedoSearch;
1942             while ( my $cf_value = $cf_values->Next ) {
1943                 next if $values_hash{ $cf_value->id };
1944
1945                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1946                     Field   => $cf,
1947                     ValueId => $cf_value->id
1948                 );
1949                 push( @results, $msg );
1950             }
1951         } elsif ( $arg eq 'Values' ) {
1952             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1953
1954             # keep everything up to the point of difference, delete the rest
1955             my $delete_flag;
1956             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1957                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1958                     shift @values;
1959                     next;
1960                 }
1961
1962                 $delete_flag ||= 1;
1963                 $old_cf->Delete;
1964             }
1965
1966             # now add/replace extra things, if any
1967             foreach my $value (@values) {
1968                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1969                     Field => $cf,
1970                     Value => $value
1971                 );
1972                 push( @results, $msg );
1973             }
1974         } else {
1975             push(
1976                 @results,
1977                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1978                     $cf->Name, ref $args{'Object'},
1979                     $args{'Object'}->id
1980                 )
1981             );
1982         }
1983     }
1984     return @results;
1985 }
1986
1987 # {{{ sub ProcessTicketWatchers
1988
1989 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1990
1991 Returns an array of results messages.
1992
1993 =cut
1994
1995 sub ProcessTicketWatchers {
1996     my %args = (
1997         TicketObj => undef,
1998         ARGSRef   => undef,
1999         @_
2000     );
2001     my (@results);
2002
2003     my $Ticket  = $args{'TicketObj'};
2004     my $ARGSRef = $args{'ARGSRef'};
2005
2006     # Munge watchers
2007
2008     foreach my $key ( keys %$ARGSRef ) {
2009
2010         # Delete deletable watchers
2011         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2012             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2013                 PrincipalId => $2,
2014                 Type        => $1
2015             );
2016             push @results, $msg;
2017         }
2018
2019         # Delete watchers in the simple style demanded by the bulk manipulator
2020         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2021             my ( $code, $msg ) = $Ticket->DeleteWatcher(
2022                 Email => $ARGSRef->{$key},
2023                 Type  => $1
2024             );
2025             push @results, $msg;
2026         }
2027
2028         # Add new wathchers by email address
2029         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2030             and $key =~ /^WatcherTypeEmail(\d*)$/ )
2031         {
2032
2033             #They're in this order because otherwise $1 gets clobbered :/
2034             my ( $code, $msg ) = $Ticket->AddWatcher(
2035                 Type  => $ARGSRef->{$key},
2036                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2037             );
2038             push @results, $msg;
2039         }
2040
2041         #Add requestors in the simple style demanded by the bulk manipulator
2042         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2043             my ( $code, $msg ) = $Ticket->AddWatcher(
2044                 Type  => $1,
2045                 Email => $ARGSRef->{$key}
2046             );
2047             push @results, $msg;
2048         }
2049
2050         # Add new  watchers by owner
2051         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2052             my $principal_id = $1;
2053             my $form         = $ARGSRef->{$key};
2054             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2055                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2056
2057                 my ( $code, $msg ) = $Ticket->AddWatcher(
2058                     Type        => $value,
2059                     PrincipalId => $principal_id
2060                 );
2061                 push @results, $msg;
2062             }
2063         }
2064
2065     }
2066     return (@results);
2067 }
2068
2069 # }}}
2070
2071 # {{{ sub ProcessTicketDates
2072
2073 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2074
2075 Returns an array of results messages.
2076
2077 =cut
2078
2079 sub ProcessTicketDates {
2080     my %args = (
2081         TicketObj => undef,
2082         ARGSRef   => undef,
2083         @_
2084     );
2085
2086     my $Ticket  = $args{'TicketObj'};
2087     my $ARGSRef = $args{'ARGSRef'};
2088
2089     my (@results);
2090
2091     # {{{ Set date fields
2092     my @date_fields = qw(
2093         Told
2094         Resolved
2095         Starts
2096         Started
2097         Due
2098     );
2099
2100     #Run through each field in this list. update the value if apropriate
2101     foreach my $field (@date_fields) {
2102         next unless exists $ARGSRef->{ $field . '_Date' };
2103         next if $ARGSRef->{ $field . '_Date' } eq '';
2104
2105         my ( $code, $msg );
2106
2107         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2108         $DateObj->Set(
2109             Format => 'unknown',
2110             Value  => $ARGSRef->{ $field . '_Date' }
2111         );
2112
2113         my $obj = $field . "Obj";
2114         if (    ( defined $DateObj->Unix )
2115             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2116         {
2117             my $method = "Set$field";
2118             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2119             push @results, "$msg";
2120         }
2121     }
2122
2123     # }}}
2124     return (@results);
2125 }
2126
2127 # }}}
2128
2129 # {{{ sub ProcessTicketLinks
2130
2131 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2132
2133 Returns an array of results messages.
2134
2135 =cut
2136
2137 sub ProcessTicketLinks {
2138     my %args = (
2139         TicketObj => undef,
2140         ARGSRef   => undef,
2141         @_
2142     );
2143
2144     my $Ticket  = $args{'TicketObj'};
2145     my $ARGSRef = $args{'ARGSRef'};
2146
2147     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2148
2149     #Merge if we need to
2150     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2151         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2152         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2153         push @results, $msg;
2154     }
2155
2156     return (@results);
2157 }
2158
2159 # }}}
2160
2161 sub ProcessRecordLinks {
2162     my %args = (
2163         RecordObj => undef,
2164         ARGSRef   => undef,
2165         @_
2166     );
2167
2168     my $Record  = $args{'RecordObj'};
2169     my $ARGSRef = $args{'ARGSRef'};
2170
2171     my (@results);
2172
2173     # Delete links that are gone gone gone.
2174     foreach my $arg ( keys %$ARGSRef ) {
2175         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2176             my $base   = $1;
2177             my $type   = $2;
2178             my $target = $3;
2179
2180             my ( $val, $msg ) = $Record->DeleteLink(
2181                 Base   => $base,
2182                 Type   => $type,
2183                 Target => $target
2184             );
2185
2186             push @results, $msg;
2187
2188         }
2189
2190     }
2191
2192     my @linktypes = qw( DependsOn MemberOf RefersTo );
2193
2194     foreach my $linktype (@linktypes) {
2195         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2196             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2197                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2198
2199             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2200                 next unless $luri;
2201                 $luri =~ s/\s+$//;    # Strip trailing whitespace
2202                 my ( $val, $msg ) = $Record->AddLink(
2203                     Target => $luri,
2204                     Type   => $linktype
2205                 );
2206                 push @results, $msg;
2207             }
2208         }
2209         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2210             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2211                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2212
2213             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2214                 next unless $luri;
2215                 my ( $val, $msg ) = $Record->AddLink(
2216                     Base => $luri,
2217                     Type => $linktype
2218                 );
2219
2220                 push @results, $msg;
2221             }
2222         }
2223     }
2224
2225     return (@results);
2226 }
2227
2228 =head2 _UploadedFile ( $arg );
2229
2230 Takes a CGI parameter name; if a file is uploaded under that name,
2231 return a hash reference suitable for AddCustomFieldValue's use:
2232 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2233
2234 Returns C<undef> if no files were uploaded in the C<$arg> field.
2235
2236 =cut
2237
2238 sub _UploadedFile {
2239     my $arg         = shift;
2240     my $cgi_object  = $m->cgi_object;
2241     my $fh          = $cgi_object->upload($arg) or return undef;
2242     my $upload_info = $cgi_object->uploadInfo($fh);
2243
2244     my $filename = "$fh";
2245     $filename =~ s#^.*[\\/]##;
2246     binmode($fh);
2247
2248     return {
2249         Value        => $filename,
2250         LargeContent => do { local $/; scalar <$fh> },
2251         ContentType  => $upload_info->{'Content-Type'},
2252     };
2253 }
2254
2255 sub GetColumnMapEntry {
2256     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2257
2258     # deal with the simplest thing first
2259     if ( $args{'Map'}{ $args{'Name'} } ) {
2260         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2261     }
2262
2263     # complex things
2264     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2265         return undef unless $args{'Map'}->{$mainkey};
2266         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2267             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2268
2269         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2270     }
2271     return undef;
2272 }
2273
2274 sub ProcessColumnMapValue {
2275     my $value = shift;
2276     my %args = ( Arguments => [], Escape => 1, @_ );
2277
2278     if ( ref $value ) {
2279         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2280             my @tmp = $value->( @{ $args{'Arguments'} } );
2281             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2282         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2283             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2284         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2285             return $$value;
2286         }
2287     }
2288
2289     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2290     return $value;
2291 }
2292
2293 =head2 _load_container_object ( $type, $id );
2294
2295 Instantiate container object for saving searches.
2296
2297 =cut
2298
2299 sub _load_container_object {
2300     my ( $obj_type, $obj_id ) = @_;
2301     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2302 }
2303
2304 =head2 _parse_saved_search ( $arg );
2305
2306 Given a serialization string for saved search, and returns the
2307 container object and the search id.
2308
2309 =cut
2310
2311 sub _parse_saved_search {
2312     my $spec = shift;
2313     return unless $spec;
2314     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2315         return;
2316     }
2317     my $obj_type  = $1;
2318     my $obj_id    = $2;
2319     my $search_id = $3;
2320
2321     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2322 }
2323
2324 package RT::Interface::Web;
2325 RT::Base->_ImportOverlays();
2326
2327 1;