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             $cf_values->RedoSearch;
1718             while ( my $cf_value = $cf_values->Next ) {
1719                 next if $values_hash{ $cf_value->id };
1720
1721                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1722                     Field   => $cf,
1723                     ValueId => $cf_value->id
1724                 );
1725                 push( @results, $msg );
1726             }
1727         } elsif ( $arg eq 'Values' ) {
1728             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1729
1730             # keep everything up to the point of difference, delete the rest
1731             my $delete_flag;
1732             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1733                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1734                     shift @values;
1735                     next;
1736                 }
1737
1738                 $delete_flag ||= 1;
1739                 $old_cf->Delete;
1740             }
1741
1742             # now add/replace extra things, if any
1743             foreach my $value (@values) {
1744                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1745                     Field => $cf,
1746                     Value => $value
1747                 );
1748                 push( @results, $msg );
1749             }
1750         } else {
1751             push(
1752                 @results,
1753                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1754                     $cf->Name, ref $args{'Object'},
1755                     $args{'Object'}->id
1756                 )
1757             );
1758         }
1759     }
1760     return @results;
1761 }
1762
1763 # {{{ sub ProcessTicketWatchers
1764
1765 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1766
1767 Returns an array of results messages.
1768
1769 =cut
1770
1771 sub ProcessTicketWatchers {
1772     my %args = (
1773         TicketObj => undef,
1774         ARGSRef   => undef,
1775         @_
1776     );
1777     my (@results);
1778
1779     my $Ticket  = $args{'TicketObj'};
1780     my $ARGSRef = $args{'ARGSRef'};
1781
1782     # Munge watchers
1783
1784     foreach my $key ( keys %$ARGSRef ) {
1785
1786         # Delete deletable watchers
1787         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1788             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1789                 PrincipalId => $2,
1790                 Type        => $1
1791             );
1792             push @results, $msg;
1793         }
1794
1795         # Delete watchers in the simple style demanded by the bulk manipulator
1796         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1797             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1798                 Email => $ARGSRef->{$key},
1799                 Type  => $1
1800             );
1801             push @results, $msg;
1802         }
1803
1804         # Add new wathchers by email address
1805         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1806             and $key =~ /^WatcherTypeEmail(\d*)$/ )
1807         {
1808
1809             #They're in this order because otherwise $1 gets clobbered :/
1810             my ( $code, $msg ) = $Ticket->AddWatcher(
1811                 Type  => $ARGSRef->{$key},
1812                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1813             );
1814             push @results, $msg;
1815         }
1816
1817         #Add requestors in the simple style demanded by the bulk manipulator
1818         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1819             my ( $code, $msg ) = $Ticket->AddWatcher(
1820                 Type  => $1,
1821                 Email => $ARGSRef->{$key}
1822             );
1823             push @results, $msg;
1824         }
1825
1826         # Add new  watchers by owner
1827         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1828             my $principal_id = $1;
1829             my $form         = $ARGSRef->{$key};
1830             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1831                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1832
1833                 my ( $code, $msg ) = $Ticket->AddWatcher(
1834                     Type        => $value,
1835                     PrincipalId => $principal_id
1836                 );
1837                 push @results, $msg;
1838             }
1839         }
1840
1841     }
1842     return (@results);
1843 }
1844
1845 # }}}
1846
1847 # {{{ sub ProcessTicketDates
1848
1849 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1850
1851 Returns an array of results messages.
1852
1853 =cut
1854
1855 sub ProcessTicketDates {
1856     my %args = (
1857         TicketObj => undef,
1858         ARGSRef   => undef,
1859         @_
1860     );
1861
1862     my $Ticket  = $args{'TicketObj'};
1863     my $ARGSRef = $args{'ARGSRef'};
1864
1865     my (@results);
1866
1867     # {{{ Set date fields
1868     my @date_fields = qw(
1869         Told
1870         Resolved
1871         Starts
1872         Started
1873         Due
1874     );
1875
1876     #Run through each field in this list. update the value if apropriate
1877     foreach my $field (@date_fields) {
1878         next unless exists $ARGSRef->{ $field . '_Date' };
1879         next if $ARGSRef->{ $field . '_Date' } eq '';
1880
1881         my ( $code, $msg );
1882
1883         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
1884         $DateObj->Set(
1885             Format => 'unknown',
1886             Value  => $ARGSRef->{ $field . '_Date' }
1887         );
1888
1889         my $obj = $field . "Obj";
1890         if (    ( defined $DateObj->Unix )
1891             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
1892         {
1893             my $method = "Set$field";
1894             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
1895             push @results, "$msg";
1896         }
1897     }
1898
1899     # }}}
1900     return (@results);
1901 }
1902
1903 # }}}
1904
1905 # {{{ sub ProcessTicketLinks
1906
1907 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1908
1909 Returns an array of results messages.
1910
1911 =cut
1912
1913 sub ProcessTicketLinks {
1914     my %args = (
1915         TicketObj => undef,
1916         ARGSRef   => undef,
1917         @_
1918     );
1919
1920     my $Ticket  = $args{'TicketObj'};
1921     my $ARGSRef = $args{'ARGSRef'};
1922
1923     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
1924
1925     #Merge if we need to
1926     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
1927         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
1928         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
1929         push @results, $msg;
1930     }
1931
1932     return (@results);
1933 }
1934
1935 # }}}
1936
1937 sub ProcessRecordLinks {
1938     my %args = (
1939         RecordObj => undef,
1940         ARGSRef   => undef,
1941         @_
1942     );
1943
1944     my $Record  = $args{'RecordObj'};
1945     my $ARGSRef = $args{'ARGSRef'};
1946
1947     my (@results);
1948
1949     # Delete links that are gone gone gone.
1950     foreach my $arg ( keys %$ARGSRef ) {
1951         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
1952             my $base   = $1;
1953             my $type   = $2;
1954             my $target = $3;
1955
1956             my ( $val, $msg ) = $Record->DeleteLink(
1957                 Base   => $base,
1958                 Type   => $type,
1959                 Target => $target
1960             );
1961
1962             push @results, $msg;
1963
1964         }
1965
1966     }
1967
1968     my @linktypes = qw( DependsOn MemberOf RefersTo );
1969
1970     foreach my $linktype (@linktypes) {
1971         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
1972             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
1973                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
1974
1975             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
1976                 next unless $luri;
1977                 $luri =~ s/\s+$//;    # Strip trailing whitespace
1978                 my ( $val, $msg ) = $Record->AddLink(
1979                     Target => $luri,
1980                     Type   => $linktype
1981                 );
1982                 push @results, $msg;
1983             }
1984         }
1985         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
1986             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
1987                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
1988
1989             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
1990                 next unless $luri;
1991                 my ( $val, $msg ) = $Record->AddLink(
1992                     Base => $luri,
1993                     Type => $linktype
1994                 );
1995
1996                 push @results, $msg;
1997             }
1998         }
1999     }
2000
2001     return (@results);
2002 }
2003
2004 =head2 _UploadedFile ( $arg );
2005
2006 Takes a CGI parameter name; if a file is uploaded under that name,
2007 return a hash reference suitable for AddCustomFieldValue's use:
2008 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2009
2010 Returns C<undef> if no files were uploaded in the C<$arg> field.
2011
2012 =cut
2013
2014 sub _UploadedFile {
2015     my $arg         = shift;
2016     my $cgi_object  = $m->cgi_object;
2017     my $fh          = $cgi_object->upload($arg) or return undef;
2018     my $upload_info = $cgi_object->uploadInfo($fh);
2019
2020     my $filename = "$fh";
2021     $filename =~ s#^.*[\\/]##;
2022     binmode($fh);
2023
2024     return {
2025         Value        => $filename,
2026         LargeContent => do { local $/; scalar <$fh> },
2027         ContentType  => $upload_info->{'Content-Type'},
2028     };
2029 }
2030
2031 sub GetColumnMapEntry {
2032     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2033
2034     # deal with the simplest thing first
2035     if ( $args{'Map'}{ $args{'Name'} } ) {
2036         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2037     }
2038
2039     # complex things
2040     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2041         return undef unless $args{'Map'}->{$mainkey};
2042         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2043             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2044
2045         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2046     }
2047     return undef;
2048 }
2049
2050 sub ProcessColumnMapValue {
2051     my $value = shift;
2052     my %args = ( Arguments => [], Escape => 1, @_ );
2053
2054     if ( ref $value ) {
2055         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2056             my @tmp = $value->( @{ $args{'Arguments'} } );
2057             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2058         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2059             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2060         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2061             return $$value;
2062         }
2063     }
2064
2065     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2066     return $value;
2067 }
2068
2069 =head2 _load_container_object ( $type, $id );
2070
2071 Instantiate container object for saving searches.
2072
2073 =cut
2074
2075 sub _load_container_object {
2076     my ( $obj_type, $obj_id ) = @_;
2077     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2078 }
2079
2080 =head2 _parse_saved_search ( $arg );
2081
2082 Given a serialization string for saved search, and returns the
2083 container object and the search id.
2084
2085 =cut
2086
2087 sub _parse_saved_search {
2088     my $spec = shift;
2089     return unless $spec;
2090     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2091         return;
2092     }
2093     my $obj_type  = $1;
2094     my $obj_id    = $2;
2095     my $search_id = $3;
2096
2097     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2098 }
2099
2100 eval "require RT::Interface::Web_Vendor";
2101 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2102 eval "require RT::Interface::Web_Local";
2103 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );
2104
2105 1;