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 SendStaticFile
 558
 559 Takes a File => path and a Type => Content-type
 560
 561 If Type isn't provided and File is an image, it will
 562 figure out a sane Content-type, otherwise it will
 563 send application/octet-stream
 564
 565 Will set caching headers using StaticFileHeaders
 566
 567 =cut
 568
 569 sub SendStaticFile {
 570     my $self = shift;
 571     my %args = @_;
 572     my $file = $args{File};
 573     my $type = $args{Type};
 574
 575     $self->StaticFileHeaders();
 576
 577     unless ($type) {
 578         if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
 579             $type = "image/$1";
 580             $type =~ s/jpg/jpeg/gi;
 581         }
 582         $type ||= "application/octet-stream";
 583     }
 584     $HTML::Mason::Commands::r->content_type($type);
 585     open my $fh, "<$file" or die "couldn't open file: $!";
 586     binmode($fh);
 587     {
 588         local $/ = \16384;
 589         $HTML::Mason::Commands::m->out($_) while (<$fh>);
 590         $HTML::Mason::Commands::m->flush_buffer;
 591     }
 592     close $fh;
 593 }
 594
 595 sub StripContent {
 596     my %args    = @_;
 597     my $content = $args{Content};
 598     return '' unless $content;
 599
 600     # Make the content have no 'weird' newlines in it
 601     $content =~ s/\r+\n/\n/g;
 602
 603     my $return_content = $content;
 604
 605     my $html = $args{ContentType} && $args{ContentType} eq "text/html";
 606     my $sigonly = $args{StripSignature};
 607
 608     # massage content to easily detect if there's any real content
 609     $content =~ s/\s+//g; # yes! remove all the spaces
 610     if ( $html ) {
 611         # remove html version of spaces and newlines
 612         $content =~ s!&nbsp;!!g;
 613         $content =~ s!<br/?>!!g;
 614     }
 615
 616     # Filter empty content when type is text/html
 617     return '' if $html && $content !~ /\S/;
 618
 619     # If we aren't supposed to strip the sig, just bail now.
 620     return $return_content unless $sigonly;
 621
 622     # Find the signature
 623     my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
 624     $sig =~ s/\s+//g;
 625
 626     # Check for plaintext sig
 627     return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
 628
 629     # Check for html-formatted sig
 630     RT::Interface::Web::EscapeUTF8( \$sig );
 631     return ''
 632       if $html
 633           and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
 634
 635     # Pass it through
 636     return $return_content;
 637 }
 638
 639 sub DecodeARGS {
 640     my $ARGS = shift;
 641
 642     %{$ARGS} = map {
 643
 644         # if they've passed multiple values, they'll be an array. if they've
 645         # passed just one, a scalar whatever they are, mark them as utf8
 646         my $type = ref($_);
 647         ( !$type )
 648             ? Encode::is_utf8($_)
 649                 ? $_
 650                 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
 651             : ( $type eq 'ARRAY' )
 652             ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
 653                 @$_ ]
 654             : ( $type eq 'HASH' )
 655             ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
 656                 %$_ }
 657             : $_
 658     } %$ARGS;
 659 }
 660
 661 sub PreprocessTimeUpdates {
 662     my $ARGS = shift;
 663
 664     # Later in the code we use
 665     # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
 666     # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
 667     # The call_next method pass through original arguments and if you have
 668     # an argument with unicode key then in a next component you'll get two
 669     # records in the args hash: one with key without UTF8 flag and another
 670     # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
 671     # is copied from mason's source to get the same results as we get from
 672     # call_next method, this feature is not documented, so we just leave it
 673     # here to avoid possible side effects.
 674
 675     # This code canonicalizes time inputs in hours into minutes
 676     foreach my $field ( keys %$ARGS ) {
 677         next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
 678         my $local = $1;
 679         $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
 680                       {($1 || 0) + $3 ? $2 / $3 : 0}xe;
 681         if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
 682             $ARGS->{$local} *= 60;
 683         }
 684         delete $ARGS->{$field};
 685     }
 686
 687 }
 688
 689 sub MaybeEnableSQLStatementLog {
 690
 691     my $log_sql_statements = RT->Config->Get('StatementLog');
 692
 693     if ($log_sql_statements) {
 694         $RT::Handle->ClearSQLStatementLog;
 695         $RT::Handle->LogSQLStatements(1);
 696     }
 697
 698 }
 699
 700 sub LogRecordedSQLStatements {
 701     my $log_sql_statements = RT->Config->Get('StatementLog');
 702
 703     return unless ($log_sql_statements);
 704
 705     my @log = $RT::Handle->SQLStatementLog;
 706     $RT::Handle->ClearSQLStatementLog;
 707     for my $stmt (@log) {
 708         my ( $time, $sql, $bind, $duration ) = @{$stmt};
 709         my @bind;
 710         if ( ref $bind ) {
 711             @bind = @{$bind};
 712         } else {
 713
 714             # Older DBIx-SB
 715             $duration = $bind;
 716         }
 717         $RT::Logger->log(
 718             level   => $log_sql_statements,
 719             message => "SQL("
 720                 . sprintf( "%.6f", $duration )
 721                 . "s): $sql;"
 722                 . ( @bind ? "  [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
 723         );
 724     }
 725
 726 }
 727
 728 package HTML::Mason::Commands;
 729
 730 use vars qw/$r $m %session/;
 731
 732 # {{{ loc
 733
 734 =head2 loc ARRAY
 735
 736 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
 737 with whatever it's called with. If there is no $session{'CurrentUser'},
 738 it creates a temporary user, so we have something to get a localisation handle
 739 through
 740
 741 =cut
 742
 743 sub loc {
 744
 745     if ( $session{'CurrentUser'}
 746         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
 747     {
 748         return ( $session{'CurrentUser'}->loc(@_) );
 749     } elsif (
 750         my $u = eval {
 751             RT::CurrentUser->new();
 752         }
 753         )
 754     {
 755         return ( $u->loc(@_) );
 756     } else {
 757
 758         # pathetic case -- SystemUser is gone.
 759         return $_[0];
 760     }
 761 }
 762
 763 # }}}
 764
 765 # {{{ loc_fuzzy
 766
 767 =head2 loc_fuzzy STRING
 768
 769 loc_fuzzy is for handling localizations of messages that may already
 770 contain interpolated variables, typically returned from libraries
 771 outside RT's control.  It takes the message string and extracts the
 772 variable array automatically by matching against the candidate entries
 773 inside the lexicon file.
 774
 775 =cut
 776
 777 sub loc_fuzzy {
 778     my $msg = shift;
 779
 780     if ( $session{'CurrentUser'}
 781         && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
 782     {
 783         return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
 784     } else {
 785         my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
 786         return ( $u->loc_fuzzy($msg) );
 787     }
 788 }
 789
 790 # }}}
 791
 792 # {{{ sub Abort
 793 # Error - calls Error and aborts
 794 sub Abort {
 795     my $why  = shift;
 796     my %args = @_;
 797
 798     if (   $session{'ErrorDocument'}
 799         && $session{'ErrorDocumentType'} )
 800     {
 801         $r->content_type( $session{'ErrorDocumentType'} );
 802         $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
 803         $m->abort;
 804     } else {
 805         $m->comp( "/Elements/Error", Why => $why, %args );
 806         $m->abort;
 807     }
 808 }
 809
 810 # }}}
 811
 812 # {{{ sub CreateTicket
 813
 814 =head2 CreateTicket ARGS
 815
 816 Create a new ticket, using Mason's %ARGS.  returns @results.
 817
 818 =cut
 819
 820 sub CreateTicket {
 821     my %ARGS = (@_);
 822
 823     my (@Actions);
 824
 825     my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
 826
 827     my $Queue = new RT::Queue( $session{'CurrentUser'} );
 828     unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
 829         Abort('Queue not found');
 830     }
 831
 832     unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
 833         Abort('You have no permission to create tickets in that queue.');
 834     }
 835
 836     my $due;
 837     if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
 838         $due = new RT::Date( $session{'CurrentUser'} );
 839         $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
 840     }
 841     my $starts;
 842     if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
 843         $starts = new RT::Date( $session{'CurrentUser'} );
 844         $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
 845     }
 846
 847     my $sigless = RT::Interface::Web::StripContent(
 848         Content        => $ARGS{Content},
 849         ContentType    => $ARGS{ContentType},
 850         StripSignature => 1,
 851         CurrentUser    => $session{'CurrentUser'},
 852     );
 853
 854     my $MIMEObj = MakeMIMEEntity(
 855         Subject => $ARGS{'Subject'},
 856         From    => $ARGS{'From'},
 857         Cc      => $ARGS{'Cc'},
 858         Body    => $sigless,
 859         Type    => $ARGS{'ContentType'},
 860     );
 861
 862     if ( $ARGS{'Attachments'} ) {
 863         my $rv = $MIMEObj->make_multipart;
 864         $RT::Logger->error("Couldn't make multipart message")
 865             if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
 866
 867         foreach ( values %{ $ARGS{'Attachments'} } ) {
 868             unless ($_) {
 869                 $RT::Logger->error("Couldn't add empty attachemnt");
 870                 next;
 871             }
 872             $MIMEObj->add_part($_);
 873         }
 874     }
 875
 876     foreach my $argument (qw(Encrypt Sign)) {
 877         $MIMEObj->head->add( "X-RT-$argument" => $ARGS{$argument} ) if defined $ARGS{$argument};
 878     }
 879
 880     my %create_args = (
 881         Type => $ARGS{'Type'} || 'ticket',
 882         Queue => $ARGS{'Queue'},
 883         Owner => $ARGS{'Owner'},
 884
 885         # note: name change
 886         Requestor       => $ARGS{'Requestors'},
 887         Cc              => $ARGS{'Cc'},
 888         AdminCc         => $ARGS{'AdminCc'},
 889         InitialPriority => $ARGS{'InitialPriority'},
 890         FinalPriority   => $ARGS{'FinalPriority'},
 891         TimeLeft        => $ARGS{'TimeLeft'},
 892         TimeEstimated   => $ARGS{'TimeEstimated'},
 893         TimeWorked      => $ARGS{'TimeWorked'},
 894         Subject         => $ARGS{'Subject'},
 895         Status          => $ARGS{'Status'},
 896         Due             => $due ? $due->ISO : undef,
 897         Starts          => $starts ? $starts->ISO : undef,
 898         MIMEObj         => $MIMEObj
 899     );
 900
 901     my @temp_squelch;
 902     foreach my $type (qw(Requestor Cc AdminCc)) {
 903         push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
 904             if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
 905
 906     }
 907
 908     if (@temp_squelch) {
 909         require RT::Action::SendEmail;
 910         RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
 911     }
 912
 913     if ( $ARGS{'AttachTickets'} ) {
 914         require RT::Action::SendEmail;
 915         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
 916             ref $ARGS{'AttachTickets'}
 917             ? @{ $ARGS{'AttachTickets'} }
 918             : ( $ARGS{'AttachTickets'} ) );
 919     }
 920
 921     foreach my $arg ( keys %ARGS ) {
 922         next if $arg =~ /-(?:Magic|Category)$/;
 923
 924         if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
 925             $create_args{$arg} = $ARGS{$arg};
 926         }
 927
 928         # Object-RT::Ticket--CustomField-3-Values
 929         elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
 930             my $cfid = $1;
 931
 932             my $cf = RT::CustomField->new( $session{'CurrentUser'} );
 933             $cf->Load($cfid);
 934             unless ( $cf->id ) {
 935                 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
 936                 next;
 937             }
 938
 939             if ( $arg =~ /-Upload$/ ) {
 940                 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
 941                 next;
 942             }
 943
 944             my $type = $cf->Type;
 945
 946             my @values = ();
 947             if ( ref $ARGS{$arg} eq 'ARRAY' ) {
 948                 @values = @{ $ARGS{$arg} };
 949             } elsif ( $type =~ /text/i ) {
 950                 @values = ( $ARGS{$arg} );
 951             } else {
 952                 no warnings 'uninitialized';
 953                 @values = split /\r*\n/, $ARGS{$arg};
 954             }
 955             @values = grep length, map {
 956                 s/\r+\n/\n/g;
 957                 s/^\s+//;
 958                 s/\s+$//;
 959                 $_;
 960                 }
 961                 grep defined, @values;
 962
 963             $create_args{"CustomField-$cfid"} = \@values;
 964         }
 965     }
 966
 967     # turn new link lists into arrays, and pass in the proper arguments
 968     my %map = (
 969         'new-DependsOn' => 'DependsOn',
 970         'DependsOn-new' => 'DependedOnBy',
 971         'new-MemberOf'  => 'Parents',
 972         'MemberOf-new'  => 'Children',
 973         'new-RefersTo'  => 'RefersTo',
 974         'RefersTo-new'  => 'ReferredToBy',
 975     );
 976     foreach my $key ( keys %map ) {
 977         next unless $ARGS{$key};
 978         $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
 979
 980     }
 981
 982     my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
 983     unless ($id) {
 984         Abort($ErrMsg);
 985     }
 986
 987     push( @Actions, split( "\n", $ErrMsg ) );
 988     unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
 989         Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
 990     }
 991     return ( $Ticket, @Actions );
 992
 993 }
 994
 995 # }}}
 996
 997 # {{{ sub LoadTicket - loads a ticket
 998
 999 =head2  LoadTicket id
