X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=rt%2Flib%2FRT%2FInterface%2FWeb.pm;h=af41e5ba6492cde95b4b7d189fcabb41750aeb2e;hp=1aae7581eb36f26be545e8a47a775e3ff58179c4;hb=de9d037528895f7151a9aead6724ce2df95f9586;hpb=0bff2e665b3a6389b47510e4c04a5a454f6dd7d4 diff --git a/rt/lib/RT/Interface/Web.pm b/rt/lib/RT/Interface/Web.pm index 1aae7581e..af41e5ba6 100644 --- a/rt/lib/RT/Interface/Web.pm +++ b/rt/lib/RT/Interface/Web.pm @@ -2,7 +2,7 @@ # # COPYRIGHT: # -# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC +# This software is Copyright (c) 1996-2017 Best Practical Solutions, LLC # # # (Except where explicitly superseded by other copyright notices) @@ -68,9 +68,9 @@ use URI qw(); use RT::Interface::Web::Menu; use RT::Interface::Web::Session; use Digest::MD5 (); -use Encode qw(); use List::MoreUtils qw(); use JSON qw(); +use Plack::Util; =head2 SquishedCSS $style @@ -100,6 +100,37 @@ sub SquishedJS { return $js; } +=head2 JSFiles + +=cut + +sub JSFiles { + return qw{ + jquery-1.9.1.min.js + jquery_noconflict.js + jquery-ui-1.10.0.custom.min.js + jquery-ui-timepicker-addon.js + jquery-ui-patch-datepicker.js + jquery.modal.min.js + jquery.modal-defaults.js + jquery.cookie.js + titlebox-state.js + i18n.js + util.js + autocomplete.js + jquery.event.hover-1.0.js + superfish.js + supersubs.js + jquery.supposition.js + history-folding.js + cascaded.js + forms.js + event-registration.js + late.js + /static/RichText/ckeditor.js + }, RT->Config->Get('JSFiles'); +} + =head2 ClearSquished Removes the cached CSS and JS entries, forcing them to be regenerated @@ -112,13 +143,13 @@ sub ClearSquished { %SQUISHED_CSS = (); } -=head2 EscapeUTF8 SCALARREF +=head2 EscapeHTML SCALARREF does a css-busting but minimalist escaping of whatever html you're passing in. =cut -sub EscapeUTF8 { +sub EscapeHTML { my $ref = shift; return unless defined $$ref; @@ -131,7 +162,15 @@ sub EscapeUTF8 { $$ref =~ s/'/'/g; } - +# Back-compat +# XXX: Remove in 4.4 +sub EscapeUTF8 { + RT->Deprecated( + Instead => "EscapeHTML", + Remove => "4.4", + ); + EscapeHTML(@_); +} =head2 EscapeURI SCALARREF @@ -149,13 +188,15 @@ sub EscapeURI { =head2 EncodeJSON SCALAR -Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple -value or a reference. +Encodes the SCALAR to JSON and returns a JSON Unicode (B UTF-8) string. +SCALAR may be a simple value or a reference. =cut sub EncodeJSON { - JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 }); + my $s = JSON::to_json(shift, { allow_nonref => 1 }); + $s =~ s{/}{\\/}g; + return $s; } sub _encode_surrogates { @@ -191,36 +232,29 @@ sub WebCanonicalizeInfo { -=head2 WebExternalAutoInfo($user); +=head2 WebRemoteUserAutocreateInfo($user); -Returns a hash of user attributes, used when WebExternalAuto is set. +Returns a hash of user attributes, used when WebRemoteUserAutocreate is set. =cut -sub WebExternalAutoInfo { +sub WebRemoteUserAutocreateInfo { my $user = shift; my %user_info; # default to making Privileged users, even if they specify # some other default Attributes - if ( !$RT::AutoCreate - || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) ) + if ( !$RT::UserAutocreateDefaultsOnLogin + || ( ref($RT::UserAutocreateDefaultsOnLogin) && not exists $RT::UserAutocreateDefaultsOnLogin->{Privileged} ) ) { $user_info{'Privileged'} = 1; } - if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) { - - # Populate fields with information from Unix /etc/passwd - - my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ]; - $user_info{'Comments'} = $comments if defined $comments; - $user_info{'RealName'} = $realname if defined $realname; - } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) { - - # Populate fields with information from NT domain controller - } + # Populate fields with information from Unix /etc/passwd + my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ]; + $user_info{'Comments'} = $comments if defined $comments; + $user_info{'RealName'} = $realname if defined $realname; # and return the wad of stuff return {%user_info}; @@ -266,6 +300,7 @@ sub HandleRequest { # make user info up to date $HTML::Mason::Commands::session{'CurrentUser'} ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id ); + undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'}; } else { $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new(); @@ -278,13 +313,17 @@ sub HandleRequest { MaybeShowNoAuthPage($ARGS); - AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn(); + AttemptExternalAuth($ARGS) if RT->Config->Get('WebRemoteUserContinuous') or not _UserLoggedIn(); _ForceLogout() unless _UserLoggedIn(); # Process per-page authentication callbacks $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' ); + if ( $ARGS->{'NotMobile'} ) { + $HTML::Mason::Commands::session{'NotMobile'} = 1; + } + unless ( _UserLoggedIn() ) { _ForceLogout(); @@ -296,20 +335,24 @@ sub HandleRequest { # REST urls get a special 401 response if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) { - $HTML::Mason::Commands::r->content_type("text/plain"); + $HTML::Mason::Commands::r->content_type("text/plain; charset=utf-8"); $m->error_format("text"); $m->out("RT/$RT::VERSION 401 Credentials required\n"); $m->out("\n$msg\n") if $msg; $m->abort; } - # Specially handle /index.html so that we get a nicer URL - elsif ( $m->request_comp->path eq '/index.html' ) { - my $next = SetNextPage(RT->Config->Get('WebURL')); - $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]); + # Specially handle /index.html and /m/index.html so that we get a nicer URL + elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) { + my $mobile = $1 ? 1 : 0; + my $next = SetNextPage($ARGS); + $m->comp('/NoAuth/Login.html', + next => $next, + actions => [$msg], + mobile => $mobile); $m->abort; } else { - TangentForLogin(results => ($msg ? LoginError($msg) : undef)); + TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef)); } } } @@ -325,7 +368,7 @@ sub HandleRequest { ShowRequestedPage($ARGS); LogRecordedSQLStatements(RequestData => { - Path => $HTML::Mason::Commands::m->request_comp->path, + Path => $HTML::Mason::Commands::m->request_path, }); # Process per-page final cleanup callbacks @@ -364,7 +407,7 @@ sub LoginError { return $key; } -=head2 SetNextPage [PATH] +=head2 SetNextPage ARGSRef [PATH] Intuits and stashes the next page in the sesssion hash. If PATH is specified, uses that instead of the value of L. Returns @@ -373,28 +416,88 @@ the hash value. =cut sub SetNextPage { - my $next = shift || IntuitNextPage(); + my $ARGS = shift; + my $next = $_[0] ? $_[0] : IntuitNextPage(); my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024)); + my $page = { url => $next }; + + # If an explicit URL was passed and we didn't IntuitNextPage, then + # IsPossibleCSRF below is almost certainly unrelated to the actual + # destination. Currently explicit next pages aren't used in RT, but the + # API is available. + if (not $_[0] and RT->Config->Get("RestrictReferrer")) { + # This isn't really CSRF, but the CSRF heuristics are useful for catching + # requests which may have unintended side-effects. + my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS); + if ($is_csrf) { + RT->Logger->notice( + "Marking original destination as having side-effects before redirecting for login.\n" + ."Request: $next\n" + ."Reason: " . HTML::Mason::Commands::loc($msg, @loc) + ); + $page->{'HasSideEffects'} = [$msg, @loc]; + } + } - $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $next; + $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page; $HTML::Mason::Commands::session{'i'}++; return $hash; } +=head2 FetchNextPage HASHKEY + +Returns the stashed next page hashref for the given hash. + +=cut + +sub FetchNextPage { + my $hash = shift || ""; + return $HTML::Mason::Commands::session{'NextPage'}->{$hash}; +} + +=head2 RemoveNextPage HASHKEY + +Removes the stashed next page for the given hash and returns it. + +=cut + +sub RemoveNextPage { + my $hash = shift || ""; + return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash}; +} -=head2 TangentForLogin [HASH] +=head2 TangentForLogin ARGSRef [HASH] Redirects to C, setting the value of L as -the next page. Optionally takes a hash which is dumped into query params. +the next page. Takes a hashref of request %ARGS as the first parameter. +Optionally takes all other parameters as a hash which is dumped into query +params. =cut sub TangentForLogin { - my $hash = SetNextPage(); + my $login = TangentForLoginURL(@_); + Redirect( RT->Config->Get('WebBaseURL') . $login ); +} + +=head2 TangentForLoginURL [HASH] + +Returns a URL suitable for tangenting for login. Optionally takes a hash which +is dumped into query params. + +=cut + +sub TangentForLoginURL { + my $ARGS = shift; + my $hash = SetNextPage($ARGS); my %query = (@_, next => $hash); - my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?'; + + $query{mobile} = 1 + if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)}; + + my $login = RT->Config->Get('WebPath') . '/NoAuth/Login.html?'; $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query); - Redirect($login); + return $login; } =head2 TangentForLoginWithError ERROR @@ -405,8 +508,9 @@ calls L with the appropriate results key. =cut sub TangentForLoginWithError { - my $key = LoginError(HTML::Mason::Commands::loc(@_)); - TangentForLogin( results => $key ); + my $ARGS = shift; + my $key = LoginError(HTML::Mason::Commands::loc(@_)); + TangentForLogin( $ARGS, results => $key ); } =head2 IntuitNextPage @@ -518,6 +622,7 @@ sub MaybeRejectPrivateComponentRequest { / # leading slash ( Elements | _elements | # mobile UI + Callbacks | Widgets | autohandler | # requesting this directly is suspicious l (_unsafe)? ) # loc component @@ -587,36 +692,37 @@ sub ShowRequestedPage { sub AttemptExternalAuth { my $ARGS = shift; - return unless ( RT->Config->Get('WebExternalAuth') ); + return unless ( RT->Config->Get('WebRemoteUserAuth') ); my $user = $ARGS->{user}; my $m = $HTML::Mason::Commands::m; - # If RT is configured for external auth, let's go through and get REMOTE_USER + my $logged_in_external_user = _UserLoggedIn() && $HTML::Mason::Commands::session{'WebExternallyAuthed'}; - # do we actually have a REMOTE_USER equivlent? - if ( RT::Interface::Web::WebCanonicalizeInfo() ) { - my $orig_user = $user; + # If RT is configured for external auth, let's go through and get REMOTE_USER + # Do we actually have a REMOTE_USER or equivalent? We only check auth if + # 1) we have no logged in user, or 2) we have a user who is externally + # authed. If we have a logged in user who is internally authed, don't + # check remote user otherwise we may log them out. + if (RT::Interface::Web::WebCanonicalizeInfo() + and (not _UserLoggedIn() or $logged_in_external_user) ) + { $user = RT::Interface::Web::WebCanonicalizeInfo(); - my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load'; - - if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) { - my $NodeName = Win32::NodeName(); - $user =~ s/^\Q$NodeName\E\\//i; - } + my $load_method = RT->Config->Get('WebRemoteUserGecos') ? 'LoadByGecos' : 'Load'; - my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''}; + my $next = RemoveNextPage($ARGS->{'next'}); + $next = $next->{'url'} if ref $next; InstantiateNewSession() unless _UserLoggedIn; $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new(); $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user); - if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) { + if ( RT->Config->Get('WebRemoteUserAutocreate') and not _UserLoggedIn() ) { # Create users on-the-fly my $UserObj = RT::User->new(RT->SystemUser); my ( $val, $msg ) = $UserObj->Create( - %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} }, + %{ ref RT->Config->Get('UserAutocreateDefaultsOnLogin') ? RT->Config->Get('UserAutocreateDefaultsOnLogin') : {} }, Name => $user, Gecos => $user, ); @@ -624,10 +730,10 @@ sub AttemptExternalAuth { if ($val) { # now get user specific information, to better create our user. - my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user); + my $new_user_info = RT::Interface::Web::WebRemoteUserAutocreateInfo($user); # set the attributes that have been defined. - foreach my $attribute ( $UserObj->WritableAttributes ) { + foreach my $attribute ( $UserObj->WritableAttributes, qw(Privileged Disabled) ) { $m->callback( Attribute => $attribute, User => $user, @@ -640,19 +746,13 @@ sub AttemptExternalAuth { } $HTML::Mason::Commands::session{'CurrentUser'}->Load($user); } else { - - # we failed to successfully create the user. abort abort abort. - delete $HTML::Mason::Commands::session{'CurrentUser'}; - - if (RT->Config->Get('WebFallbackToInternalAuth')) { - TangentForLoginWithError('Cannot create user: [_1]', $msg); - } else { - $m->abort(); - } + RT->Logger->error("Couldn't auto-create user '$user' when attempting WebRemoteUser: $msg"); + AbortExternalAuth( Error => "UserAutocreateDefaultsOnLogin" ); } } if ( _UserLoggedIn() ) { + $HTML::Mason::Commands::session{'WebExternallyAuthed'} = 1; $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' ); # It is possible that we did a redirect to the login page, # if the external auth allows lack of auth through with no @@ -664,26 +764,43 @@ sub AttemptExternalAuth { # straight-up external auth would always redirect to / # when you first hit it. } else { - delete $HTML::Mason::Commands::session{'CurrentUser'}; - $user = $orig_user; - - unless ( RT->Config->Get('WebFallbackToInternalAuth') ) { - TangentForLoginWithError('You are not an authorized user'); - } - } - } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) { - unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) { - # XXX unreachable due to prior defaulting in HandleRequest (check c34d108) - TangentForLoginWithError('You are not an authorized user'); + # Couldn't auth with the REMOTE_USER provided because an RT + # user doesn't exist and we're configured not to create one. + RT->Logger->error("Couldn't find internal user for '$user' when attempting WebRemoteUser and RT is not configured for auto-creation. Refer to `perldoc $RT::BasePath/docs/authentication.pod` if you want to allow auto-creation."); + AbortExternalAuth( + Error => "NoInternalUser", + User => $user, + ); } - } else { - - # WebExternalAuth is set, but we don't have a REMOTE_USER. abort - # XXX: we must return AUTH_REQUIRED status or we fallback to - # internal auth here too. - delete $HTML::Mason::Commands::session{'CurrentUser'} - if defined $HTML::Mason::Commands::session{'CurrentUser'}; } + elsif ($logged_in_external_user) { + # The logged in external user was deauthed by the auth system and we + # should kick them out. + AbortExternalAuth( Error => "Deauthorized" ); + } + elsif (not RT->Config->Get('WebFallbackToRTLogin')) { + # Abort if we don't want to fallback internally + AbortExternalAuth( Error => "NoRemoteUser" ); + } +} + +sub AbortExternalAuth { + my %args = @_; + my $error = $args{Error} ? "/Errors/WebRemoteUser/$args{Error}" : undef; + my $m = $HTML::Mason::Commands::m; + my $r = $HTML::Mason::Commands::r; + + _ForceLogout(); + + # Clear the decks, not that we should have partial content. + $m->clear_buffer; + + $r->status(403); + $m->comp($error, %args) + if $error and $m->comp_exists($error); + + # Return a 403 Forbidden or we may fallback to a login page with no form + $m->abort(403); } sub AttemptPasswordAuthentication { @@ -705,12 +822,13 @@ sub AttemptPasswordAuthentication { # It's important to nab the next page from the session before we blow # the session away - my $next = delete $HTML::Mason::Commands::session{'NextPage'}->{$ARGS->{'next'} || ''}; + my $next = RemoveNextPage($ARGS->{'next'}); + $next = $next->{'url'} if ref $next; InstantiateNewSession(); $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj; - $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' ); + $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler', RedirectTo => \$next ); # Really the only time we don't want to redirect here is if we were # passed user and pass as query params in the URL. @@ -745,7 +863,7 @@ sub LoadSessionFromCookie { my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef ); tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie; unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) { - undef $cookies{$cookiename}; + InstantiateNewSession(); } if ( int RT->Config->Get('AutoLogoff') ) { my $now = int( time / 60 ); @@ -778,6 +896,30 @@ sub SendSessionCookie { $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string; } +=head2 GetWebURLFromRequest + +People may use different web urls instead of C<$WebURL> in config. +Return the web url current user is using. + +=cut + +sub GetWebURLFromRequest { + + my $uri = URI->new( RT->Config->Get('WebURL') ); + + if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) { + $uri->scheme('https'); + } + else { + $uri->scheme('http'); + } + + # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST + $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'} ); + $uri->port( $ENV{'SERVER_PORT'} ); + return "$uri"; # stringify to be consistent with WebURL in config +} + =head2 Redirect URL This routine ells the current user's browser to redirect to URL. @@ -808,15 +950,10 @@ sub Redirect { && $uri->host eq $server_uri->host && $uri->port eq $server_uri->port ) { - if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) { - $uri->scheme('https'); - } else { - $uri->scheme('http'); - } - - # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST - $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'}); - $uri->port( $ENV{'SERVER_PORT'} ); + my $env_uri = URI->new(GetWebURLFromRequest()); + $uri->scheme($env_uri->scheme); + $uri->host($env_uri->host); + $uri->port($env_uri->port); } # not sure why, but on some systems without this call mason doesn't @@ -830,6 +967,53 @@ sub Redirect { $HTML::Mason::Commands::m->abort; } +=head2 GetStaticHeaders + +return an arrayref of Headers (currently, Cache-Control and Expires). + +=cut + +sub GetStaticHeaders { + my %args = @_; + + my $Visibility = 'private'; + if ( ! defined $args{Time} ) { + $args{Time} = 0; + } elsif ( $args{Time} eq 'no-cache' ) { + $args{Time} = 0; + } elsif ( $args{Time} eq 'forever' ) { + $args{Time} = 30 * 24 * 60 * 60; + $Visibility = 'public'; + } + + my $CacheControl = $args{Time} + ? sprintf "max-age=%d, %s", $args{Time}, $Visibility + : 'no-cache' + ; + + my $expires = RT::Date->new(RT->SystemUser); + $expires->SetToNow; + $expires->AddSeconds( $args{Time} ) if $args{Time}; + + return [ + Expires => $expires->RFC2616, + 'Cache-Control' => $CacheControl, + ]; +} + +=head2 CacheControlExpiresHeaders + +set both Cache-Control and Expires http headers + +=cut + +sub CacheControlExpiresHeaders { + Plack::Util::header_iter( GetStaticHeaders(@_), sub { + my ( $key, $val ) = @_; + $HTML::Mason::Commands::r->headers_out->{$key} = $val; + } ); +} + =head2 StaticFileHeaders Send the browser a few headers to try to get it to (somewhat agressively) @@ -840,24 +1024,12 @@ This routine could really use _accurate_ heuristics. (XXX TODO) =cut sub StaticFileHeaders { - my $date = RT::Date->new(RT->SystemUser); - - # make cache public - $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public'; - # remove any cookie headers -- if it is cached publicly, it # shouldn't include anyone's cookie! delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'}; # Expire things in a month. - $date->Set( Value => time + 30 * 24 * 60 * 60 ); - $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616; - - # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since' - # request, but we don't handle it and generate full reply again - # Last modified at server start time - # $date->Set( Value => $^T ); - # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616; + CacheControlExpiresHeaders( Time => 'forever' ); } =head2 ComponentPathIsSafe PATH @@ -865,15 +1037,15 @@ sub StaticFileHeaders { Takes C and returns a boolean indicating that the user-specified partial component path is safe. -Currently "safe" means that the path does not start with a dot (C<.>) and does -not contain a slash-dot C. +Currently "safe" means that the path does not start with a dot (C<.>), does +not contain a slash-dot C, and does not contain any nulls. =cut sub ComponentPathIsSafe { my $self = shift; my $path = shift; - return $path !~ m{(?:^|/)\.}; + return($path !~ m{(?:^|/)\.} and $path !~ m{\0}); } =head2 PathIsSafe @@ -1021,7 +1193,7 @@ sub StripContent { # Check for plaintext sig return '' if not $html and $content =~ /^(--)?\Q$sig\E$/; - # Check for html-formatted sig; we don't use EscapeUTF8 here + # Check for html-formatted sig; we don't use EscapeHTML here # because we want to precisely match the escapting that FCKEditor # uses. $sig =~ s/&/&/g; @@ -1038,21 +1210,25 @@ sub StripContent { sub DecodeARGS { my $ARGS = shift; + # Later in the code we use + # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS ); + # instead of $m->call_next to avoid problems with UTF8 keys in + # arguments. Specifically, the call_next method pass through + # original arguments, which are still the encoded bytes, not + # characters. "{ base_comp => $m->request_comp }" is copied from + # mason's source to get the same results as we get from call_next + # method; this feature is not documented. %{$ARGS} = map { # if they've passed multiple values, they'll be an array. if they've # passed just one, a scalar whatever they are, mark them as utf8 my $type = ref($_); ( !$type ) - ? Encode::is_utf8($_) - ? $_ - : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) + ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) : ( $type eq 'ARRAY' ) - ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } - @$_ ] + ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ] : ( $type eq 'HASH' ) - ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } - %$_ } + ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ } : $_ } %$ARGS; } @@ -1060,17 +1236,6 @@ sub DecodeARGS { sub PreprocessTimeUpdates { my $ARGS = shift; - # Later in the code we use - # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS ); - # instead of $m->call_next to avoid problems with UTF8 keys in arguments. - # The call_next method pass through original arguments and if you have - # an argument with unicode key then in a next component you'll get two - # records in the args hash: one with key without UTF8 flag and another - # with the flag, which may result into errors. "{ base_comp => $m->request_comp }" - # is copied from mason's source to get the same results as we get from - # call_next method, this feature is not documented, so we just leave it - # here to avoid possible side effects. - # This code canonicalizes time inputs in hours into minutes foreach my $field ( keys %$ARGS ) { next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1}; @@ -1140,32 +1305,35 @@ sub ValidateWebConfig { return if $_has_validated_web_config; $_has_validated_web_config = 1; - if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) { - $RT::Logger->warn("The actual SERVER_PORT ($ENV{SERVER_PORT}) does NOT match the configured WebPort ($RT::WebPort). Perhaps you should Set(\$WebPort, $ENV{SERVER_PORT}); in RT_SiteConfig.pm, otherwise your internal links may be broken."); - } - - if ($ENV{HTTP_HOST}) { - # match "example.com" or "example.com:80" - my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/; + my $port = $ENV{SERVER_PORT}; + my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER} + || $ENV{HTTP_HOST} || $ENV{SERVER_NAME}; + ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/; - if ($host ne RT->Config->Get('WebDomain')) { - $RT::Logger->warn("The actual HTTP_HOST ($host) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, otherwise your internal links may be broken."); - } + if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) { + $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). " + ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, " + ."otherwise your internal hyperlinks may be broken."); } - else { - if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) { - $RT::Logger->warn("The actual SERVER_NAME ($ENV{SERVER_NAME}) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$ENV{SERVER_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken."); - } + + if ( $host ne RT->Config->Get('WebDomain') ) { + $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). " + ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, " + ."otherwise your internal hyperlinks may be broken."); } - #i don't understand how this was ever expected to work - # (even without our dum double // hack)?? - #if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) { - ( my $WebPath = RT->Config->Get('WebPath') ) =~ s(/+)(/)g; - ( my $script_name = $ENV{SCRIPT_NAME} ) =~ s(/+)(/)g; - my $script_name_prefix = substr($script_name, 0, length($WebPath)); - if ( $script_name_prefix ne $WebPath ) { - $RT::Logger->warn("The actual SCRIPT_NAME ($script_name) does NOT match the configured WebPath ($WebPath). Perhaps you should Set(\$WebPath, '$script_name_prefix'); in RT_SiteConfig.pm, otherwise your internal links may be broken."); + return; #next warning flooding our logs, doesn't seem applicable to our use + # (SCRIPT_NAME is the full path, WebPath is just the beginning) + #in vanilla RT does something eat the local part of SCRIPT_NAME 1st? + + # Unfortunately, there is no reliable way to get the _path_ that was + # requested at the proxy level; simply disable this warning if we're + # proxied and there's a mismatch. + my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}; + if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) { + $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). " + ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, " + ."otherwise your internal hyperlinks may be broken."); } } @@ -1186,7 +1354,17 @@ sub ComponentRoots { return @roots; } -our %is_whitelisted_component = ( +sub StaticRoots { + my $self = shift; + my @static = ( + $RT::LocalStaticPath, + (map { $_->StaticDir } @{RT->Plugins}), + $RT::StaticPath, + ); + return grep { $_ and -d $_ } @static; +} + +our %IS_WHITELISTED_COMPONENT = ( # The RSS feed embeds an auth token in the path, but query # information for the search. Because it's a straight-up read, in # addition to embedding its own auth, it's fine. @@ -1195,17 +1373,62 @@ our %is_whitelisted_component = ( # While these can be used for denial-of-service against RT # (construct a very inefficient query and trick lots of users into # running them against RT) it's incredibly useful to be able to link - # to a search result or bookmark a result page. + # to a search result (or chart) or bookmark a result page. '/Search/Results.html' => 1, '/Search/Simple.html' => 1, - '/m/tickets/search' => 1, + '/m/tickets/search' => 1, + '/Search/Chart.html' => 1, + '/User/Search.html' => 1, + + # This page takes Attachment and Transaction argument to figure + # out what to show, but it's read only and will deny information if you + # don't have ShowOutgoingEmail. + '/Ticket/ShowEmailRecord.html' => 1, +); + +# Whitelist arguments that do not indicate an effectful request. +our @GLOBAL_WHITELISTED_ARGS = ( + # For example, "id" is acceptable because that is how RT retrieves a + # record. + 'id', + + # If they have a results= from MaybeRedirectForResults, that's also fine. + 'results', + + # The homepage refresh, which uses the Refresh header, doesn't send + # a referer in most browsers; whitelist the one parameter it reloads + # with, HomeRefreshInterval, which is safe + 'HomeRefreshInterval', + + # The NotMobile flag is fine for any page; it's only used to toggle a flag + # in the session related to which interface you get. + 'NotMobile', +); + +our %WHITELISTED_COMPONENT_ARGS = ( + # SavedSearchLoad - This happens when you middle-(or ⌘ )-click "Edit" for a saved search on + # the homepage. It's not going to do any damage + # NewQuery - This is simply to clear the search query + '/Search/Build.html' => ['SavedSearchLoad','NewQuery'], + # Happens if you try and reply to a message in the ticket history or click a number + # of options on a tickets Action menu + '/Ticket/Update.html' => ['QuoteTransaction', 'Action', 'DefaultStatus'], + # Action->Extract Article on a ticket's menu + '/Articles/Article/ExtractIntoClass.html' => ['Ticket'], +); + +# Components which are blacklisted from automatic, argument-based whitelisting. +# These pages are not idempotent when called with just an id. +our %IS_BLACKLISTED_COMPONENT = ( + # Takes only id and toggles bookmark state + '/Helpers/Toggle/TicketBookmark' => 1, ); sub IsCompCSRFWhitelisted { my $comp = shift; my $ARGS = shift; - return 1 if $is_whitelisted_component{$comp}; + return 1 if $IS_WHITELISTED_COMPONENT{$comp}; my %args = %{ $ARGS }; @@ -1213,7 +1436,7 @@ sub IsCompCSRFWhitelisted { # golden. This acts on the presumption that external forms may # hardcode a username and password -- if a malicious attacker knew # both already, CSRF is the least of your problems. - my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin'); + my $AllowLoginCSRF = not RT->Config->Get('RestrictLoginReferrer'); if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) { my $user_obj = RT::CurrentUser->new(); $user_obj->Load($args{user}); @@ -1223,26 +1446,40 @@ sub IsCompCSRFWhitelisted { delete $args{pass}; } - # Eliminate arguments that do not indicate an effectful request. - # For example, "id" is acceptable because that is how RT retrieves a - # record. - delete $args{id}; + # Some pages aren't idempotent even with safe args like id; blacklist + # them from the automatic whitelisting below. + return 0 if $IS_BLACKLISTED_COMPONENT{$comp}; - # If they have a valid results= from MaybeRedirectForResults, that's - # also fine. - delete $args{results} if $args{results} - and $HTML::Mason::Commands::session{"Actions"}->{$args{results}}; + if ( my %csrf_config = RT->Config->Get('ReferrerComponents') ) { + my $value = $csrf_config{$comp}; + if ( ref $value eq 'ARRAY' ) { + delete $args{$_} for @$value; + return %args ? 0 : 1; + } + else { + return $value ? 1 : 0; + } + } - # The homepage refresh, which uses the Refresh header, doesn't send - # a referer in most browsers; whitelist the one parameter it reloads - # with, HomeRefreshInterval, which is safe - delete $args{HomeRefreshInterval}; + return AreCompCSRFParametersWhitelisted($comp, \%args); +} + +sub AreCompCSRFParametersWhitelisted { + my $sub = shift; + my $ARGS = shift; + + my %leftover_args = %{ $ARGS }; + + # Join global whitelist and component-specific whitelist + my @whitelisted_args = (@GLOBAL_WHITELISTED_ARGS, @{ $WHITELISTED_COMPONENT_ARGS{$sub} || [] }); + + for my $arg (@whitelisted_args) { + delete $leftover_args{$arg}; + } # If there are no arguments, then it's likely to be an idempotent # request, which are not susceptible to CSRF - return 1 if !%args; - - return 0; + return !%leftover_args; } sub IsRefererCSRFWhitelisted { @@ -1363,7 +1600,7 @@ sub ExpandCSRFToken { if ($data->{attach}) { my $filename = $data->{attach}{filename}; my $mime = $data->{attach}{mime}; - $HTML::Mason::Commands::session{'Attachments'}{$filename} + $HTML::Mason::Commands::session{'Attachments'}{$ARGS->{'Token'}||''}{$filename} = $mime; } @@ -1383,8 +1620,12 @@ sub StoreRequestToken { if ($ARGS->{Attach}) { my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' ); my $file_path = delete $ARGS->{'Attach'}; + + # This needs to be decoded because the value is a reference; + # hence it was not decoded along with all of the standard + # arguments in DecodeARGS $data->{attach} = { - filename => Encode::decode_utf8("$file_path"), + filename => Encode::decode("UTF-8", "$file_path"), mime => $attachment, }; } @@ -1412,17 +1653,209 @@ sub MaybeShowInterstitialCSRFPage { my $token = StoreRequestToken($ARGS); $HTML::Mason::Commands::m->comp( '/Elements/CSRF', - OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info, + OriginalURL => RT->Config->Get('WebBaseURL') . RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info, Reason => HTML::Mason::Commands::loc( $msg, @loc ), Token => $token, ); # Calls abort, never gets here } +our @POTENTIAL_PAGE_ACTIONS = ( + qr'/Ticket/Create.html' => "create a ticket", # loc + qr'/Ticket/' => "update a ticket", # loc + qr'/Admin/' => "modify RT's configuration", # loc + qr'/Approval/' => "update an approval", # loc + qr'/Articles/' => "update an article", # loc + qr'/Dashboards/' => "modify a dashboard", # loc + qr'/m/ticket/' => "update a ticket", # loc + qr'Prefs' => "modify your preferences", # loc + qr'/Search/' => "modify or access a search", # loc + qr'/SelfService/Create' => "create a ticket", # loc + qr'/SelfService/' => "update a ticket", # loc +); + +sub PotentialPageAction { + my $page = shift; + my @potentials = @POTENTIAL_PAGE_ACTIONS; + while (my ($pattern, $result) = splice @potentials, 0, 2) { + return HTML::Mason::Commands::loc($result) + if $page =~ $pattern; + } + return ""; +} + +=head2 RewriteInlineImages PARAMHASH + +Turns C<< >> elements in HTML into working images pointing +back to RT's stored copy. + +Takes the following parameters: + +=over 4 + +=item Content + +Scalar ref of the HTML content to rewrite. Modified in place to support the +most common use-case. + +=item Attachment + +The L object from which the Content originates. + +=item Related (optional) + +Array ref of related L objects to use for C matching. + +Defaults to the result of the C method on the passed Attachment. + +=item AttachmentPath (optional) + +The base path to use when rewriting C attributes. + +Defaults to C< $WebPath/Ticket/Attachment > + +=back + +In scalar context, returns the number of elements rewritten. + +In list content, returns the attachments IDs referred to by the rewritten +elements, in the order found. There may be duplicates. + +=cut + +sub RewriteInlineImages { + my %args = ( + Content => undef, + Attachment => undef, + Related => undef, + AttachmentPath => RT->Config->Get('WebPath')."/Ticket/Attachment", + @_ + ); + + return unless defined $args{Content} + and ref $args{Content} eq 'SCALAR' + and defined $args{Attachment}; + + my $related_part = $args{Attachment}->Closest("multipart/related") + or return; + + $args{Related} ||= $related_part->Children->ItemsArrayRef; + return unless @{$args{Related}}; + + my $content = $args{'Content'}; + my @rewritten; + + require HTML::RewriteAttributes::Resources; + $$content = HTML::RewriteAttributes::Resources->rewrite($$content, sub { + my $cid = shift; + my %meta = @_; + return $cid unless lc $meta{tag} eq 'img' + and lc $meta{attr} eq 'src' + and $cid =~ s/^cid://i; + + for my $attach (@{$args{Related}}) { + if (($attach->GetHeader('Content-ID') || '') =~ /^(<)?\Q$cid\E(?(1)>)$/) { + push @rewritten, $attach->Id; + return "$args{AttachmentPath}/" . $attach->TransactionId . '/' . $attach->Id; + } + } + + # No attachments means this is a bogus CID. Just pass it through. + RT->Logger->debug(qq[Found bogus inline image src="cid:$cid"]); + return "cid:$cid"; + }); + return @rewritten; +} + +=head2 GetCustomFieldInputName(CustomField => $cf_object, Object => $object, Grouping => $grouping_name) + +Returns the standard custom field input name; this is complementary to +L. Takes the following arguments: + +=over + +=item CustomField => I object> + +Required. + +=item Object => I + +The object that the custom field is applied to; optional. If omitted, +defaults to a new object of the appropriate class for the custom field. + +=item Grouping => I + +The grouping that the custom field is being rendered in. Groupings +allow a custom field to appear in more than one location per form. + +=back + +=cut + +sub GetCustomFieldInputName { + my %args = ( + CustomField => undef, + Object => undef, + Grouping => undef, + @_, + ); + + my $name = GetCustomFieldInputNamePrefix(%args); + + if ( $args{CustomField}->Type eq 'Select' ) { + if ( $args{CustomField}->RenderType eq 'List' and $args{CustomField}->SingleValue ) { + $name .= 'Value'; + } + else { + $name .= 'Values'; + } + } + elsif ( $args{CustomField}->Type =~ /^(?:Binary|Image)$/ ) { + $name .= 'Upload'; + } + elsif ( $args{CustomField}->Type =~ /^(?:Date|DateTime|Text|Wikitext)$/ ) { + $name .= 'Values'; + } + else { + if ( $args{CustomField}->SingleValue ) { + $name .= 'Value'; + } + else { + $name .= 'Values'; + } + } + + return $name; +} + +=head2 GetCustomFieldInputNamePrefix(CustomField => $cf_object, Object => $object, Grouping => $grouping_name) + +Returns the standard custom field input name prefix(without "Value" or alike suffix) + +=cut + +sub GetCustomFieldInputNamePrefix { + my %args = ( + CustomField => undef, + Object => undef, + Grouping => undef, + @_, + ); + + my $prefix = join '-', 'Object', ref( $args{Object} ) || $args{CustomField}->ObjectTypeFromLookupType, + ( $args{Object} && $args{Object}->id ? $args{Object}->id : '' ), + 'CustomField' . ( $args{Grouping} ? ":$args{Grouping}" : '' ), + $args{CustomField}->id, ''; + + return $prefix; +} + package HTML::Mason::Commands; use vars qw/$r $m %session/; +use Scalar::Util qw(blessed); + sub Menu { return $HTML::Mason::Commands::m->notes('menu'); } @@ -1435,7 +1868,96 @@ sub PageWidgets { return $HTML::Mason::Commands::m->notes('page-widgets'); } +sub RenderMenu { + my %args = (toplevel => 1, parent_id => '', depth => 0, @_); + return unless $args{'menu'}; + + my ($menu, $depth, $toplevel, $id, $parent_id) + = @args{qw(menu depth toplevel id parent_id)}; + + my $interp = $m->interp; + my $web_path = RT->Config->Get('WebPath'); + + my $res = ''; + $res .= ' ' x $depth; + $res .= 'apply_escapes($id, 'h') .'"' + if $id; + $res .= ' class="toplevel"' if $toplevel; + $res .= ">\n"; + + for my $child ($menu->children) { + $res .= ' 'x ($depth+1); + + my $item_id = lc(($parent_id? "$parent_id-" : "") .$child->key); + $item_id =~ s/\s/-/g; + my $eitem_id = $interp->apply_escapes($item_id, 'h'); + $res .= qq{
  • has_children; + push @classes, 'active' if $child->active; + $res .= ' class="'. join( ' ', @classes ) .'"' + if @classes; + + $res .= '>'; + + if ( my $tmp = $child->raw_html ) { + $res .= $tmp; + } else { + $res .= qq{path; + my $url = (not $path or $path =~ m{^\w+:/}) ? $path : $web_path . $path; + $url ||= "#"; + $res .= ' href="'. $interp->apply_escapes($url, 'h') .'"'; + + if ( $tmp = $child->target ) { + $res .= ' target="'. $interp->apply_escapes($tmp, 'h') .'"' + } + + if ($child->attributes) { + for my $key (keys %{$child->attributes}) { + my ($name, $value) = map { $interp->apply_escapes($_, 'h') } + $key, $child->attributes->{$key}; + $res .= " $name=\"$value\""; + } + } + $res .= '>'; + + if ( $child->escape_title ) { + $res .= $interp->apply_escapes($child->title, 'h'); + } else { + $res .= $child->title; + } + $res .= ''; + } + if ( $child->has_children ) { + $res .= "\n"; + $res .= RenderMenu( + menu => $child, + toplevel => 0, + parent_id => $item_id, + depth => $depth+1, + return => 1, + ); + $res .= "\n"; + $res .= ' ' x ($depth+1); + } + $res .= "
    • \n"; + } + $res .= ' ' x $depth; + $res .= ''; + return $res if $args{'return'}; + + $m->print($res); + return ''; +} =head2 loc ARRAY @@ -1594,9 +2116,10 @@ sub CreateTicket { my (@Actions); - my $Ticket = RT::Ticket->new( $session{'CurrentUser'} ); + my $current_user = $session{'CurrentUser'}; + my $Ticket = RT::Ticket->new( $current_user ); - my $Queue = RT::Queue->new( $session{'CurrentUser'} ); + my $Queue = RT::Queue->new( $current_user ); unless ( $Queue->Load( $ARGS{'Queue'} ) ) { Abort('Queue not found'); } @@ -1607,12 +2130,12 @@ sub CreateTicket { my $due; if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) { - $due = RT::Date->new( $session{'CurrentUser'} ); + $due = RT::Date->new( $current_user ); $due->Set( Format => 'unknown', Value => $ARGS{'Due'} ); } my $starts; if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) { - $starts = RT::Date->new( $session{'CurrentUser'} ); + $starts = RT::Date->new( $current_user ); $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} ); } @@ -1620,34 +2143,44 @@ sub CreateTicket { Content => $ARGS{Content}, ContentType => $ARGS{ContentType}, StripSignature => 1, - CurrentUser => $session{'CurrentUser'}, + CurrentUser => $current_user, ); + my $date_now = RT::Date->new( $current_user ); + $date_now->SetToNow; my $MIMEObj = MakeMIMEEntity( Subject => $ARGS{'Subject'}, - From => $ARGS{'From'}, + From => $ARGS{'From'} || $current_user->EmailAddress, + To => $ARGS{'To'} || $Queue->CorrespondAddress + || RT->Config->Get('CorrespondAddress'), Cc => $ARGS{'Cc'}, + Date => $date_now->RFC2822(Timezone => 'user'), Body => $sigless, Type => $ARGS{'ContentType'}, + Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web', ); - if ( $ARGS{'Attachments'} ) { - my $rv = $MIMEObj->make_multipart; - $RT::Logger->error("Couldn't make multipart message") - if !$rv || $rv !~ /^(?:DONE|ALREADY)$/; + my @attachments; + if ( my $tmp = $session{'Attachments'}{ $ARGS{'Token'} || '' } ) { + push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp; - foreach ( values %{ $ARGS{'Attachments'} } ) { - unless ($_) { - $RT::Logger->error("Couldn't add empty attachemnt"); - next; - } - $MIMEObj->add_part($_); - } + delete $session{'Attachments'}{ $ARGS{'Token'} || '' } + unless $ARGS{'KeepAttachments'}; + $session{'Attachments'} = $session{'Attachments'} + if @attachments; + } + if ( $ARGS{'Attachments'} ) { + push @attachments, grep $_, map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} }; + } + if ( @attachments ) { + $MIMEObj->make_multipart; + $MIMEObj->add_part( $_ ) foreach @attachments; } - foreach my $argument (qw(Encrypt Sign)) { - $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 ) - if defined $ARGS{$argument}; + for my $argument (qw(Encrypt Sign)) { + if ( defined $ARGS{ $argument } ) { + $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 ); + } } my %create_args = ( @@ -1668,16 +2201,25 @@ sub CreateTicket { Status => $ARGS{'Status'}, Due => $due ? $due->ISO : undef, Starts => $starts ? $starts->ISO : undef, - MIMEObj => $MIMEObj + MIMEObj => $MIMEObj, + SquelchMailTo => $ARGS{'SquelchMailTo'}, + TransSquelchMailTo => $ARGS{'TransSquelchMailTo'}, ); - my @txn_squelch; - foreach my $type (qw(Requestor Cc AdminCc)) { - push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} ) - if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] }; + if ($ARGS{'DryRun'}) { + $create_args{DryRun} = 1; + $create_args{Owner} ||= $RT::Nobody->Id; + $create_args{Requestor} ||= $session{CurrentUser}->EmailAddress; + $create_args{Subject} ||= ''; + $create_args{Status} ||= $Queue->Lifecycle->DefaultOnCreate, + } else { + my @txn_squelch; + foreach my $type (qw(Requestor Cc AdminCc)) { + push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} ) + if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] }; + } + push @{$create_args{TransSquelchMailTo}}, @txn_squelch; } - $create_args{TransSquelchMailTo} = \@txn_squelch - if @txn_squelch; if ( $ARGS{'AttachTickets'} ) { require RT::Action::SendEmail; @@ -1687,69 +2229,16 @@ sub CreateTicket { : ( $ARGS{'AttachTickets'} ) ); } - foreach my $arg ( keys %ARGS ) { - next if $arg =~ /-(?:Magic|Category)$/; - - if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) { - $create_args{$arg} = $ARGS{$arg}; - } - - # Object-RT::Ticket--CustomField-3-Values - elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) { - my $cfid = $1; - - my $cf = RT::CustomField->new( $session{'CurrentUser'} ); - $cf->SetContextObject( $Queue ); - $cf->Load($cfid); - unless ( $cf->id ) { - $RT::Logger->error( "Couldn't load custom field #" . $cfid ); - next; - } - - if ( $arg =~ /-Upload$/ ) { - $create_args{"CustomField-$cfid"} = _UploadedFile($arg); - next; - } - - my $type = $cf->Type; - - my @values = (); - if ( ref $ARGS{$arg} eq 'ARRAY' ) { - @values = @{ $ARGS{$arg} }; - } elsif ( $type =~ /text/i ) { - @values = ( $ARGS{$arg} ); - } else { - no warnings 'uninitialized'; - @values = split /\r*\n/, $ARGS{$arg}; - } - @values = grep length, map { - s/\r+\n/\n/g; - s/^\s+//; - s/\s+$//; - $_; - } - grep defined, @values; - - $create_args{"CustomField-$cfid"} = \@values; - } - } - - # turn new link lists into arrays, and pass in the proper arguments - my %map = ( - 'new-DependsOn' => 'DependsOn', - 'DependsOn-new' => 'DependedOnBy', - 'new-MemberOf' => 'Parents', - 'MemberOf-new' => 'Children', - 'new-RefersTo' => 'RefersTo', - 'RefersTo-new' => 'ReferredToBy', + my %cfs = ProcessObjectCustomFieldUpdatesForCreate( + ARGSRef => \%ARGS, + ContextObject => $Queue, ); - foreach my $key ( keys %map ) { - next unless $ARGS{$key}; - $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ]; - } + my %links = ProcessLinksForCreate( ARGSRef => \%ARGS ); + + my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args, %links, %cfs); + return $Trans if $ARGS{DryRun}; - my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args); unless ($id) { Abort($ErrMsg); } @@ -1805,6 +2294,9 @@ is true. =cut +# change from stock: if txn custom fields are set but there's no content +# or attachment, create a Touch txn instead of doing nothing + sub ProcessUpdateMessage { my %args = ( @@ -1814,10 +2306,18 @@ sub ProcessUpdateMessage { @_ ); - if ( $args{ARGSRef}->{'UpdateAttachments'} - && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } ) - { - delete $args{ARGSRef}->{'UpdateAttachments'}; + my @attachments; + if ( my $tmp = $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' } ) { + push @attachments, grep $_, map $tmp->{$_}, sort keys %$tmp; + + delete $session{'Attachments'}{ $args{'ARGSRef'}{'Token'} || '' } + unless $args{'KeepAttachments'}; + $session{'Attachments'} = $session{'Attachments'} + if @attachments; + } + if ( $args{ARGSRef}{'UpdateAttachments'} ) { + push @attachments, grep $_, map $args{ARGSRef}->{UpdateAttachments}{$_}, + sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} }; } # Strip the signature @@ -1828,19 +2328,38 @@ sub ProcessUpdateMessage { CurrentUser => $args{'TicketObj'}->CurrentUser, ); - # If, after stripping the signature, we have no message, move the - # UpdateTimeWorked into adjusted TimeWorked, so that a later - # ProcessBasics can deal -- then bail out. - if ( not $args{ARGSRef}->{'UpdateAttachments'} + my %txn_customfields; + + foreach my $key ( keys %{ $args{ARGSRef} } ) { + if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) { + next if $key =~ /(TimeUnits|Magic)$/; + $txn_customfields{$key} = $args{ARGSRef}->{$key}; + } + } + + # If, after stripping the signature, we have no message, create a + # Touch transaction if necessary + if ( not @attachments and not length $args{ARGSRef}->{'UpdateContent'} ) { - if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) { - $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'}; + #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) { + # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + + # delete $args{ARGSRef}->{'UpdateTimeWorked'}; + # } + + my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'}; + if ( $timetaken or grep {length $_} values %txn_customfields ) { + my ( $Transaction, $Description, $Object ) = + $args{TicketObj}->Touch( + CustomFields => \%txn_customfields, + TimeTaken => $timetaken + ); + return $Description; } return; } - if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) { + if ( ($args{ARGSRef}->{'UpdateSubject'}||'') eq ($args{'TicketObj'}->Subject || '') ) { $args{ARGSRef}->{'UpdateSubject'} = undef; } @@ -1848,9 +2367,10 @@ sub ProcessUpdateMessage { Subject => $args{ARGSRef}->{'UpdateSubject'}, Body => $args{ARGSRef}->{'UpdateContent'}, Type => $args{ARGSRef}->{'UpdateContentType'}, + Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web', ); - $Message->head->replace( 'Message-ID' => Encode::encode_utf8( + $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} ) ) ); my $old_txn = RT::Transaction->new( $session{'CurrentUser'} ); @@ -1863,13 +2383,14 @@ sub ProcessUpdateMessage { if ( my $msg = $old_txn->Message->First ) { RT::Interface::Email::SetInReplyTo( Message => $Message, - InReplyTo => $msg + InReplyTo => $msg, + Ticket => $args{'TicketObj'}, ); } - if ( $args{ARGSRef}->{'UpdateAttachments'} ) { + if ( @attachments ) { $Message->make_multipart; - $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} }; + $Message->add_part( $_ ) foreach @attachments; } if ( $args{ARGSRef}->{'AttachTickets'} ) { @@ -1880,17 +2401,9 @@ sub ProcessUpdateMessage { : ( $args{ARGSRef}->{'AttachTickets'} ) ); } - my %txn_customfields; - - foreach my $key ( keys %{ $args{ARGSRef} } ) { - if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) { - $txn_customfields{$key} = $args{ARGSRef}->{$key}; - } - } - my %message_args = ( - Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ), - Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ), + Sign => $args{ARGSRef}->{'Sign'}, + Encrypt => $args{ARGSRef}->{'Encrypt'}, MIMEObj => $Message, TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}, CustomFields => \%txn_customfields, @@ -1905,11 +2418,11 @@ sub ProcessUpdateMessage { if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) { my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args); push( @results, $Description ); - $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; + $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object; } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) { my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args); push( @results, $Description ); - $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; + $Object->UpdateCustomFields( %{ $args{ARGSRef} } ) if $Object; } else { push( @results, loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") ); @@ -1944,7 +2457,6 @@ sub _ProcessUpdateMessageRecipients { if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) { push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} ); push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses; - } push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo}; @@ -1966,6 +2478,45 @@ sub _ProcessUpdateMessageRecipients { } } +sub ProcessAttachments { + my %args = ( + ARGSRef => {}, + Token => '', + @_ + ); + + my $token = $args{'ARGSRef'}{'Token'} + ||= $args{'Token'} ||= Digest::MD5::md5_hex( rand(1024) ); + + my $update_session = 0; + + # deal with deleting uploaded attachments + if ( my $del = $args{'ARGSRef'}{'DeleteAttach'} ) { + delete $session{'Attachments'}{ $token }{ $_ } + foreach ref $del? @$del : ($del); + + $update_session = 1; + } + + # store the uploaded attachment in session + my $new = $args{'ARGSRef'}{'Attach'}; + if ( defined $new && length $new ) { + my $attachment = MakeMIMEEntity( + AttachmentFieldName => 'Attach' + ); + + # This needs to be decoded because the value is a reference; + # hence it was not decoded along with all of the standard + # arguments in DecodeARGS + my $file_path = Encode::decode( "UTF-8", "$new"); + $session{'Attachments'}{ $token }{ $file_path } = $attachment; + + $update_session = 1; + } + $session{'Attachments'} = $session{'Attachments'} if $update_session; +} + + =head2 MakeMIMEEntity PARAMHASH Takes a paramhash Subject, Body and AttachmentFieldName. @@ -1986,13 +2537,15 @@ sub MakeMIMEEntity { Body => undef, AttachmentFieldName => undef, Type => undef, + Interface => 'API', @_, ); my $Message = MIME::Entity->build( Type => 'multipart/mixed', - "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ), - map { $_ => Encode::encode_utf8( $args{ $_} ) } - grep defined $args{$_}, qw(Subject From Cc) + "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ), + "X-RT-Interface" => $args{Interface}, + map { $_ => Encode::encode( "UTF-8", $args{ $_} ) } + grep defined $args{$_}, qw(Subject From Cc To Date) ); if ( defined $args{'Body'} && length $args{'Body'} ) { @@ -2003,7 +2556,7 @@ sub MakeMIMEEntity { $Message->attach( Type => $args{'Type'} || 'text/plain', Charset => 'UTF-8', - Data => $args{'Body'}, + Data => Encode::encode( "UTF-8", $args{'Body'} ), ); } @@ -2020,20 +2573,21 @@ sub MakeMIMEEntity { my $uploadinfo = $cgi_object->uploadInfo($filehandle); - my $filename = "$filehandle"; + my $filename = Encode::decode("UTF-8","$filehandle"); $filename =~ s{^.*[\\/]}{}; $Message->attach( Type => $uploadinfo->{'Content-Type'}, - Filename => $filename, - Data => \@content, + Filename => Encode::encode("UTF-8",$filename), + Data => \@content, # Bytes, as read directly from the file, above ); if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) { - $Message->head->set( 'Subject' => $filename ); + $Message->head->replace( 'Subject' => Encode::encode( "UTF-8", $filename ) ); } - # Attachment parts really shouldn't get a Message-ID + # Attachment parts really shouldn't get a Message-ID or "interface" $Message->head->delete('Message-ID'); + $Message->head->delete('X-RT-Interface'); } } @@ -2092,7 +2646,7 @@ sub ProcessACLChanges { my $obj; if ( $object_type eq 'RT::System' ) { $obj = $RT::System; - } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) { + } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) { $obj = $object_type->new( $session{'CurrentUser'} ); $obj->Load($object_id); unless ( $obj->id ) { @@ -2139,19 +2693,8 @@ sub ProcessACLs { # Check if we want to grant rights to a previously rights-less user for my $type (qw(user group)) { - my $key = "AddPrincipalForRights-$type"; - - next unless $ARGSref->{$key}; - - my $principal; - if ( $type eq 'user' ) { - $principal = RT::User->new( $session{'CurrentUser'} ); - $principal->LoadByCol( Name => $ARGSref->{$key} ); - } - else { - $principal = RT::Group->new( $session{'CurrentUser'} ); - $principal->LoadUserDefinedGroup( $ARGSref->{$key} ); - } + my $principal = _ParseACLNewPrincipal($ARGSref, $type) + or next; unless ($principal->PrincipalId) { push @results, loc("Couldn't load the specified principal"); @@ -2203,7 +2746,7 @@ sub ProcessACLs { my $obj; if ( $object_type eq 'RT::System' ) { $obj = $RT::System; - } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) { + } elsif ( $object_type->DOES('RT::Record::Role::Rights') ) { $obj = $object_type->new( $session{'CurrentUser'} ); $obj->Load($object_id); unless ( $obj->id ) { @@ -2251,7 +2794,34 @@ sub ProcessACLs { return (@results); } +=head2 _ParseACLNewPrincipal + +Takes a hashref of C<%ARGS> and a principal type (C or C). Looks +for the presence of rights being added on a principal of the specified type, +and returns undef if no new principal is being granted rights. Otherwise loads +up an L or L object and returns it. Note that the object +may not be successfully loaded, and you should check C<->id> yourself. + +=cut + +sub _ParseACLNewPrincipal { + my $ARGSref = shift; + my $type = lc shift; + my $key = "AddPrincipalForRights-$type"; + + return unless $ARGSref->{$key}; + my $principal; + if ( $type eq 'user' ) { + $principal = RT::User->new( $session{'CurrentUser'} ); + $principal->LoadByCol( Name => $ARGSref->{$key} ); + } + elsif ( $type eq 'group' ) { + $principal = RT::Group->new( $session{'CurrentUser'} ); + $principal->LoadUserDefinedGroup( $ARGSref->{$key} ); + } + return $principal; +} =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs) @@ -2426,32 +2996,69 @@ sub ProcessTicketReminders { if ( $args->{'update-reminders'} ) { while ( my $reminder = $reminder_collection->Next ) { - my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve; - if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) { - $Ticket->Reminders->Resolve($reminder); + my $resolve_status = $reminder->LifecycleObj->ReminderStatusOnResolve; + my ( $status, $msg, $old_subject, @subresults ); + if ( $reminder->Status ne $resolve_status + && $args->{ 'Complete-Reminder-' . $reminder->id } ) + { + ( $status, $msg ) = $Ticket->Reminders->Resolve($reminder); + push @subresults, $msg; } - elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) { - $Ticket->Reminders->Open($reminder); + elsif ( $reminder->Status eq $resolve_status + && !$args->{ 'Complete-Reminder-' . $reminder->id } ) + { + ( $status, $msg ) = $Ticket->Reminders->Open($reminder); + push @subresults, $msg; } - if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) { - $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ; + if ( + exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) + && ( $reminder->Subject ne + $args->{ 'Reminder-Subject-' . $reminder->id } ) + ) + { + $old_subject = $reminder->Subject; + ( $status, $msg ) = + $reminder->SetSubject( + $args->{ 'Reminder-Subject-' . $reminder->id } ); + push @subresults, $msg; } - if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) { - $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ; + if ( + exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) + && ( $reminder->Owner != + $args->{ 'Reminder-Owner-' . $reminder->id } ) + ) + { + ( $status, $msg ) = + $reminder->SetOwner( + $args->{ 'Reminder-Owner-' . $reminder->id }, "Force" ); + push @subresults, $msg; } - if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) { + if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) + && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) + { my $DateObj = RT::Date->new( $session{'CurrentUser'} ); + my $due = $args->{ 'Reminder-Due-' . $reminder->id }; + $DateObj->Set( Format => 'unknown', - Value => $args->{ 'Reminder-Due-' . $reminder->id } + Value => $due, ); - if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) { - $reminder->SetDue( $DateObj->ISO ); + if ( $DateObj->Unix != $reminder->DueObj->Unix ) { + ( $status, $msg ) = $reminder->SetDue( $DateObj->ISO ); } + else { + $msg = loc( "invalid due date: [_1]", $due ); + } + + push @subresults, $msg; } + + push @results, map { + loc( "Reminder '[_1]': [_2]", $old_subject || $reminder->Subject, $_ ) + } @subresults; } } @@ -2461,34 +3068,20 @@ sub ProcessTicketReminders { Format => 'unknown', Value => $args->{'NewReminder-Due'} ); - my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add( + my ( $status, $msg ) = $Ticket->Reminders->Add( Subject => $args->{'NewReminder-Subject'}, Owner => $args->{'NewReminder-Owner'}, Due => $due_obj->ISO ); - push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'}); - } - return @results; -} - -sub ProcessTicketCustomFieldUpdates { - my %args = @_; - $args{'Object'} = delete $args{'TicketObj'}; - my $ARGSRef = { %{ $args{'ARGSRef'} } }; - - # Build up a list of objects that we want to work with - my %custom_fields_to_mod; - foreach my $arg ( keys %$ARGSRef ) { - if ( $arg =~ /^Ticket-(\d+-.*)/ ) { - $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg}; - } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) { - $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg}; - } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) { - delete $ARGSRef->{$arg}; # don't try to update transaction fields + if ( $status ) { + push @results, + loc( "Reminder '[_1]': [_2]", $args->{'NewReminder-Subject'}, loc("Created") ) + } + else { + push @results, $msg; } } - - return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef ); + return @results; } sub ProcessObjectCustomFieldUpdates { @@ -2497,15 +3090,7 @@ sub ProcessObjectCustomFieldUpdates { my @results; # Build up a list of objects that we want to work with - my %custom_fields_to_mod; - foreach my $arg ( keys %$ARGSRef ) { - - # format: Object---CustomField-- - next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/; - - # For each of those objects, find out what custom fields we want to work with. - $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg}; - } + my %custom_fields_to_mod = _ParseObjectCustomFieldArgs($ARGSRef); # For each of those objects foreach my $class ( keys %custom_fields_to_mod ) { @@ -2514,6 +3099,9 @@ sub ProcessObjectCustomFieldUpdates { $Object = $class->new( $session{'CurrentUser'} ) unless $Object && ref $Object eq $class; + # skip if we have no object to update + next unless $id || $Object->id; + $Object->Load($id) unless ( $Object->id || 0 ) == $id; unless ( $Object->id ) { $RT::Logger->warning("Couldn't load object $class #$id"); @@ -2528,12 +3116,34 @@ sub ProcessObjectCustomFieldUpdates { $RT::Logger->warning("Couldn't load custom field #$cf"); next; } + my @groupings = sort keys %{ $custom_fields_to_mod{$class}{$id}{$cf} }; + if (@groupings > 1) { + # Check for consistency, in case of JS fail + for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) { + my $base = $custom_fields_to_mod{$class}{$id}{$cf}{$groupings[0]}{$key}; + $base = [ $base ] unless ref $base; + for my $grouping (@groupings[1..$#groupings]) { + my $other = $custom_fields_to_mod{$class}{$id}{$cf}{$grouping}{$key}; + $other = [ $other ] unless ref $other; + warn "CF $cf submitted with multiple differing values" + if grep {$_} List::MoreUtils::pairwise { + no warnings qw(uninitialized); + $a ne $b + } @{$base}, @{$other}; + } + } + # We'll just be picking the 1st grouping in the hash, alphabetically + } push @results, _ProcessObjectCustomFieldUpdates( - Prefix => "Object-$class-$id-CustomField-$cf-", - Object => $Object, - CustomField => $CustomFieldObj, - ARGS => $custom_fields_to_mod{$class}{$id}{$cf}, + Prefix => GetCustomFieldInputNamePrefix( + Object => $Object, + CustomField => $CustomFieldObj, + Grouping => $groupings[0], + ), + Object => $Object, + CustomField => $CustomFieldObj, + ARGS => $custom_fields_to_mod{$class}{$id}{$cf}{ $groupings[0] }, ); } } @@ -2541,6 +3151,34 @@ sub ProcessObjectCustomFieldUpdates { return @results; } +sub _ParseObjectCustomFieldArgs { + my $ARGSRef = shift || {}; + my %args = ( + IncludeBulkUpdate => 0, + @_, + ); + my %custom_fields_to_mod; + + foreach my $arg ( keys %$ARGSRef ) { + + # format: Object---CustomField[:]-- + # you can use GetCustomFieldInputName to generate the complement input name + # or if IncludeBulkUpdate: Bulk--CustomField[:]-- + next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField(?::(\w+))?-(\d+)-(.*)$/ + || ($args{IncludeBulkUpdate} && $arg =~ /^Bulk-(?:Add|Delete)-()()CustomField(?::(\w+))?-(\d+)-(.*)$/); + # need two empty groups because we must consume $1 and $2 with empty + # class and ID + + next if $1 eq 'RT::Transaction';# don't try to update transaction fields + + # For each of those objects, find out what custom fields we want to work with. + # Class ID CF grouping command + $custom_fields_to_mod{$1}{ $2 || 0 }{$4}{$3 || ''}{$5} = $ARGSRef->{$arg}; + } + + return wantarray ? %custom_fields_to_mod : \%custom_fields_to_mod; +} + sub _ProcessObjectCustomFieldUpdates { my %args = @_; my $cf = $args{'CustomField'}; @@ -2550,7 +3188,7 @@ sub _ProcessObjectCustomFieldUpdates { # the browser gives you a blank value which causes CFs to be processed twice if ( defined $args{'ARGS'}->{'Values'} && !length $args{'ARGS'}->{'Values'} - && $args{'ARGS'}->{'Values-Magic'} ) + && ($args{'ARGS'}->{'Values-Magic'}) ) { delete $args{'ARGS'}->{'Values'}; } @@ -2559,14 +3197,14 @@ sub _ProcessObjectCustomFieldUpdates { foreach my $arg ( keys %{ $args{'ARGS'} } ) { # skip category argument - next if $arg eq 'Category'; + next if $arg =~ /-Category$/; # and TimeUnits next if $arg eq 'Value-TimeUnits'; # since http won't pass in a form element with a null value, we need # to fake it - if ( $arg eq 'Values-Magic' ) { + if ( $arg =~ /-Magic$/ ) { # We don't care about the magic, if there's really a values element; next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'}; @@ -2579,22 +3217,14 @@ sub _ProcessObjectCustomFieldUpdates { $args{'ARGS'}->{'Values'} = undef; } - my @values = (); - if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) { - @values = @{ $args{'ARGS'}->{$arg} }; - } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext - @values = ( $args{'ARGS'}->{$arg} ); - } else { - @values = split /\r*\n/, $args{'ARGS'}->{$arg} - if defined $args{'ARGS'}->{$arg}; - } - @values = grep length, map { - s/\r+\n/\n/g; - s/^\s+//; - s/\s+$//; - $_; - } - grep defined, @values; + my @values = _NormalizeObjectCustomFieldValue( + CustomField => $cf, + Param => $args{'Prefix'} . $arg, + Value => $args{'ARGS'}->{$arg} + ); + + # "Empty" values still don't mean anything for Image and Binary fields + next if $cf_type =~ /^(?:Image|Binary)$/ and not @values; if ( $arg eq 'AddValue' || $arg eq 'Value' ) { foreach my $value (@values) { @@ -2605,8 +3235,7 @@ sub _ProcessObjectCustomFieldUpdates { push( @results, $msg ); } } elsif ( $arg eq 'Upload' ) { - my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next; - my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, ); + my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %{$values[0]}, Field => $cf, ); push( @results, $msg ); } elsif ( $arg eq 'DeleteValues' ) { foreach my $value (@values) { @@ -2624,7 +3253,7 @@ sub _ProcessObjectCustomFieldUpdates { ); push( @results, $msg ); } - } elsif ( $arg eq 'Values' && !$cf->Repeated ) { + } elsif ( $arg eq 'Values' ) { my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id ); my %values_hash; @@ -2658,29 +3287,6 @@ sub _ProcessObjectCustomFieldUpdates { ); push( @results, $msg ); } - } elsif ( $arg eq 'Values' ) { - my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id ); - - # keep everything up to the point of difference, delete the rest - my $delete_flag; - foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) { - if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) { - shift @values; - next; - } - - $delete_flag ||= 1; - $old_cf->Delete; - } - - # now add/replace extra things, if any - foreach my $value (@values) { - my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( - Field => $cf, - Value => $value - ); - push( @results, $msg ); - } } else { push( @results, @@ -2694,6 +3300,107 @@ sub _ProcessObjectCustomFieldUpdates { return @results; } +sub ProcessObjectCustomFieldUpdatesForCreate { + my %args = ( + ARGSRef => {}, + ContextObject => undef, + @_ + ); + my $context = $args{'ContextObject'}; + my %parsed; + my %custom_fields = _ParseObjectCustomFieldArgs( $args{'ARGSRef'} ); + + for my $class (keys %custom_fields) { + # we're only interested in new objects, so only look at $id == 0 + for my $cfid (keys %{ $custom_fields{$class}{0} || {} }) { + my $cf = RT::CustomField->new( $session{'CurrentUser'} ); + if ($context) { + my $system_cf = RT::CustomField->new( RT->SystemUser ); + $system_cf->LoadById($cfid); + if ($system_cf->ValidateContextObject($context)) { + $cf->SetContextObject($context); + } else { + RT->Logger->error( + sprintf "Invalid context object %s (%d) for CF %d; skipping CF", + ref $context, $context->id, $system_cf->id + ); + next; + } + } + $cf->LoadById($cfid); + + unless ($cf->id) { + RT->Logger->warning("Couldn't load custom field #$cfid"); + next; + } + + my @groupings = sort keys %{ $custom_fields{$class}{0}{$cfid} }; + if (@groupings > 1) { + # Check for consistency, in case of JS fail + for my $key (qw/AddValue Value Values DeleteValues DeleteValueIds/) { + warn "CF $cfid submitted with multiple differing $key" + if grep {($custom_fields{$class}{0}{$cfid}{$_}{$key} || '') + ne ($custom_fields{$class}{0}{$cfid}{$groupings[0]}{$key} || '')} + @groupings; + } + # We'll just be picking the 1st grouping in the hash, alphabetically + } + + my @values; + my $name_prefix = GetCustomFieldInputNamePrefix( + CustomField => $cf, + Grouping => $groupings[0], + ); + while (my ($arg, $value) = each %{ $custom_fields{$class}{0}{$cfid}{$groupings[0]} }) { + # Values-Magic doesn't matter on create; no previous values are being removed + # Category is irrelevant for the actual value + next if $arg =~ /-Magic$/ or $arg =~ /-Category$/; + + push @values, + _NormalizeObjectCustomFieldValue( + CustomField => $cf, + Param => $name_prefix . $arg, + Value => $value, + ); + } + + $parsed{"CustomField-$cfid"} = \@values if @values; + } + } + + return wantarray ? %parsed : \%parsed; +} + +sub _NormalizeObjectCustomFieldValue { + my %args = ( + Param => "", + @_ + ); + my $cf_type = $args{CustomField}->Type; + my @values = (); + + if ( ref $args{'Value'} eq 'ARRAY' ) { + @values = @{ $args{'Value'} }; + } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext + @values = ( $args{'Value'} ); + } else { + @values = split /\r*\n/, $args{'Value'} + if defined $args{'Value'}; + } + @values = grep length, map { + s/\r+\n/\n/g; + s/^\s+//; + s/\s+$//; + $_; + } + grep defined, @values; + + if ($args{'Param'} =~ /-Upload$/ and $cf_type =~ /^(Image|Binary)$/) { + @values = _UploadedFile( $args{'Param'} ) || (); + } + + return @values; +} =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS ); @@ -2798,10 +3505,10 @@ sub ProcessTicketDates { # Set date fields my @date_fields = qw( Told - Resolved Starts Started Due + WillResolve ); #Run through each field in this list. update the value if apropriate @@ -2818,9 +3525,7 @@ sub ProcessTicketDates { ); my $obj = $field . "Obj"; - if ( ( defined $DateObj->Unix ) - and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) ) - { + if ( $DateObj->Unix != $Ticket->$obj()->Unix() ) { my $method = "Set$field"; my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO ); push @results, "$msg"; @@ -2842,19 +3547,24 @@ Returns an array of results messages. sub ProcessTicketLinks { my %args = ( TicketObj => undef, + TicketId => undef, ARGSRef => undef, @_ ); my $Ticket = $args{'TicketObj'}; + my $TicketId = $args{'TicketId'} || $Ticket->Id; my $ARGSRef = $args{'ARGSRef'}; - my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef ); + my (@results) = ProcessRecordLinks( + %args, RecordObj => $Ticket, RecordId => $TicketId, ARGSRef => $ARGSRef, + ); #Merge if we need to - if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) { - $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g; - my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ); + my $input = $TicketId .'-MergeInto'; + if ( $ARGSRef->{ $input } ) { + $ARGSRef->{ $input } =~ s/\s+//g; + my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $input } ); push @results, $msg; } @@ -2865,11 +3575,13 @@ sub ProcessTicketLinks { sub ProcessRecordLinks { my %args = ( RecordObj => undef, + RecordId => undef, ARGSRef => undef, @_ ); my $Record = $args{'RecordObj'}; + my $RecordId = $args{'RecordId'} || $Record->Id; my $ARGSRef = $args{'ARGSRef'}; my (@results); @@ -2896,11 +3608,12 @@ sub ProcessRecordLinks { my @linktypes = qw( DependsOn MemberOf RefersTo ); foreach my $linktype (@linktypes) { - if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) { - $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } ) - if ref( $ARGSRef->{ $Record->Id . "-$linktype" } ); + my $input = $RecordId .'-'. $linktype; + if ( $ARGSRef->{ $input } ) { + $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } ) + if ref $ARGSRef->{ $input }; - for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) { + for my $luri ( split( / /, $ARGSRef->{ $input } ) ) { next unless $luri; $luri =~ s/\s+$//; # Strip trailing whitespace my ( $val, $msg ) = $Record->AddLink( @@ -2910,11 +3623,12 @@ sub ProcessRecordLinks { push @results, $msg; } } - if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) { - $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } ) - if ref( $ARGSRef->{ "$linktype-" . $Record->Id } ); + $input = $linktype .'-'. $RecordId; + if ( $ARGSRef->{ $input } ) { + $ARGSRef->{ $input } = join( ' ', @{ $ARGSRef->{ $input } } ) + if ref $ARGSRef->{ $input }; - for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) { + for my $luri ( split( / /, $ARGSRef->{ $input } ) ) { next unless $luri; my ( $val, $msg ) = $Record->AddLink( Base => $luri, @@ -2929,6 +3643,142 @@ sub ProcessRecordLinks { return (@results); } +=head2 ProcessLinksForCreate + +Takes a hash with a single key, C, the value of which is a hashref to +C<%ARGS>. + +Converts and returns submitted args in the form of C and +C into their appropriate directional link types. For example, +C becomes C and C becomes +C. The incoming arg values are split on whitespace and +normalized into arrayrefs before being returned. + +Primarily used by object creation pages for transforming incoming form inputs +from F into arguments appropriate for individual record +Create methods. + +Returns a hashref in scalar context and a hash in list context. + +=cut + +sub ProcessLinksForCreate { + my %args = @_; + my %links; + + foreach my $type ( keys %RT::Link::DIRMAP ) { + for ([Base => "new-$type"], [Target => "$type-new"]) { + my ($direction, $key) = @$_; + next unless $args{ARGSRef}->{$key}; + $links{ $RT::Link::DIRMAP{$type}->{$direction} } = [ + grep $_, split ' ', $args{ARGSRef}->{$key} + ]; + } + } + return wantarray ? %links : \%links; +} + +=head2 ProcessTransactionSquelching + +Takes a hashref of the submitted form arguments, C<%ARGS>. + +Returns a hash of squelched addresses. + +=cut + +sub ProcessTransactionSquelching { + my $args = shift; + my %checked = map { $_ => 1 } grep { defined } + ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} : + defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) : + () ); + my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||''); + return %squelched; +} + +sub ProcessRecordBulkCustomFields { + my %args = (RecordObj => undef, ARGSRef => {}, @_); + + my $ARGSRef = $args{'ARGSRef'}; + + my %data; + + my @results; + foreach my $key ( keys %$ARGSRef ) { + next unless $key =~ /^Bulk-(Add|Delete)-CustomField-(\d+)-(.*)$/; + my ($op, $cfid, $rest) = ($1, $2, $3); + next if $rest =~ /-Category$/; + + my $res = $data{$cfid} ||= {}; + unless (keys %$res) { + my $cf = RT::CustomField->new( $session{'CurrentUser'} ); + $cf->Load( $cfid ); + next unless $cf->Id; + + $res->{'cf'} = $cf; + } + + if ( $op eq 'Delete' && $rest eq 'AllValues' ) { + $res->{'DeleteAll'} = $ARGSRef->{$key}; + next; + } + + my @values = _NormalizeObjectCustomFieldValue( + CustomField => $res->{'cf'}, + Value => $ARGSRef->{$key}, + Param => $key, + ); + next unless @values; + $res->{$op} = \@values; + } + + while ( my ($cfid, $data) = each %data ) { + my $current_values = $args{'RecordObj'}->CustomFieldValues( $cfid ); + + # just add one value for fields with single value + if ( $data->{'Add'} && $data->{'cf'}->MaxValues == 1 ) { + next if $current_values->HasEntry($data->{Add}[-1]); + + my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue( + Field => $cfid, + Value => $data->{'Add'}[-1], + ); + push @results, $msg; + next; + } + + if ( $data->{'DeleteAll'} ) { + while ( my $value = $current_values->Next ) { + my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue( + Field => $cfid, + ValueId => $value->id, + ); + push @results, $msg; + } + } + foreach my $value ( @{ $data->{'Delete'} || [] } ) { + my $entry = $current_values->HasEntry($value); + next unless $entry; + + my ( $id, $msg ) = $args{'RecordObj'}->DeleteCustomFieldValue( + Field => $cfid, + ValueId => $entry->id, + ); + push @results, $msg; + } + foreach my $value ( @{ $data->{'Add'} || [] } ) { + next if $current_values->HasEntry($value); + + my ( $id, $msg ) = $args{'RecordObj'}->AddCustomFieldValue( + Field => $cfid, + Value => $value + ); + push @results, $msg; + } + } + return @results; +} + =head2 _UploadedFile ( $arg ); Takes a CGI parameter name; if a file is uploaded under that name, @@ -2965,7 +3815,8 @@ sub GetColumnMapEntry { } # complex things - elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) { + elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) { + $subkey =~ s/^\{(.*)\}$/$1/; return undef unless $args{'Map'}->{$mainkey}; return $args{'Map'}{$mainkey}{ $args{'Attribute'} } unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE'; @@ -2988,10 +3839,13 @@ sub ProcessColumnMapValue { } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) { return $$value; } + } else { + if ($args{'Escape'}) { + $value = $m->interp->apply_escapes( $value, 'h' ); + $value =~ s/\n/
    /g if defined $value; + } + return $value; } - - return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'}; - return $value; } =head2 GetPrincipalsMap OBJECT, CATEGORIES @@ -3008,10 +3862,10 @@ sub GetPrincipalsMap { if (/System/) { my $system = RT::Groups->new($session{'CurrentUser'}); $system->LimitToSystemInternalGroups(); - $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); + $system->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); push @map, [ 'System' => $system, # loc_left_pair - 'Type' => 1, + 'Name' => 1, ]; } elsif (/Groups/) { @@ -3035,21 +3889,33 @@ sub GetPrincipalsMap { elsif (/Roles/) { my $roles = RT::Groups->new($session{'CurrentUser'}); - if ($object->isa('RT::System')) { - $roles->LimitToRolesForSystem(); - } - elsif ($object->isa('RT::Queue')) { - $roles->LimitToRolesForQueue($object->Id); + if ($object->isa("RT::CustomField")) { + # If we're a custom field, show the global roles for our LookupType. + my $class = $object->RecordClassFromLookupType; + if ($class and $class->DOES("RT::Record::Role::Roles")) { + $roles->LimitToRolesForObject(RT->System); + $roles->Limit( + FIELD => "Name", + FUNCTION => 'LOWER(?)', + OPERATOR => "IN", + VALUE => [ map {lc $_} $class->Roles ], + CASESENSITIVE => 1, + ); + } else { + # No roles to show; so show nothing + undef $roles; + } + } else { + $roles->LimitToRolesForObject($object); } - else { - $RT::Logger->warn("Skipping unknown object type ($object) for Role principals"); - next; + + if ($roles) { + $roles->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); + push @map, [ + 'Roles' => $roles, # loc_left_pair + 'Name' => 1 + ]; } - $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); - push @map, [ - 'Roles' => $roles, # loc_left_pair - 'Type' => 1 - ]; } elsif (/Users/) { my $Users = RT->PrivilegedUsers->UserMembersObj(); @@ -3064,23 +3930,18 @@ sub GetPrincipalsMap { ); # Limit to UserEquiv groups - my $groups = $Users->NewAlias('Groups'); - $Users->Join( - ALIAS1 => $groups, - FIELD1 => 'id', - ALIAS2 => $group_members, - FIELD2 => 'GroupId' + my $groups = $Users->Join( + ALIAS1 => $group_members, + FIELD1 => 'GroupId', + TABLE2 => 'Groups', + FIELD2 => 'id', ); - $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' ); - $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' ); + $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence', CASESENSITIVE => 0 ); + $Users->Limit( ALIAS => $groups, FIELD => 'Name', VALUE => 'UserEquiv', CASESENSITIVE => 0 ); - - my $display = sub { - $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1) - }; push @map, [ 'Users' => $Users, # loc_left_pair - $display => 0 + 'Format' => 0 ]; } } @@ -3149,16 +4010,17 @@ following: =cut our @SCRUBBER_ALLOWED_TAGS = qw( - A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5 + A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP S DEL STRIKE H1 H2 H3 H4 H5 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO ); our %SCRUBBER_ALLOWED_ATTRIBUTES = ( - # Match http, ftp and relative urls + # Match http, https, ftp, mailto and relative urls # XXX: we also scrub format strings with this module then allow simple config options - href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i, + href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|HomePath|BaseURL|URL)__)}i, face => 1, size => 1, + color => 1, target => 1, style => qr{ ^(?:\s* @@ -3172,6 +4034,12 @@ our %SCRUBBER_ALLOWED_ATTRIBUTES = ( font-family: \s* [\w\s"',.\-]+ | font-weight: \s* [\w\-]+ | + border-style: \s* \w+ | + border-color: \s* [#\w]+ | + border-width: \s* [\s\w]+ | + padding: \s* [\s\w]+ | + margin: \s* [\s\w]+ | + # MS Office styles, which are probably fine. If we don't, then any # associated styles in the same attribute get stripped. mso-[\w\-]+?: \s* [\w\s"',.\-]+ @@ -3184,9 +4052,42 @@ our %SCRUBBER_ALLOWED_ATTRIBUTES = ( our %SCRUBBER_RULES = (); +# If we're displaying images, let embedded ones through +if (RT->Config->Get('ShowTransactionImages') or RT->Config->Get('ShowRemoteImages')) { + $SCRUBBER_RULES{'img'} = { + '*' => 0, + alt => 1, + }; + + my @src; + push @src, qr/^cid:/i + if RT->Config->Get('ShowTransactionImages'); + + push @src, $SCRUBBER_ALLOWED_ATTRIBUTES{'href'} + if RT->Config->Get('ShowRemoteImages'); + + $SCRUBBER_RULES{'img'}->{'src'} = join "|", @src; +} + sub _NewScrubber { require HTML::Scrubber; my $scrubber = HTML::Scrubber->new(); + + if (HTML::Gumbo->require) { + no warnings 'redefine'; + my $orig = \&HTML::Scrubber::scrub; + *HTML::Scrubber::scrub = sub { + my $self = shift; + + eval { $_[0] = HTML::Gumbo->new->parse( $_[0] ); chomp $_[0] }; + warn "HTML::Gumbo pre-parse failed: $@" if $@; + return $orig->($self, @_); + }; + push @SCRUBBER_ALLOWED_TAGS, qw/TABLE THEAD TBODY TFOOT TR TD TH/; + $SCRUBBER_ALLOWED_ATTRIBUTES{$_} = 1 for + qw/colspan rowspan align valign cellspacing cellpadding border width height/; + } + $scrubber->default( 0, { @@ -3215,6 +4116,21 @@ sub JSON { RT::Interface::Web::EncodeJSON(@_); } +sub CSSClass { + my $value = shift; + return '' unless defined $value; + $value =~ s/[^A-Za-z0-9_-]/_/g; + return $value; +} + +sub GetCustomFieldInputName { + RT::Interface::Web::GetCustomFieldInputName(@_); +} + +sub GetCustomFieldInputNamePrefix { + RT::Interface::Web::GetCustomFieldInputNamePrefix(@_); +} + package RT::Interface::Web; RT::Base->_ImportOverlays();