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     my @results;
1349
1350     foreach my $arg ( keys %$ARGSref ) {
1351         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1352
1353         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1354
1355         my @rights;
1356         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1357             @rights = @{ $ARGSref->{$arg} };
1358         } else {
1359             @rights = $ARGSref->{$arg};
1360         }
1361         @rights = grep $_, @rights;
1362         next unless @rights;
1363
1364         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1365         $principal->Load($principal_id);
1366
1367         my $obj;
1368         if ( $object_type eq 'RT::System' ) {
1369             $obj = $RT::System;
1370         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1371             $obj = $object_type->new( $session{'CurrentUser'} );
1372             $obj->Load($object_id);
1373             unless ( $obj->id ) {
1374                 $RT::Logger->error("couldn't load $object_type #$object_id");
1375                 next;
1376             }
1377         } else {
1378             $RT::Logger->error("object type '$object_type' is incorrect");
1379             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1380             next;
1381         }
1382
1383         foreach my $right (@rights) {
1384             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1385             push( @results, $msg );
1386         }
1387     }
1388
1389     return (@results);
1390 }
1391
1392 # }}}
1393
1394 # {{{ sub UpdateRecordObj
1395
1396 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1397
1398 @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.
1399
1400 Returns an array of success/failure messages
1401
1402 =cut
1403
1404 sub UpdateRecordObject {
1405     my %args = (
1406         ARGSRef         => undef,
1407         AttributesRef   => undef,
1408         Object          => undef,
1409         AttributePrefix => undef,
1410         @_
1411     );
1412
1413     my $Object  = $args{'Object'};
1414     my @results = $Object->Update(
1415         AttributesRef   => $args{'AttributesRef'},
1416         ARGSRef         => $args{'ARGSRef'},
1417         AttributePrefix => $args{'AttributePrefix'},
1418     );
1419
1420     return (@results);
1421 }
1422
1423 # }}}
1424
1425 # {{{ Sub ProcessCustomFieldUpdates
1426
1427 sub ProcessCustomFieldUpdates {
1428     my %args = (
1429         CustomFieldObj => undef,
1430         ARGSRef        => undef,
1431         @_
1432     );
1433
1434     my $Object  = $args{'CustomFieldObj'};
1435     my $ARGSRef = $args{'ARGSRef'};
1436
1437     my @attribs = qw(Name Type Description Queue SortOrder);
1438     my @results = UpdateRecordObject(
1439         AttributesRef => \@attribs,
1440         Object        => $Object,
1441         ARGSRef       => $ARGSRef
1442     );
1443
1444     my $prefix = "CustomField-" . $Object->Id;
1445     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1446         my ( $addval, $addmsg ) = $Object->AddValue(
1447             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1448             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1449             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1450         );
1451         push( @results, $addmsg );
1452     }
1453
1454     my @delete_values
1455         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1456         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1457         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1458
1459     foreach my $id (@delete_values) {
1460         next unless defined $id;
1461         my ( $err, $msg ) = $Object->DeleteValue($id);
1462         push( @results, $msg );
1463     }
1464
1465     my $vals = $Object->Values();
1466     while ( my $cfv = $vals->Next() ) {
1467         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1468             if ( $cfv->SortOrder != $so ) {
1469                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1470                 push( @results, $msg );
1471             }
1472         }
1473     }
1474
1475     return (@results);
1476 }
1477
1478 # }}}
1479
1480 # {{{ sub ProcessTicketBasics
1481
1482 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1483
1484 Returns an array of results messages.
1485
1486 =cut
1487
1488 sub ProcessTicketBasics {
1489
1490     my %args = (
1491         TicketObj => undef,
1492         ARGSRef   => undef,
1493         @_
1494     );
1495
1496     my $TicketObj = $args{'TicketObj'};
1497     my $ARGSRef   = $args{'ARGSRef'};
1498
1499     # {{{ Set basic fields
1500     my @attribs = qw(
1501         Subject
1502         FinalPriority
1503         Priority
1504         TimeEstimated
1505         TimeWorked
1506         TimeLeft
1507         Type
1508         Status
1509         Queue
1510     );
1511
1512     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1513         my $tempqueue = RT::Queue->new($RT::SystemUser);
1514         $tempqueue->Load( $ARGSRef->{'Queue'} );
1515         if ( $tempqueue->id ) {
1516             $ARGSRef->{'Queue'} = $tempqueue->id;
1517         }
1518     }
1519
1520     # Status isn't a field that can be set to a null value.
1521     # RT core complains if you try
1522     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1523
1524     my @results = UpdateRecordObject(
1525         AttributesRef => \@attribs,
1526         Object        => $TicketObj,
1527         ARGSRef       => $ARGSRef,
1528     );
1529
1530     # We special case owner changing, so we can use ForceOwnerChange
1531     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1532         my ($ChownType);
1533         if ( $ARGSRef->{'ForceOwnerChange'} ) {
1534             $ChownType = "Force";
1535         } else {
1536             $ChownType = "Give";
1537         }
1538
1539         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1540         push( @results, $msg );
1541     }
1542
1543     # }}}
1544
1545     return (@results);
1546 }
1547
1548 # }}}
1549
1550 sub ProcessTicketCustomFieldUpdates {
1551     my %args = @_;
1552     $args{'Object'} = delete $args{'TicketObj'};
1553     my $ARGSRef = { %{ $args{'ARGSRef'} } };
1554
1555     # Build up a list of objects that we want to work with
1556     my %custom_fields_to_mod;
1557     foreach my $arg ( keys %$ARGSRef ) {
1558         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1559             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1560         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1561             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1562         }
1563     }
1564
1565     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1566 }
1567
1568 sub ProcessObjectCustomFieldUpdates {
1569     my %args    = @_;
1570     my $ARGSRef = $args{'ARGSRef'};
1571     my @results;
1572
1573     # Build up a list of objects that we want to work with
1574     my %custom_fields_to_mod;
1575     foreach my $arg ( keys %$ARGSRef ) {
1576
1577         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1578         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1579
1580         # For each of those objects, find out what custom fields we want to work with.
1581         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1582     }
1583
1584     # For each of those objects
1585     foreach my $class ( keys %custom_fields_to_mod ) {
1586         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1587             my $Object = $args{'Object'};
1588             $Object = $class->new( $session{'CurrentUser'} )
1589                 unless $Object && ref $Object eq $class;
1590
1591             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1592             unless ( $Object->id ) {
1593                 $RT::Logger->warning("Couldn't load object $class #$id");
1594                 next;
1595             }
1596
1597             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1598                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1599                 $CustomFieldObj->LoadById($cf);
1600                 unless ( $CustomFieldObj->id ) {
1601                     $RT::Logger->warning("Couldn't load custom field #$cf");
1602                     next;
1603                 }
1604                 push @results,
1605                     _ProcessObjectCustomFieldUpdates(
1606                     Prefix      => "Object-$class-$id-CustomField-$cf-",
1607                     Object      => $Object,
1608                     CustomField => $CustomFieldObj,
1609                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
1610                     );
1611             }
1612         }
1613     }
1614     return @results;
1615 }
1616
1617 sub _ProcessObjectCustomFieldUpdates {
1618     my %args    = @_;
1619     my $cf      = $args{'CustomField'};
1620     my $cf_type = $cf->Type;
1621
1622     # Remove blank Values since the magic field will take care of this. Sometimes
1623     # the browser gives you a blank value which causes CFs to be processed twice
1624     if (   defined $args{'ARGS'}->{'Values'}
1625         && !length $args{'ARGS'}->{'Values'}
1626         && $args{'ARGS'}->{'Values-Magic'} )
1627     {
1628         delete $args{'ARGS'}->{'Values'};
1629     }
1630
1631     my @results;
1632     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1633
1634         # skip category argument
1635         next if $arg eq 'Category';
1636
1637         # since http won't pass in a form element with a null value, we need
1638         # to fake it
1639         if ( $arg eq 'Values-Magic' ) {
1640
1641             # We don't care about the magic, if there's really a values element;
1642             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
1643             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1644
1645             # "Empty" values does not mean anything for Image and Binary fields
1646             next if $cf_type =~ /^(?:Image|Binary)$/;
1647
1648             $arg = 'Values';
1649             $args{'ARGS'}->{'Values'} = undef;
1650         }
1651
1652         my @values = ();
1653         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1654             @values = @{ $args{'ARGS'}->{$arg} };
1655         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
1656             @values = ( $args{'ARGS'}->{$arg} );
1657         } else {
1658             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1659                 if defined $args{'ARGS'}->{$arg};
1660         }
1661         @values = grep length, map {
1662             s/\r+\n/\n/g;
1663             s/^\s+//;
1664             s/\s+$//;
1665             $_;
1666             }
1667             grep defined, @values;
1668
1669         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1670             foreach my $value (@values) {
1671                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1672                     Field => $cf->id,
1673                     Value => $value
1674                 );
1675                 push( @results, $msg );
1676             }
1677         } elsif ( $arg eq 'Upload' ) {
1678             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1679             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1680             push( @results, $msg );
1681         } elsif ( $arg eq 'DeleteValues' ) {
1682             foreach my $value (@values) {
1683                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1684                     Field => $cf,
1685                     Value => $value,
1686                 );
1687                 push( @results, $msg );
1688             }
1689         } elsif ( $arg eq 'DeleteValueIds' ) {
1690             foreach my $value (@values) {
1691                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1692                     Field   => $cf,
1693                     ValueId => $value,
1694                 );
1695                 push( @results, $msg );
1696             }
1697         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1698             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1699
1700             my %values_hash;
1701             foreach my $value (@values) {
1702                 if ( my $entry = $cf_values->HasEntry($value) ) {
1703                     $values_hash{ $entry->id } = 1;
1704                     next;
1705                 }
1706
1707                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1708                     Field => $cf,
1709                     Value => $value
1710                 );
1711                 push( @results, $msg );
1712                 $values_hash{$val} = 1 if $val;
1713             }
1714
1715             # For Date Cfs, @values is empty when there is no changes (no datas in form input)
1716             return @results if ( $cf->Type eq 'Date' && ! @values );
1717
1718             $cf_values->RedoSearch;
1719             while ( my $cf_value = $cf_values->Next ) {
1720                 next if $values_hash{ $cf_value->id };
1721
1722                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1723                     Field   => $cf,
1724                     ValueId => $cf_value->id
1725                 );
1726                 push( @results, $msg );
1727             }
1728         } elsif ( $arg eq 'Values' ) {
1729             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1730
1731             # keep everything up to the point of difference, delete the rest
1732             my $delete_flag;
1733             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1734                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1735                     shift @values;
1736                     next;
1737                 }
1738
1739                 $delete_flag ||= 1;
1740                 $old_cf->Delete;
1741             }
1742
1743             # now add/replace extra things, if any
1744             foreach my $value (@values) {
1745                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1746                     Field => $cf,
1747                     Value => $value
1748                 );
1749                 push( @results, $msg );
1750             }
1751         } else {
1752             push(
1753                 @results,
1754                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1755                     $cf->Name, ref $args{'Object'},
1756                     $args{'Object'}->id
1757                 )
1758             );
1759         }
1760     }
1761     return @results;
1762 }
1763
1764 # {{{ sub ProcessTicketWatchers
1765
1766 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1767
1768 Returns an array of results messages.
1769
1770 =cut
1771
1772 sub ProcessTicketWatchers {
1773     my %args = (
1774         TicketObj => undef,
1775         ARGSRef   => undef,
1776         @_
1777     );
1778     my (@results);
1779
1780     my $Ticket  = $args{'TicketObj'};
1781     my $ARGSRef = $args{'ARGSRef'};
1782
1783     # Munge watchers
1784
1785     foreach my $key ( keys %$ARGSRef ) {
1786
1787         # Delete deletable watchers
1788         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1789             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1790                 PrincipalId => $2,
1791                 Type        => $1
1792             );
1793             push @results, $msg;
1794         }
1795
1796         # Delete watchers in the simple style demanded by the bulk manipulator
1797         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1798             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1799                 Email => $ARGSRef->{$key},
1800                 Type  => $1
1801             );
1802             push @results, $msg;
1803         }
1804
1805         # Add new wathchers by email address
1806         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1807             and $key =~ /^WatcherTypeEmail(\d*)$/ )
1808         {
1809
1810             #They're in this order because otherwise $1 gets clobbered :/
1811             my ( $code, $msg ) = $Ticket->AddWatcher(
1812                 Type  => $ARGSRef->{$key},
1813                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1814             );
1815             push @results, $msg;
1816         }
1817
1818         #Add requestors in the simple style demanded by the bulk manipulator
1819         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1820             my ( $code, $msg ) = $Ticket->AddWatcher(
1821                 Type  => $1,
1822                 Email => $ARGSRef->{$key}
1823             );
1824             push @results, $msg;
1825         }
1826
1827         # Add new  watchers by owner
1828         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1829             my $principal_id = $1;
1830             my $form         = $ARGSRef->{$key};
1831             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1832                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1833
1834                 my ( $code, $msg ) = $Ticket->AddWatcher(
1835                     Type        => $value,
1836                     PrincipalId => $principal_id
1837                 );
1838                 push @results, $msg;
1839             }
1840         }
1841
1842     }
1843     return (@results);
1844 }
1845
1846 # }}}
1847
1848 # {{{ sub ProcessTicketDates
1849
1850 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1851
1852 Returns an array of results messages.
1853
1854 =cut
1855
1856 sub ProcessTicketDates {
1857     my %args = (
1858         TicketObj => undef,
1859         ARGSRef   => undef,
1860         @_
1861     );
1862
1863     my $Ticket  = $args{'TicketObj'};
1864     my $ARGSRef = $args{'ARGSRef'};
1865
1866     my (@results);
1867
1868     # {{{ Set date fields
1869     my @date_fields = qw(
1870         Told
1871         Resolved
1872         Starts
1873         Started
1874         Due
1875     );
1876
1877     #Run through each field in this list. update the value if apropriate
1878     foreach my $field (@date_fields) {
1879         next unless exists $ARGSRef->{ $field . '_Date' };
1880         next if $ARGSRef->{ $field . '_Date' } eq '';
1881
1882         my ( $code, $msg );
1883
1884         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
1885         $DateObj->Set(
1886             Format => 'unknown',
1887             Value  => $ARGSRef->{ $field . '_Date' }
1888         );
1889
1890         my $obj = $field . "Obj";
1891         if (    ( defined $DateObj->Unix )
1892             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
1893         {
1894             my $method = "Set$field";
1895             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
1896             push @results, "$msg";
1897         }
1898     }
1899
1900     # }}}
1901     return (@results);
1902 }
1903
1904 # }}}
1905
1906 # {{{ sub ProcessTicketLinks
1907
1908 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1909
1910 Returns an array of results messages.
1911
1912 =cut
1913
1914 sub ProcessTicketLinks {
1915     my %args = (
1916         TicketObj => undef,
1917         ARGSRef   => undef,
1918         @_
1919     );
1920
1921     my $Ticket  = $args{'TicketObj'};
1922     my $ARGSRef = $args{'ARGSRef'};
1923
1924     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
1925
1926     #Merge if we need to
1927     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
1928         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
1929         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
1930         push @results, $msg;
1931     }
1932
1933     return (@results);
1934 }
1935
1936 # }}}
1937
1938 sub ProcessRecordLinks {
1939     my %args = (
1940         RecordObj => undef,
1941         ARGSRef   => undef,
1942         @_
1943     );
1944
1945     my $Record  = $args{'RecordObj'};
1946     my $ARGSRef = $args{'ARGSRef'};
1947
1948     my (@results);
1949
1950     # Delete links that are gone gone gone.
1951     foreach my $arg ( keys %$ARGSRef ) {
1952         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
1953             my $base   = $1;
1954             my $type   = $2;
1955             my $target = $3;
1956
1957             my ( $val, $msg ) = $Record->DeleteLink(
1958                 Base   => $base,
1959                 Type   => $type,
1960                 Target => $target
1961             );
1962
1963             push @results, $msg;
1964
1965         }
1966
1967     }
1968
1969     my @linktypes = qw( DependsOn MemberOf RefersTo );
1970
1971     foreach my $linktype (@linktypes) {
1972         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
1973             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
1974                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
1975
1976             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
1977                 next unless $luri;
1978                 $luri =~ s/\s+$//;    # Strip trailing whitespace
1979                 my ( $val, $msg ) = $Record->AddLink(
1980                     Target => $luri,
1981                     Type   => $linktype
1982                 );
1983                 push @results, $msg;
1984             }
1985         }
1986         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
1987             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
1988                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
1989
1990             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
1991                 next unless $luri;
1992                 my ( $val, $msg ) = $Record->AddLink(
1993                     Base => $luri,
1994                     Type => $linktype
1995                 );
1996
1997                 push @results, $msg;
1998             }
1999         }
2000     }
2001
2002     return (@results);
2003 }
2004
2005 =head2 _UploadedFile ( $arg );
2006
2007 Takes a CGI parameter name; if a file is uploaded under that name,
2008 return a hash reference suitable for AddCustomFieldValue's use:
2009 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2010
2011 Returns C<undef> if no files were uploaded in the C<$arg> field.
2012
2013 =cut
2014
2015 sub _UploadedFile {
2016     my $arg         = shift;
2017     my $cgi_object  = $m->cgi_object;
2018     my $fh          = $cgi_object->upload($arg) or return undef;
2019     my $upload_info = $cgi_object->uploadInfo($fh);
2020
2021     my $filename = "$fh";
2022     $filename =~ s#^.*[\\/]##;
2023     binmode($fh);
2024
2025     return {
2026         Value        => $filename,
2027         LargeContent => do { local $/; scalar <$fh> },
2028         ContentType  => $upload_info->{'Content-Type'},
2029     };
2030 }
2031
2032 sub GetColumnMapEntry {
2033     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2034
2035     # deal with the simplest thing first
2036     if ( $args{'Map'}{ $args{'Name'} } ) {
2037         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2038     }
2039
2040     # complex things
2041     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2042         return undef unless $args{'Map'}->{$mainkey};
2043         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2044             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2045
2046         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2047     }
2048     return undef;
2049 }
2050
2051 sub ProcessColumnMapValue {
2052     my $value = shift;
2053     my %args = ( Arguments => [], Escape => 1, @_ );
2054
2055     if ( ref $value ) {
2056         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2057             my @tmp = $value->( @{ $args{'Arguments'} } );
2058             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2059         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2060             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2061         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2062             return $$value;
2063         }
2064     }
2065
2066     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2067     return $value;
2068 }
2069
2070 =head2 _load_container_object ( $type, $id );
2071
2072 Instantiate container object for saving searches.
2073
2074 =cut
2075
2076 sub _load_container_object {
2077     my ( $obj_type, $obj_id ) = @_;
2078     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2079 }
2080
2081 =head2 _parse_saved_search ( $arg );
2082
2083 Given a serialization string for saved search, and returns the
2084 container object and the search id.
2085
2086 =cut
2087
2088 sub _parse_saved_search {
2089     my $spec = shift;
2090     return unless $spec;
2091     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2092         return;
2093     }
2094     my $obj_type  = $1;
2095     my $obj_id    = $2;
2096     my $search_id = $3;
2097
2098     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2099 }
2100
2101 eval "require RT::Interface::Web_Vendor";
2102 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2103 eval "require RT::Interface::Web_Local";
2104 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );
2105
2106 1;