escape results from the CPAN

Apache2-PageKit

  eval {
    $error = $model->pkit_on_error($error) if $model->can('pkit_on_error');
  };
  # just in case we die again inside pkit_on_error
  $error = $@ if ($@);

  # save changes
  delete @$pk{qw/session page_session/};

  # the session and page_session references can not be used
  # inside pkit_cleanup_code -- they are already deleted
  $model->pkit_cleanup_code if $model->can('pkit_cleanup_code');
  if( exists $INC{'Apache/ErrorReport.pm'} && $error ){
    Apache2::ErrorReport::fatal($error);
  }
  die $error if $error;

  return ( defined $pk->{status_code} ? $pk->{status_code} : undef );
}

# utility function, concats parameters from request parameters into string
# seperated by '&' and '=' - suitable for displaying in a URL
sub params_as_string {
  my ($apr, $exclude_param) = @_;

  my $args;
  # we cache args in pnotes - i think it is faster this way
  # especially if you have <PKIT_SELFURL exclude="foo"> tags
  unless ($args = $apr->pnotes('r_args')){

    # this fine easy line is replaced with this beast to parse url's
    # like http://ka.brain.de/login2?passwd=ss&&&&submit&&login=s&
    #  my %args = $apr->args;
    my %args = ();
    
=pod    
    my @args = $apr->args;
    while (@args) {
      my $k = shift @args;
      next unless $k;
      $args{$k} = shift @args;
    }
=cut

  # this is so ugly and should be rewritten TODO ugly hack
  my $args_table = $apr->APR::Request::args;
  for my $k ( %$args_table ) {
    my $v = $args_table->{$k};
    $args{$k} = $v if defined $v;
  }

    for (qw(login logout view check_cookie messages error_messages lang)){
      delete $args{"pkit_$_"};
    }
    $args = \%args;
    $apr->pnotes(r_args => $args);
  }

  if($exclude_param && @$exclude_param){
    my %exclude_param_hash = map {$_ => 1} @$exclude_param;
    return join ('&', map { Apache2::Util::escape_path("$_", $apr->pool) ."=" . Apache2::Util::escape_path(defined($args->{$_}) ? $args->{$_} : "", $apr->pool )}
       grep {!exists $exclude_param_hash{$_}} keys %$args);
  } else {
    return join ('&', map { Apache2::Util::escape_path("$_", $apr->pool) ."=" . Apache2::Util::escape_path(defined($args->{$_}) ? $args->{$_} : "", $apr->pool)} keys %$args);
  }
}

sub update_session {
  my ($pk, $auth_session_id) = @_;
  my $use_recent_login_timeout =
    $pk->{config}->get_global_attr('use_recent_login_timeout') || 'yes';
  return if ( $use_recent_login_timeout eq 'no' );

  # keep recent sessions recent, if user is logged in
  # that is sessions time out if user hasn't viewed in a page
  # in recent_login_timeout seconds
  my $session = $pk->{session};
  return unless defined($session);
  
  unless(exists($session->{pkit_inactivity_timeout})){
    my $recent_login_timeout = $pk->{config}->get_global_attr('recent_login_timeout') || 3600;
    my $last_activity = $session->{pkit_last_activity};
    if(defined($last_activity) && $last_activity + $recent_login_timeout < time()){
      # user has been inactive for recent_login_timeout seconds, timeout
      $session->{pkit_inactivity_timeout} = 1;
    } else {
      # update last_activity timestamp
      $session->{pkit_last_activity} = time();
    }
  }
}

sub load_page_session {
  my ( $pk, $ss ) = @_;

  $ss ||= $pk->{model}->pkit_session_setup;

  my $config = $pk->{config};
  my $want_page_session = $config->get_page_attr($pk->{page_id}, 'page_session')
    || $config->get_global_attr('page_session') || 'no';

  if ( $want_page_session eq 'yes' ) {

    my ( %page_session, $secret );
    {
      no strict 'refs';
      $secret = ${ $config->get_global_attr('model_base_class') . '::secret_md5' };
    }

    my $page_session_class = $config->get_global_attr('page_session_class') || 'Apache::SessionX';

    tie %page_session, $page_session_class, Digest::MD5::md5_hex( $secret, $pk->{page_id} ),
    {
      Lock => $ss->{session_lock_class},
      Store => $ss->{session_store_class},
      Generate => 'MD5',
      Serialize => $ss->{session_serialize_class} || 'Storable',
      create_unknown => 1,
      lazy => 1,
      %{$ss->{session_args}}
    };
    $pk->{page_session} = \%page_session;
  }
}

lib/Apache2/PageKit.pm view on Meta::CPAN

  my $view = $pk->{view};

  # $config is an Apache2::PageKit::Config object
  my $config = $pk->{config};

  # $model is an Apache2::PageKit::Model object
  my $model = $pk->{model};

  # decline to serve images, etc