1000
1001 Takes a ticket id as its only variable. if it's handed an array, it takes
1002 the first value.
1003
1004 Returns an RT::Ticket object as the current user.
1005
1006 =cut
1007
1008 sub LoadTicket {
1009     my $id = shift;
1010
1011     if ( ref($id) eq "ARRAY" ) {
1012         $id = $id->[0];
1013     }
1014
1015     unless ($id) {
1016         Abort("No ticket specified");
1017     }
1018
1019     my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1020     $Ticket->Load($id);
1021     unless ( $Ticket->id ) {
1022         Abort("Could not load ticket $id");
1023     }
1024     return $Ticket;
1025 }
1026
1027 # }}}
1028
1029 # {{{ sub ProcessUpdateMessage
1030
1031 =head2 ProcessUpdateMessage
1032
1033 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1034
1035 Don't write message if it only contains current user's signature and
1036 SkipSignatureOnly argument is true. Function anyway adds attachments
1037 and updates time worked field even if skips message. The default value
1038 is true.
1039
1040 =cut
1041
1042 sub ProcessUpdateMessage {
1043
1044     my %args = (
1045         ARGSRef           => undef,
1046         TicketObj         => undef,
1047         SkipSignatureOnly => 1,
1048         @_
1049     );
1050
1051     if ( $args{ARGSRef}->{'UpdateAttachments'}
1052         && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1053     {
1054         delete $args{ARGSRef}->{'UpdateAttachments'};
1055     }
1056
1057     # Strip the signature
1058     $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1059         Content        => $args{ARGSRef}->{UpdateContent},
1060         ContentType    => $args{ARGSRef}->{UpdateContentType},
1061         StripSignature => $args{SkipSignatureOnly},
1062         CurrentUser    => $args{'TicketObj'}->CurrentUser,
1063     );
1064
1065     # If, after stripping the signature, we have no message, move the
1066     # UpdateTimeWorked into adjusted TimeWorked, so that a later
1067     # ProcessBasics can deal -- then bail out.
1068     if (    not $args{ARGSRef}->{'UpdateAttachments'}
1069         and not length $args{ARGSRef}->{'UpdateContent'} )
1070     {
1071         if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1072             $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1073         }
1074         return;
1075     }
1076
1077     if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1078         $args{ARGSRef}->{'UpdateSubject'} = undef;
1079     }
1080
1081     my $Message = MakeMIMEEntity(
1082         Subject => $args{ARGSRef}->{'UpdateSubject'},
1083         Body    => $args{ARGSRef}->{'UpdateContent'},
1084         Type    => $args{ARGSRef}->{'UpdateContentType'},
1085     );
1086
1087     $Message->head->add( 'Message-ID' => RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'}, ) );
1088     my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1089     if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1090         $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1091     } else {
1092         $old_txn = $args{TicketObj}->Transactions->First();
1093     }
1094
1095     if ( my $msg = $old_txn->Message->First ) {
1096         RT::Interface::Email::SetInReplyTo(
1097             Message   => $Message,
1098             InReplyTo => $msg
1099         );
1100     }
1101
1102     if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1103         $Message->make_multipart;
1104         $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1105     }
1106
1107     if ( $args{ARGSRef}->{'AttachTickets'} ) {
1108         require RT::Action::SendEmail;
1109         RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1110             ref $args{ARGSRef}->{'AttachTickets'}
1111             ? @{ $args{ARGSRef}->{'AttachTickets'} }
1112             : ( $args{ARGSRef}->{'AttachTickets'} ) );
1113     }
1114
1115     my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1116     my $cc  = $args{ARGSRef}->{'UpdateCc'};
1117
1118     my %message_args = (
1119         CcMessageTo  => $cc,
1120         BccMessageTo => $bcc,
1121         Sign         => $args{ARGSRef}->{'Sign'},
1122         Encrypt      => $args{ARGSRef}->{'Encrypt'},
1123         MIMEObj      => $Message,
1124         TimeTaken    => $args{ARGSRef}->{'UpdateTimeWorked'}
1125     );
1126
1127     unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1128         foreach my $key ( keys %{ $args{ARGSRef} } ) {
1129             next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1130
1131             my $var   = ucfirst($1) . 'MessageTo';
1132             my $value = $2;
1133             if ( $message_args{$var} ) {
1134                 $message_args{$var} .= ", $value";
1135             } else {
1136                 $message_args{$var} = $value;
1137             }
1138         }
1139     }
1140
1141     my @results;
1142     if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1143         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
1144         push( @results, $Description );
1145         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1146     } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1147         my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
1148         push( @results, $Description );
1149         $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1150     } else {
1151         push( @results,
1152             loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1153     }
1154     return @results;
1155 }
1156
1157 # }}}
1158
1159 # {{{ sub MakeMIMEEntity
1160
1161 =head2 MakeMIMEEntity PARAMHASH
1162
1163 Takes a paramhash Subject, Body and AttachmentFieldName.
1164
1165 Also takes Form, Cc and Type as optional paramhash keys.
1166
1167   Returns a MIME::Entity.
1168
1169 =cut
1170
1171 sub MakeMIMEEntity {
1172
1173     #TODO document what else this takes.
1174     my %args = (
1175         Subject             => undef,
1176         From                => undef,
1177         Cc                  => undef,
1178         Body                => undef,
1179         AttachmentFieldName => undef,
1180         Type                => undef,
1181         @_,
1182     );
1183     my $Message = MIME::Entity->build(
1184         Type    => 'multipart/mixed',
1185         Subject => $args{'Subject'} || "",
1186         From    => $args{'From'},
1187         Cc      => $args{'Cc'},
1188     );
1189
1190     if ( defined $args{'Body'} && length $args{'Body'} ) {
1191
1192         # Make the update content have no 'weird' newlines in it
1193         $args{'Body'} =~ s/\r\n/\n/gs;
1194
1195         # MIME::Head is not happy in utf-8 domain.  This only happens
1196         # when processing an incoming email (so far observed).
1197         no utf8;
1198         use bytes;
1199         $Message->attach(
1200             Type => $args{'Type'} || 'text/plain',
1201             Charset => 'UTF-8',
1202             Data    => $args{'Body'},
1203         );
1204     }
1205
1206     if ( $args{'AttachmentFieldName'} ) {
1207
1208         my $cgi_object = $m->cgi_object;
1209
1210         if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1211
1212             my ( @content, $buffer );
1213             while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1214                 push @content, $buffer;
1215             }
1216
1217             my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1218
1219             # Prefer the cached name first over CGI.pm stringification.
1220             my $filename = $RT::Mason::CGI::Filename;
1221             $filename = "$filehandle" unless defined($filename);
1222             $filename = Encode::decode_utf8($filename);
1223             $filename =~ s{^.*[\\/]}{};
1224
1225             $Message->attach(
1226                 Type     => $uploadinfo->{'Content-Type'},
1227                 Filename => $filename,
1228                 Data     => \@content,
1229             );
1230             if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1231                 $Message->head->set( 'Subject' => $filename );
1232             }
1233         }
1234     }
1235
1236     $Message->make_singlepart;
1237     RT::I18N::SetMIMEEntityToUTF8($Message);    # convert text parts into utf-8
1238
1239     return ($Message);
1240
1241 }
1242
1243 # }}}
1244
1245 # {{{ sub ParseDateToISO
1246
1247 =head2 ParseDateToISO
1248
1249 Takes a date in an arbitrary format.
1250 Returns an ISO date and time in GMT
1251
1252 =cut
1253
1254 sub ParseDateToISO {
1255     my $date = shift;
1256
1257     my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1258     $date_obj->Set(
1259         Format => 'unknown',
1260         Value  => $date
1261     );
1262     return ( $date_obj->ISO );
1263 }
1264
1265 # }}}
1266
1267 # {{{ sub ProcessACLChanges
1268
1269 sub ProcessACLChanges {
1270     my $ARGSref = shift;
1271
1272     #XXX: why don't we get ARGSref like in other Process* subs?
1273
1274     my @results;
1275
1276     foreach my $arg ( keys %$ARGSref ) {
1277         next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1278
1279         my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1280
1281         my @rights;
1282         if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1283             @rights = @{ $ARGSref->{$arg} };
1284         } else {
1285             @rights = $ARGSref->{$arg};
1286         }
1287         @rights = grep $_, @rights;
1288         next unless @rights;
1289
1290         my $principal = RT::Principal->new( $session{'CurrentUser'} );
1291         $principal->Load($principal_id);
1292
1293         my $obj;
1294         if ( $object_type eq 'RT::System' ) {
1295             $obj = $RT::System;
1296         } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1297             $obj = $object_type->new( $session{'CurrentUser'} );
1298             $obj->Load($object_id);
1299             unless ( $obj->id ) {
1300                 $RT::Logger->error("couldn't load $object_type #$object_id");
1301                 next;
1302             }
1303         } else {
1304             $RT::Logger->error("object type '$object_type' is incorrect");
1305             push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1306             next;
1307         }
1308
1309         foreach my $right (@rights) {
1310             my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1311             push( @results, $msg );
1312         }
1313     }
1314
1315     return (@results);
1316 }
1317
1318 # }}}
1319
1320 # {{{ sub UpdateRecordObj
1321
1322 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1323
1324 @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.
1325
1326 Returns an array of success/failure messages
1327
1328 =cut
1329
1330 sub UpdateRecordObject {
1331     my %args = (
1332         ARGSRef         => undef,
1333         AttributesRef   => undef,
1334         Object          => undef,
1335         AttributePrefix => undef,
1336         @_
1337     );
1338
1339     my $Object  = $args{'Object'};
1340     my @results = $Object->Update(
1341         AttributesRef   => $args{'AttributesRef'},
1342         ARGSRef         => $args{'ARGSRef'},
1343         AttributePrefix => $args{'AttributePrefix'},
1344     );
1345
1346     return (@results);
1347 }
1348
1349 # }}}
1350
1351 # {{{ Sub ProcessCustomFieldUpdates
1352
1353 sub ProcessCustomFieldUpdates {
1354     my %args = (
1355         CustomFieldObj => undef,
1356         ARGSRef        => undef,
1357         @_
1358     );
1359
1360     my $Object  = $args{'CustomFieldObj'};
1361     my $ARGSRef = $args{'ARGSRef'};
1362
1363     my @attribs = qw(Name Type Description Queue SortOrder);
1364     my @results = UpdateRecordObject(
1365         AttributesRef => \@attribs,
1366         Object        => $Object,
1367         ARGSRef       => $ARGSRef
1368     );
1369
1370     my $prefix = "CustomField-" . $Object->Id;
1371     if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
1372         my ( $addval, $addmsg ) = $Object->AddValue(
1373             Name        => $ARGSRef->{"$prefix-AddValue-Name"},
1374             Description => $ARGSRef->{"$prefix-AddValue-Description"},
1375             SortOrder   => $ARGSRef->{"$prefix-AddValue-SortOrder"},
1376         );
1377         push( @results, $addmsg );
1378     }
1379
1380     my @delete_values
1381         = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
1382         ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
1383         : ( $ARGSRef->{"$prefix-DeleteValue"} );
1384
1385     foreach my $id (@delete_values) {
1386         next unless defined $id;
1387         my ( $err, $msg ) = $Object->DeleteValue($id);
1388         push( @results, $msg );
1389     }
1390
1391     my $vals = $Object->Values();
1392     while ( my $cfv = $vals->Next() ) {
1393         if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
1394             if ( $cfv->SortOrder != $so ) {
1395                 my ( $err, $msg ) = $cfv->SetSortOrder($so);
1396                 push( @results, $msg );
1397             }
1398         }
1399     }
1400
1401     return (@results);
1402 }
1403
1404 # }}}
1405
1406 # {{{ sub ProcessTicketBasics
1407
1408 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1409
1410 Returns an array of results messages.
1411
1412 =cut
1413
1414 sub ProcessTicketBasics {
1415
1416     my %args = (
1417         TicketObj => undef,
1418         ARGSRef   => undef,
1419         @_
1420     );
1421
1422     my $TicketObj = $args{'TicketObj'};
1423     my $ARGSRef   = $args{'ARGSRef'};
1424
1425     # {{{ Set basic fields
1426     my @attribs = qw(
1427         Subject
1428         FinalPriority
1429         Priority
1430         TimeEstimated
1431         TimeWorked
1432         TimeLeft
1433         Type
1434         Status
1435         Queue
1436     );
1437
1438     if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
1439         my $tempqueue = RT::Queue->new($RT::SystemUser);
1440         $tempqueue->Load( $ARGSRef->{'Queue'} );
1441         if ( $tempqueue->id ) {
1442             $ARGSRef->{'Queue'} = $tempqueue->id;
1443         }
1444     }
1445
1446     # Status isn't a field that can be set to a null value.
1447     # RT core complains if you try
1448     delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
1449
1450     my @results = UpdateRecordObject(
1451         AttributesRef => \@attribs,
1452         Object        => $TicketObj,
1453         ARGSRef       => $ARGSRef,
1454     );
1455
1456     # We special case owner changing, so we can use ForceOwnerChange
1457     if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
1458         my ($ChownType);
1459         if ( $ARGSRef->{'ForceOwnerChange'} ) {
1460             $ChownType = "Force";
1461         } else {
1462             $ChownType = "Give";
1463         }
1464
1465         my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
1466         push( @results, $msg );
1467     }
1468
1469     # }}}
1470
1471     return (@results);
1472 }
1473
1474 # }}}
1475
1476 sub ProcessTicketCustomFieldUpdates {
1477     my %args = @_;
1478     $args{'Object'} = delete $args{'TicketObj'};
1479     my $ARGSRef = { %{ $args{'ARGSRef'} } };
1480
1481     # Build up a list of objects that we want to work with
1482     my %custom_fields_to_mod;
1483     foreach my $arg ( keys %$ARGSRef ) {
1484         if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
1485             $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
1486         } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
1487             $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
1488         }
1489     }
1490
1491     return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
1492 }
1493
1494 sub ProcessObjectCustomFieldUpdates {
1495     my %args    = @_;
1496     my $ARGSRef = $args{'ARGSRef'};
1497     my @results;
1498
1499     # Build up a list of objects that we want to work with
1500     my %custom_fields_to_mod;
1501     foreach my $arg ( keys %$ARGSRef ) {
1502
1503         # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
1504         next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
1505
1506         # For each of those objects, find out what custom fields we want to work with.
1507         $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
1508     }
1509
1510     # For each of those objects
1511     foreach my $class ( keys %custom_fields_to_mod ) {
1512         foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
1513             my $Object = $args{'Object'};
1514             $Object = $class->new( $session{'CurrentUser'} )
1515                 unless $Object && ref $Object eq $class;
1516
1517             $Object->Load($id) unless ( $Object->id || 0 ) == $id;
1518             unless ( $Object->id ) {
1519                 $RT::Logger->warning("Couldn't load object $class #$id");
1520                 next;
1521             }
1522
1523             foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
1524                 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
1525                 $CustomFieldObj->LoadById($cf);
1526                 unless ( $CustomFieldObj->id ) {
1527                     $RT::Logger->warning("Couldn't load custom field #$cf");
1528                     next;
1529                 }
1530                 push @results,
1531                     _ProcessObjectCustomFieldUpdates(
1532                     Prefix      => "Object-$class-$id-CustomField-$cf-",
1533                     Object      => $Object,
1534                     CustomField => $CustomFieldObj,
1535                     ARGS        => $custom_fields_to_mod{$class}{$id}{$cf},
1536                     );
1537             }
1538         }
1539     }
1540     return @results;
1541 }
1542
1543 sub _ProcessObjectCustomFieldUpdates {
1544     my %args    = @_;
1545     my $cf      = $args{'CustomField'};
1546     my $cf_type = $cf->Type;
1547
1548     # Remove blank Values since the magic field will take care of this. Sometimes
1549     # the browser gives you a blank value which causes CFs to be processed twice
1550     if (   defined $args{'ARGS'}->{'Values'}
1551         && !length $args{'ARGS'}->{'Values'}
1552         && $args{'ARGS'}->{'Values-Magic'} )
1553     {
1554         delete $args{'ARGS'}->{'Values'};
1555     }
1556
1557     my @results;
1558     foreach my $arg ( keys %{ $args{'ARGS'} } ) {
1559
1560         # skip category argument
1561         next if $arg eq 'Category';
1562
1563         # since http won't pass in a form element with a null value, we need
1564         # to fake it
1565         if ( $arg eq 'Values-Magic' ) {
1566
1567             # We don't care about the magic, if there's really a values element;
1568             next if defined $args{'ARGS'}->{'Value'}  && length $args{'ARGS'}->{'Value'};
1569             next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
1570
1571             # "Empty" values does not mean anything for Image and Binary fields
1572             next if $cf_type =~ /^(?:Image|Binary)$/;
1573
1574             $arg = 'Values';
1575             $args{'ARGS'}->{'Values'} = undef;
1576         }
1577
1578         my @values = ();
1579         if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
1580             @values = @{ $args{'ARGS'}->{$arg} };
1581         } elsif ( $cf_type =~ /text/i ) {    # Both Text and Wikitext
1582             @values = ( $args{'ARGS'}->{$arg} );
1583         } else {
1584             @values = split /\r*\n/, $args{'ARGS'}->{$arg}
1585                 if defined $args{'ARGS'}->{$arg};
1586         }
1587         @values = grep length, map {
1588             s/\r+\n/\n/g;
1589             s/^\s+//;
1590             s/\s+$//;
1591             $_;
1592             }
1593             grep defined, @values;
1594
1595         if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
1596             foreach my $value (@values) {
1597                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1598                     Field => $cf->id,
1599                     Value => $value
1600                 );
1601                 push( @results, $msg );
1602             }
1603         } elsif ( $arg eq 'Upload' ) {
1604             my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
1605             my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
1606             push( @results, $msg );
1607         } elsif ( $arg eq 'DeleteValues' ) {
1608             foreach my $value (@values) {
1609                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1610                     Field => $cf,
1611                     Value => $value,
1612                 );
1613                 push( @results, $msg );
1614             }
1615         } elsif ( $arg eq 'DeleteValueIds' ) {
1616             foreach my $value (@values) {
1617                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1618                     Field   => $cf,
1619                     ValueId => $value,
1620                 );
1621                 push( @results, $msg );
1622             }
1623         } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
1624             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1625
1626             my %values_hash;
1627             foreach my $value (@values) {
1628                 if ( my $entry = $cf_values->HasEntry($value) ) {
1629                     $values_hash{ $entry->id } = 1;
1630                     next;
1631                 }
1632
1633                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1634                     Field => $cf,
1635                     Value => $value
1636                 );
1637                 push( @results, $msg );
1638                 $values_hash{$val} = 1 if $val;
1639             }
1640
1641             $cf_values->RedoSearch;
1642             while ( my $cf_value = $cf_values->Next ) {
1643                 next if $values_hash{ $cf_value->id };
1644
1645                 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
1646                     Field   => $cf,
1647                     ValueId => $cf_value->id
1648                 );
1649                 push( @results, $msg );
1650             }
1651         } elsif ( $arg eq 'Values' ) {
1652             my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
1653
1654             # keep everything up to the point of difference, delete the rest
1655             my $delete_flag;
1656             foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
1657                 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
1658                     shift @values;
1659                     next;
1660                 }
1661
1662                 $delete_flag ||= 1;
1663                 $old_cf->Delete;
1664             }
1665
1666             # now add/replace extra things, if any
1667             foreach my $value (@values) {
1668                 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
1669                     Field => $cf,
1670                     Value => $value
1671                 );
1672                 push( @results, $msg );
1673             }
1674         } else {
1675             push(
1676                 @results,
1677                 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
1678                     $cf->Name, ref $args{'Object'},
1679                     $args{'Object'}->id
1680                 )
1681             );
1682         }
1683     }
1684     return @results;
1685 }
1686
1687 # {{{ sub ProcessTicketWatchers
1688
1689 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1690
1691 Returns an array of results messages.
1692
1693 =cut
1694
1695 sub ProcessTicketWatchers {
1696     my %args = (
1697         TicketObj => undef,
1698         ARGSRef   => undef,
1699         @_
1700     );
1701     my (@results);
1702
1703     my $Ticket  = $args{'TicketObj'};
1704     my $ARGSRef = $args{'ARGSRef'};
1705
1706     # Munge watchers
1707
1708     foreach my $key ( keys %$ARGSRef ) {
1709
1710         # Delete deletable watchers
1711         if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
1712             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1713                 PrincipalId => $2,
1714                 Type        => $1
1715             );
1716             push @results, $msg;
1717         }
1718
1719         # Delete watchers in the simple style demanded by the bulk manipulator
1720         elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
1721             my ( $code, $msg ) = $Ticket->DeleteWatcher(
1722                 Email => $ARGSRef->{$key},
1723                 Type  => $1
1724             );
1725             push @results, $msg;
1726         }
1727
1728         # Add new wathchers by email address
1729         elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
1730             and $key =~ /^WatcherTypeEmail(\d*)$/ )
1731         {
1732
1733             #They're in this order because otherwise $1 gets clobbered :/
1734             my ( $code, $msg ) = $Ticket->AddWatcher(
1735                 Type  => $ARGSRef->{$key},
1736                 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
1737             );
1738             push @results, $msg;
1739         }
1740
1741         #Add requestors in the simple style demanded by the bulk manipulator
1742         elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
1743             my ( $code, $msg ) = $Ticket->AddWatcher(
1744                 Type  => $1,
1745                 Email => $ARGSRef->{$key}
1746             );
1747             push @results, $msg;
1748         }
1749
1750         # Add new  watchers by owner
1751         elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
1752             my $principal_id = $1;
1753             my $form         = $ARGSRef->{$key};
1754             foreach my $value ( ref($form) ? @{$form} : ($form) ) {
1755                 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
1756
1757                 my ( $code, $msg ) = $Ticket->AddWatcher(
1758                     Type        => $value,
1759                     PrincipalId => $principal_id
1760                 );
1761                 push @results, $msg;
1762             }
1763         }
1764
1765     }
1766     return (@results);
1767 }
1768
1769 # }}}
1770
1771 # {{{ sub ProcessTicketDates
1772
1773 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1774
1775 Returns an array of results messages.
1776
1777 =cut
1778
1779 sub ProcessTicketDates {
1780     my %args = (
1781         TicketObj => undef,
1782         ARGSRef   => undef,
1783         @_
1784     );
1785
1786     my $Ticket  = $args{'TicketObj'};
1787     my $ARGSRef = $args{'ARGSRef'};
1788
1789     my (@results);
1790
1791     # {{{ Set date fields
1792     my @date_fields = qw(
1793         Told
1794         Resolved
1795         Starts
1796         Started
1797         Due
1798     );
1799
1800     #Run through each field in this list. update the value if apropriate
1801     foreach my $field (@date_fields) {
1802         next unless exists $ARGSRef->{ $field . '_Date' };
1803         next if $ARGSRef->{ $field . '_Date' } eq '';
1804
1805         my ( $code, $msg );
1806
1807         my $DateObj = RT::Date->new( $session{'CurrentUser'} );
1808         $DateObj->Set(
1809             Format => 'unknown',
1810             Value  => $ARGSRef->{ $field . '_Date' }
1811         );
1812
1813         my $obj = $field . "Obj";
1814         if (    ( defined $DateObj->Unix )
1815             and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
1816         {
1817             my $method = "Set$field";
1818             my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
1819             push @results, "$msg";
1820         }
1821     }
1822
1823     # }}}
1824     return (@results);
1825 }
1826
1827 # }}}
1828
1829 # {{{ sub ProcessTicketLinks
1830
1831 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
1832
1833 Returns an array of results messages.
1834
1835 =cut
1836
1837 sub ProcessTicketLinks {
1838     my %args = (
1839         TicketObj => undef,
1840         ARGSRef   => undef,
1841         @_
1842     );
1843
1844     my $Ticket  = $args{'TicketObj'};
1845     my $ARGSRef = $args{'ARGSRef'};
1846
1847     my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
1848
1849     #Merge if we need to
1850     if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
1851         $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
1852         my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
1853         push @results, $msg;
1854     }
1855
1856     return (@results);
1857 }
1858
1859 # }}}
1860
1861 sub ProcessRecordLinks {
1862     my %args = (
1863         RecordObj => undef,
1864         ARGSRef   => undef,
1865         @_
1866     );
1867
1868     my $Record  = $args{'RecordObj'};
1869     my $ARGSRef = $args{'ARGSRef'};
1870
1871     my (@results);
1872
1873     # Delete links that are gone gone gone.
1874     foreach my $arg ( keys %$ARGSRef ) {
1875         if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
1876             my $base   = $1;
1877             my $type   = $2;
1878             my $target = $3;
1879
1880             my ( $val, $msg ) = $Record->DeleteLink(
1881                 Base   => $base,
1882                 Type   => $type,
1883                 Target => $target
1884             );
1885
1886             push @results, $msg;
1887
1888         }
1889
1890     }
1891
1892     my @linktypes = qw( DependsOn MemberOf RefersTo );
1893
1894     foreach my $linktype (@linktypes) {
1895         if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
1896             $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
1897                 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
1898
1899             for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
1900                 next unless $luri;
1901                 $luri =~ s/\s+$//;    # Strip trailing whitespace
1902                 my ( $val, $msg ) = $Record->AddLink(
1903                     Target => $luri,
1904                     Type   => $linktype
1905                 );
1906                 push @results, $msg;
1907             }
1908         }
1909         if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
1910             $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
1911                 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
1912
1913             for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
1914                 next unless $luri;
1915                 my ( $val, $msg ) = $Record->AddLink(
1916                     Base => $luri,
1917                     Type => $linktype
1918                 );
1919
1920                 push @results, $msg;
1921             }
1922         }
1923     }
1924
1925     return (@results);
1926 }
1927
1928 =head2 _UploadedFile ( $arg );
1929
1930 Takes a CGI parameter name; if a file is uploaded under that name,
1931 return a hash reference suitable for AddCustomFieldValue's use:
1932 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
1933
1934 Returns C<undef> if no files were uploaded in the C<$arg> field.
1935
1936 =cut
1937
1938 sub _UploadedFile {
1939     my $arg         = shift;
1940     my $cgi_object  = $m->cgi_object;
1941     my $fh          = $cgi_object->upload($arg) or return undef;
1942     my $upload_info = $cgi_object->uploadInfo($fh);
1943
1944     my $filename = "$fh";
1945     $filename =~ s#^.*[\\/]##;
1946     binmode($fh);
1947
1948     return {
1949         Value        => $filename,
1950         LargeContent => do { local $/; scalar <$fh> },
1951         ContentType  => $upload_info->{'Content-Type'},
1952     };
1953 }
1954
1955 sub GetColumnMapEntry {
1956     my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
1957
1958     # deal with the simplest thing first
1959     if ( $args{'Map'}{ $args{'Name'} } ) {
1960         return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
1961     }
1962
1963     # complex things
1964     elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
1965         return undef unless $args{'Map'}->{$mainkey};
1966         return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
1967             unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
1968
1969         return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
1970     }
1971     return undef;
1972 }
1973
1974 sub ProcessColumnMapValue {
1975     my $value = shift;
1976     my %args = ( Arguments => [], Escape => 1, @_ );
1977
1978     if ( ref $value ) {
1979         if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
1980             my @tmp = $value->( @{ $args{'Arguments'} } );
1981             return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
1982         } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
1983             return join '', map ProcessColumnMapValue( $_, %args ), @$value;
1984         } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
1985             return $$value;
1986         }
1987     }
1988
1989     return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
1990     return $value;
1991 }
1992
1993 =head2 _load_container_object ( $type, $id );
1994
1995 Instantiate container object for saving searches.
1996
1997 =cut
1998
1999 sub _load_container_object {
2000     my ( $obj_type, $obj_id ) = @_;
2001     return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2002 }
2003
2004 =head2 _parse_saved_search ( $arg );
2005
2006 Given a serialization string for saved search, and returns the
2007 container object and the search id.
2008
2009 =cut
2010
2011 sub _parse_saved_search {
2012     my $spec = shift;
2013     return unless $spec;
2014     if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2015         return;
2016     }
2017     my $obj_type  = $1;
2018     my $obj_id    = $2;
2019     my $search_id = $3;
2020
2021     return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2022 }
2023
2024 eval "require RT::Interface::Web_Vendor";
2025 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm} );
2026 eval "require RT::Interface::Web_Local";
2027 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Web_Local.pm} );
2028
2029 1;