rt/lib/RT/Interface/Web.pm

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