#  return DECLINED if $apr->content_type && $apr->content_type !~ m|^text/|io;

  my $uri = $apr->uri;

  my $output_param_object = $pk->{output_param_object};
  my $fillinform_object = $pk->{fillinform_object};

  # decline files_match
  if (my $files_match = $config->get_server_attr('files_match')){
    return DECLINED if $uri =~ m/$files_match/;
  }

  # this is the color, that replaces all <PKIT_ERRORSTR>
  my $default_errorstr = $config->get_global_attr('default_errorstr') || '#ff0000';
  $output_param_object->param(pkit_errorstr => $default_errorstr);

  my $uri_prefix = $config->get_global_attr('uri_prefix') || '';

  if($uri_prefix){
    $uri =~ s(^/$uri_prefix/*)(/); # */
  }

  if($model->can('pkit_fixup_uri')){
    $uri = $model->pkit_fixup_uri($uri);
  }

#  my $host = (split(':',$apr->headers_in->{'Host'}))[0];
  my ($host, $uri_with_query);
  if(my $X_Original_URI = $apr->headers_in->{'X-Original-URI'}){
    ($host) = ($X_Original_URI =~ m!^https?://([^/]*)!);
    $uri_with_query = $X_Original_URI;
  } else {
    $host = $apr->headers_in->{'Host'};

    $uri_with_query = ((defined( $ENV{HTTPS} ) && $ENV{HTTPS} eq 'on') ? 'https' : 'http') . '://' . $host . ($uri_prefix ? '/' . $uri_prefix : '' ) . $uri;
  }
#  my $pkit_selfurl;

  $apr->notes->set(orig_uri => $uri_with_query);

  my $query_string = params_as_string($apr);
  if($query_string){
    $uri_with_query .= "?" . $query_string;
#    $pkit_selfurl = $uri_with_query . '&';
#  } else {
#    $pkit_selfurl = $uri_with_query . '?';
  }
#  $view->param(pkit_selfurl => $pkit_selfurl);

  $output_param_object->param(pkit_hostname => $host);

#  my $pkit_done = Apache2::Util::escape_path($apr->param('pkit_done') || $uri_with_query, $apr->pool);
  my $pkit_done = $apr->param('pkit_done') || $uri_with_query;

#  $pkit_done =~ s/"/\%22/g;
#  $pkit_done =~ s/&/\%26/g;
#  $pkit_done =~ s/\?/\%3F/g;
  $output_param_object->param("pkit_done",$pkit_done);
#  $fillinform_object->param("pkit_done",$pkit_done);

  $pk->{page_id} = $uri;

  # add the default_page for pageid with trailing slash "/"
  # WARNING - this is undocumented and may go away at anytime
  $pk->{page_id} =~ s!^(.*?)/+$! "$1/" . $model->pkit_get_default_page !e;

  # get rid of leading forward slash
  $pk->{page_id} =~ s(^/+)();

  # get default page if there is no page specified in url
  if($pk->{page_id} eq ''){
    $pk->{page_id} = $model->pkit_get_default_page;
  }

  # store name and page_id for a static file, that require a login
  my %static_file;

  # redirect "not found" pages
  unless ($pk->page_exists($pk->{page_id})){
    # first try to see if we can find a static file that we
    # can return
    my $filename = $pk->static_page_exists($pk->{page_id});
    unless($filename) {{

      if ($pk->is_directory($pk->{page_id})) {
        # redirect to the directory instead of deliver the page.
	# otherwise the client gets all links wrong if they are relative.
	# http://xyz.abc.de/my_dir
	# we deliver silently http://xyz.abc.de/my_dir/some_default_page
	# but all relative links on some_default_page get
	# http://xyz.abc.de/_the_link_ istead of
	# http://xyz.abc.de/my_dir/_the_link_
	# so we redirect better ...
        $apr->headers_out->{Location} = $pk->{page_id} . '/';
	return REDIRECT;
      }

      $pk->{page_id} = $config->uri_match($pk->{page_id})
	|| $config->get_global_attr('not_found_page')
	|| $model->pkit_get_default_page;
      unless ($pk->page_exists($pk->{page_id})){
	# if not_found_page is static, then return DECLINED...
	$filename = $pk->static_page_exists($pk->{page_id});
      }
    }}
    if ($filename){
      my $require_login  = $config->get_page_attr($pk->{page_id},'require_login') || 'no';
      my $protect_static = $config->get_global_attr('protect_static') || 'yes';
      if ( $require_login eq 'no' || $protect_static ne 'yes' ) {
        # return the static page only, if no parameters are attached to the uri
	# otherwise we can not login logout and so on when one the default or index
	# or whatever page is static.

lib/Apache2/PageKit.pm view on Meta::CPAN

  # this call can't fail it is already verified by pkit_auth_credential
  my ($auth_user, $auth_session_id) = $model->pkit_auth_session_key($ses_key);

 # watch if session was the session we search for, if not get the auth_session
  if (!$session_id || $auth_session_id ne $session_id) {
    my $ss = $model->pkit_session_setup;
    my %auth_session;

    my $session_class = $config->get_global_attr('session_class') || 'Apache::SessionX';
    # get new session assoc with login
    tie %auth_session, $session_class, $auth_session_id,
      {
         Lock => $ss->{session_lock_class},
         Store => $ss->{session_store_class},
         Generate => 'MD5',
         Serialize => $ss->{session_serialize_class} || 'Storable',
         create_unknown => 1,
         lazy => 0,
         %{$ss->{session_args}}
      };

    if ( $use_recent_login_timeout ne 'no' ) {
      delete $auth_session{pkit_inactivity_timeout};
      $auth_session{pkit_last_activity} = time;
    }

    # save session
    untie %auth_session;
  }

  my $pkit_id = 'pkit_id' . ( $config->get_server_attr('cookie_postfix') || '' );

  my $cookie_domain_str = $config->get_server_attr('cookie_domain');
  my @cookie_domains = defined($cookie_domain_str) ? split(' ',$cookie_domain_str) : (undef);
  for my $cookie_domain (@cookie_domains){
    my $cookie = Apache2::Cookie->new($apr->env,
				   -name => $pkit_id,
				   -value => $ses_key,
				   -path => "/");
    $cookie->domain($cookie_domain) if $cookie_domain;
    if ($remember){
      $cookie->expires("+10y");
    }
    $apr->err_headers_out->add( 'Set-Cookie' => $cookie->as_string );
  }

  # remove appending ? or & and any combination of them
  $done =~ s/[\?&]+$//;

  # this is used to check if cookie is set
  if($done =~ /\?/){
    $done .= "&pkit_check_cookie=on";
  } else {
    $done .= "?pkit_check_cookie=on";
  }

  $done =~ s/ /+/g;

  if(my @pkit_messages = $apr->param('pkit_messages')){
    for my $message (@pkit_messages){
      $done .= "&pkit_messages=" . Apache2::Util::escape_path($message, $apr->pool);
    }
  }
  if(my @pkit_error_messages = $apr->param('pkit_error_messages')){
    for my $message (@pkit_error_messages){
      $done .= "&pkit_error_messages=" . Apache2::Util::escape_path($message, $apr->pool);
    }
  }

  $apr->headers_out->set(Location => "$done");
  return 1;
}

sub authenticate {
  my ($pk) = @_;
  my $apr = $pk->{apr};

  my $model = $pk->{model};
  my %cookies = Apache2::Cookie->fetch($apr->env);
  my $cookie_pkit_id = 'pkit_id' . ( $pk->{config}->get_server_attr('cookie_postfix') || '' );

  return unless $cookies{$cookie_pkit_id};

  my %ticket = $cookies{$cookie_pkit_id}->value;

  # in case pkit_auth_session_key is not defined, but cookie
  # is somehow already set
  return unless $model->can('pkit_auth_session_key');

  my ($auth_user, $auth_session_id) = $model->pkit_auth_session_key(\%ticket);

  return unless $auth_user;

  $auth_session_id = $auth_user unless defined($auth_session_id);

  $apr->user($auth_user);
#  $apr->param(pkit_user => $auth_user);

#  $pk->{output_param_object}->param(pkit_user => $auth_user);

  return ($auth_user, $auth_session_id);
}

sub logout {
  my ($pk) = @_;
  my $apr = $pk->{apr};

  my $config = $pk->{config};
  my %cookies = Apache2::Cookie->fetch($apr->env);

  my $cookie_postfix = $config->get_server_attr('cookie_postfix') || '';
  my $pkit_id = 'pkit_id' . $cookie_postfix;
  my $pkit_session_id = 'pkit_session_id' . $cookie_postfix;

  my $logout_kills_session = $config->get_global_attr('logout_kills_session') || 'yes';
  my @cookies_to_kill = ( $cookies{$pkit_id} );
  push @cookies_to_kill, $cookies{$pkit_session_id} if $logout_kills_session eq 'yes';

  my $cookie_domain = $config->get_server_attr('cookie_domain');
  my @cookie_domains = defined($cookie_domain) ? split(' ',$cookie_domain) : (undef);

  for my $tcookie (@cookies_to_kill){
    next unless $tcookie;
    for my $cookie_domain (@cookie_domains){
      $tcookie->value("");
      $tcookie->path("/");

( run in 1.123 second using v1.01-cache-2.11-cpan-39bf76dae61 )