Apache2::ClickPath - Apache WEB Server User Tracking

 LoadModule perl_module ".../mod_perl.so"
 PerlLoadModule Apache2::ClickPath
 <ClickPathUAExceptions>
   Google     Googlebot
   MSN        msnbot
   Mirago     HeinrichderMiragoRobot
   Yahoo      Yahoo-MMCrawler
   Seekbot    Seekbot
   Picsearch  psbot
   Globalspec Ocelli
   Naver      NaverBot
   Turnitin   TurnitinBot
   dir.com    Pompos
   search.ch  search\.ch
   IBM        http://www\.almaden\.ibm\.com/cs/crawler/
 </ClickPathUAExceptions>
 ClickPathSessionPrefix "-S:"
 ClickPathMaxSessionAge 18000
 PerlTransHandler Apache2::ClickPath
 PerlOutputFilterHandler Apache2::ClickPath::OutputFilter
 LogFormat "%h %l %u %t \"%m %U%q %H\" %>s %b \"%{Referer}i\" \"%{User-agent}i\" \"%{SESSION}e\""

 %h %l %u %t \"%r\"

package Apache2::ClickPath;

use 5.008;
use strict;
use warnings;
no warnings qw(uninitialized);

use APR::Table ();
use APR::SockAddr ();
use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Apache2::Connection ();
use Apache2::Filter ();
use Apache2::RequestRec ();
use Apache2::Module ();
use Apache2::CmdParms ();
use Apache2::Directive ();
use Apache2::Log ();
use Apache2::URI ();
use Apache2::Const -compile => qw(DECLINED OK
				  OR_ALL RSRC_CONF
				  TAKE1 RAW_ARGS NO_ARGS);

use MIME::Base64 ();
use Crypt::CBC ();
use Crypt::Blowfish ();
use Digest::MD5 ();
use Digest::CRC ();

use Apache2::ClickPath::_parse ();

our $VERSION = '1.901';
our $rcounter=int rand 0x10000;

my @directives=
  (
   {
    name         => 'ClickPathSessionPrefix',
    func         => __PACKAGE__ . '::ClickPathSessionPrefix',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       => 'ClickPathSessionPrefix string',
   },
   {
    name         => 'ClickPathMaxSessionAge',
    func         => __PACKAGE__ . '::ClickPathMaxSessionAge',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       => 'ClickPathMaxSessionAge time_in_seconds',
   },
   {
    name         => 'ClickPathUAExceptionsFile',
    func         => __PACKAGE__ . '::ClickPathUAExceptionsFile',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       => 'ClickPathUAExceptionsFile filename',
   },
   {
    name         => '<ClickPathUAExceptions',
    func         => __PACKAGE__ . '::ClickPathUAExceptions',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::RAW_ARGS,
    errmsg       => '<ClickPathUAExceptions>
name1 regexp1
name2 regexp2
...
</ClickPathUAExceptions>',
   },
   {
    name         => '</ClickPathUAExceptions>',
    func         => __PACKAGE__ . '::ClickPathUAExceptionsEND',
    req_override => Apache2::Const::OR_ALL,
    args_how     => Apache2::Const::NO_ARGS,
    errmsg       => '</ClickPathUAExceptions> without <ClickPathUAExceptions>',
   },
   {
    name         => 'ClickPathFriendlySessionsFile',
    func         => __PACKAGE__ . '::ClickPathFriendlySessionsFile',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::TAKE1,
    errmsg       => 'ClickPathFriendlySessionsFile filename',
   },
   {
    name         => '<ClickPathFriendlySessions',
    func         => __PACKAGE__ . '::ClickPathFriendlySessions',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::RAW_ARGS,
    errmsg       => '<ClickPathFriendlySessions>
name1 regexp1
name2 regexp2
...
</ClickPathFriendlySessions>',
   },
   {
    name         => '</ClickPathFriendlySessions>',
    func         => __PACKAGE__ . '::ClickPathFriendlySessionsEND',
    req_override => Apache2::Const::OR_ALL,
    args_how     => Apache2::Const::NO_ARGS,
    errmsg       => '</ClickPathFriendlySessions> without <ClickPathFriendlySessions>',
   },
   {
    name         => 'ClickPathMachine',
    func         => __PACKAGE__ . '::ClickPathMachine',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::RAW_ARGS,
    errmsg       => 'ClickPathMachine string',
   },
   {
    name         => '<ClickPathMachineTable',
    func         => __PACKAGE__ . '::ClickPathMachineTable',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::RAW_ARGS,
    errmsg       => '<ClickPathMachineTable>
ip_ext1|name_ext1 [name1 [ip_int1|name_int1]]
ip_ext2|name_ext2 [name2 [ip_int1|name_int1]]
...
</ClickPathMachineTable>',
   },
   {
    name         => '</ClickPathMachineTable>',
    func         => __PACKAGE__ . '::ClickPathMachineTableEND',
    req_override => Apache2::Const::OR_ALL,
    args_how     => Apache2::Const::NO_ARGS,
    errmsg       => '</ClickPathMachineTable> without <ClickPathMachineTable>',
   },
   {
    name         => 'ClickPathSecret',
    func         => __PACKAGE__ . '::ClickPathSecret',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::RAW_ARGS,
    errmsg       => 'ClickPathSecret string',
   },
   {
    name         => 'ClickPathSecretIV',
    func         => __PACKAGE__ . '::ClickPathSecretIV',
    req_override => Apache2::Const::RSRC_CONF,
    args_how     => Apache2::Const::RAW_ARGS,
    errmsg       => 'ClickPathSecretIV string',
   },
  );
Apache2::Module::add(__PACKAGE__, \@directives);

sub ClickPathSessionPrefix {
  my($I, $parms, $arg)=@_;
  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathSessionPrefix"}=$arg;
}

sub ClickPathMaxSessionAge {
  my($I, $parms, $arg)=@_;
  die "ERROR: Argument to ClickPathMaxSessionAge must be a number\n"
    unless( $arg=~/^\d+$/ );
  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathMaxSessionAge"}=$arg;
}

sub ClickPathUAExceptionsFile {
  my($I, $parms, $arg)=@_;
  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathUAExceptionsFile"}=$arg;
}

sub ClickPathUAExceptions {
  my($I, $parms, @args)=@_;

  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathUAExceptions"}
    =Apache2::ClickPath::_parse::UAExceptions( $parms->directive->as_string );
}

sub ClickPathUAExceptionsEND {
  my($I, $parms, $arg)=@_;
  die "ERROR: </ClickPathUAExceptions> without <ClickPathUAExceptions>\n";
}

sub ClickPathFriendlySessionsFile {
  my($I, $parms, $arg)=@_;
  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathFriendlySessionsFile"}=$arg;
}

sub ClickPathFriendlySessions {
  my($I, $parms, @args)=@_;

  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  @{$I}{"ClickPathFriendlySessionsTable",
	"ClickPathFriendlySessionsReverse"}
    =Apache2::ClickPath::_parse::FriendlySessions( $parms->directive->as_string );
}

sub ClickPathFriendlySessionsEND {
  my($I, $parms, $arg)=@_;
  die "ERROR: </ClickPathFriendlySessions> without <ClickPathFriendlySessions>\n";
}

sub ClickPathMachine {
  my($I, $parms, $arg)=@_;
  die "ClickPathMachine [name] -- name consist of letters, digits or _\n"
    unless( $arg=~/^\w*$/ );

  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathMachine"}=$arg;
}

sub ClickPathMachineTable {
  my($I, $parms, @args)=@_;

  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  @{$I}{"ClickPathMachineTable", "ClickPathMachineReverse"}
    =Apache2::ClickPath::_parse::MachineTable( $parms->directive->as_string );
}

sub ClickPathMachineTableEND {
  my($I, $parms, $arg)=@_;
  die "ERROR: </ClickPathMachineTable> without <ClickPathMachineTable>\n";
}

sub postconfig {
  my($conf_pool, $log_pool, $temp_pool, $s) = @_;

  for( $s=Apache2::ServerUtil->server; $s; $s=$s->next ) {
    my $cfg=Apache2::Module::get_config( __PACKAGE__, $s );
    if( $cfg ) {
      if( exists $cfg->{ClickPathSecret} ) {
	$cfg->{ClickPathSecretIV}="abcd1234"
	  unless( length $cfg->{ClickPathSecretIV} );
      }
    }
  }

  return Apache2::Const::OK;
}

sub setPostConfigHandler {
  my $h=Apache2::ServerUtil->server->get_handlers('PerlPostConfigHandler')||[];
  unless( grep $_==\&postconfig, @{$h} ) {
    Apache2::ServerUtil->server->push_handlers
	('PerlPostConfigHandler'=>\&postconfig);
  }
}

sub ClickPathSecret {
  my($I, $parms, $arg)=@_;

  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathSecret"}=Apache2::ClickPath::_parse::Secret( $arg );
  setPostConfigHandler;
}

sub ClickPathSecretIV {
  my($I, $parms, $arg)=@_;

  $I=Apache2::Module::get_config( __PACKAGE__, $parms->server );
  $I->{"ClickPathSecretIV"}=substr( Digest::MD5::md5( $arg ), 0, 8 );
  setPostConfigHandler;
}

sub _get_ua_exc {
  my $cf=shift;

  ########### checking for UA Exceptions #################################
  # a ClickPathUAExceptionsFile directive overrides ClickPathUAExceptions
  # a ClickPathUAExceptionsFile is read every time it has been changed
  ########################################################################

  my ($fh, @stat);
  if( length $cf->{"ClickPathUAExceptionsFile"} and
      @stat=stat $cf->{"ClickPathUAExceptionsFile"} and
      $stat[9]>$cf->{"ClickPathUAExceptionsFile_read_time"} and
      open $fh, $cf->{"ClickPathUAExceptionsFile"} ) {
    $cf->{"ClickPathUAExceptionsFile_read_time"}=$stat[9];

    local $/;
    $cf->{"ClickPathUAExceptions_list"}
      =Apache2::ClickPath::_parse::UAExceptions( scalar( <$fh> ) );
    close $fh;
    return $cf->{"ClickPathUAExceptions_list"};
  } elsif( @stat and
	   $stat[9]<=$cf->{"ClickPathUAExceptionsFile_read_time"} ) {
    return $cf->{"ClickPathUAExceptions_list"};
  } else {
    return $cf->{"ClickPathUAExceptions"} || [];
  }
}

sub _get_friendly_session {
  my $cf=shift;

  ########### checking for Friendly Sessions #############################
  # a ClickPathFriendlySessionsFile directive overrides
  # ClickPathFriendlySessions
  # a ClickPathFriendlySessionsFile is read every time it has been changed
  ########################################################################

  my ($fh, @stat);
  if( length $cf->{"ClickPathFriendlySessionsFile"} and
      @stat=stat $cf->{"ClickPathFriendlySessionsFile"} and
      $stat[9]>$cf->{"ClickPathFriendlySessionsFile_read_time"} and
      open $fh, $cf->{"ClickPathFriendlySessionsFile"} ) {
    $cf->{"ClickPathFriendlySessionsFile_read_time"}=$stat[9];

    local $/;
    @{$cf}{"ClickPathFriendlySessionsFileTable",
	   "ClickPathFriendlySessionsFileReverse"}
      =Apache2::ClickPath::_parse::FriendlySessions( scalar( <$fh> ) );
    close $fh;
    return @{$cf}{"ClickPathFriendlySessionsFileTable",
		  "ClickPathFriendlySessionsFileReverse"};
  } elsif( @stat and
	   $stat[9]<=$cf->{"ClickPathFriendlySessionsFile_read_time"} ) {
    return @{$cf}{"ClickPathFriendlySessionsFileTable",
		  "ClickPathFriendlySessionsFileReverse"};
  } else {
    return @{$cf}{"ClickPathFriendlySessionsTable",
		  "ClickPathFriendlySessionsReverse"};
  }
}

sub handler {
  my $r=shift;

  my $cf=Apache2::Module::get_config(__PACKAGE__, $r->server);
  my $tag=$cf->{"ClickPathSessionPrefix"}
    or return Apache2::Const::DECLINED;
  $r->pnotes( __PACKAGE__.'::tag'=>$tag );

  #print STDERR "\n\n$$: request: ".$r->the_request, "\n";
  #print STDERR "$$: uri: ".$r->uri, "\n";

  my $file=$r->uri;

  # if an old session is used this will be reset
  # if an old session timed out (goto NEWSESSION) this will be incremented
  # giving in 2.
  # if simply a new session is created this is 1
  # then a pnote is set indicating this state. Thus the filter can
  # examin it.
  my $newsession=1;

  my $pr=$r->main || $r->prev;
  my $ref=$r->headers_in->{Referer} || "";

  if( $pr ) {
    my $session=$pr->subprocess_env( 'SESSION' );
    if( length $session ) {
      $r->subprocess_env( REMOTE_SESSION=>
			  $pr->subprocess_env( 'REMOTE_SESSION' ) );
      $r->subprocess_env( REMOTE_SESSION_HOST=>
			  $pr->subprocess_env( 'REMOTE_SESSION_HOST' ) );
      $r->subprocess_env( CGI_SESSION=>
			  $pr->subprocess_env( 'CGI_SESSION' ) );
      $r->subprocess_env( SESSION_START=>
			  $pr->subprocess_env( 'SESSION_START' ) );
      $r->subprocess_env( SESSION_AGE=>
			  $pr->subprocess_env( 'SESSION_AGE' ) );
      $r->subprocess_env('ClickPathMachineName'=>
			  $pr->subprocess_env( 'ClickPathMachineName' ) );
      my $store=$pr->subprocess_env( 'ClickPathMachineStore' );
      $r->subprocess_env('ClickPathMachineStore'=>$store) if( length $store );
      $r->subprocess_env( SESSION=>$session );
      $newsession=$pr->pnotes( __PACKAGE__.'::newsession' );
      $r->pnotes( __PACKAGE__.'::newsession'=>$newsession )
	if( $newsession );
      #print STDERR "$$: ReUsing session $session\n";
    }
  } elsif( $file=~s!^/+\Q$tag\E ( [^/]+ ) /!/!x ) {
    my $session=$1;

    #print STDERR "$$: Using old session $session\n";

    $ref=~s!^(\w+://[^/]+)/+\Q$tag\E[^/]+!$1!;
    $r->headers_in->{Referer}=$ref;

    $r->parse_uri( 'http://localhost'.$file.(length $r->args ? '?'.$r->args : '') );
    $r->subprocess_env( SESSION=>$session );
    $r->subprocess_env( CGI_SESSION=>'/'.$tag.$session );

    # decode session
    $session=~tr[N-Za-z0-9@\-,A-M][A-Za-z0-9@\-,];
    my @l=split /,/, $session, 3;
    # extract remote session
    my $rtab;
    (undef, $rtab)=_get_friendly_session( $cf );
    $rtab={} unless( $rtab );
    if( @l==3 and exists $rtab->{$l[1]} ) {
      my %h=('**'=>'*', '*!'=>'!', '*.'=>'=', '!'=>"\n", '*x'=>'/', '*y'=>'#');
      $l[2]=~s/(\*[*!.xy]|!)/$h{$1}/ge;
      $r->subprocess_env( REMOTE_SESSION=>$l[2] );
      $r->subprocess_env( REMOTE_SESSION_HOST=>$rtab->{$l[1]} );
    } else {
      $r->subprocess_env->unset( 'REMOTE_SESSION' );
      $r->subprocess_env->unset( 'REMOTE_SESSION_HOST' );
    }
    # extract session start time
    $l[0]=~tr[@\-][+/];
    @l=split /:/, $l[0], 2;	# $l[0]: IP Addr, $l[1]: session
    if( exists $cf->{ClickPathMachineReverse} ) {
      if( exists $cf->{ClickPathMachineReverse}->{$l[0]} ) {
	$r->subprocess_env('ClickPathMachineName'=>$l[0]);
	$r->subprocess_env('ClickPathMachineStore'=>
			   $cf->{"ClickPathMachineReverse"}->{$l[0]}->[1])
	  if( length $cf->{"ClickPathMachineReverse"}->{$l[0]}->[1] );
      } else {
	$r->log->notice( "Caught invalid session: Unknown Machine name '$l[0]'" );
	$r->subprocess_env( INVALID_SESSION=>$r->subprocess_env( 'SESSION' ) );
	$r->subprocess_env->unset( 'SESSION' );
	$r->subprocess_env->unset( 'CGI_SESSION' );
	$r->subprocess_env->unset( 'REMOTE_SESSION' );
	$r->subprocess_env->unset( 'REMOTE_SESSION_HOST' );
	$newsession++;
	goto NEWSESSION;
      }
    }

    my $len4=do {use integer; (length( $l[1] )+3)/4;};
    $len4*=4;
    $l[1]=MIME::Base64::decode_base64( $l[1].('='x($len4-length( $l[1] ))) );

    if( exists $cf->{ClickPathSecret} ) {
      my $crypt=Crypt::CBC->new(
				-key=>$cf->{ClickPathSecret},
				-keysize=>length($cf->{ClickPathSecret}),
				-cipher=>'Crypt::Blowfish',
				-literal_key=>1,
				-header=>'none',
				-iv=>$cf->{ClickPathSecretIV},
			       );
      $l[1]=$crypt->decrypt( $l[1] );
    }

    my $crc;
    if( length( $l[1] ) ) {
      $crc=Digest::CRC::crc8( substr( $l[1], 1 ) );
    } else {
      $crc=-1;			# invalid value
    }

    @l=unpack "CNNnN", $l[1];

    my $maxage=$cf->{"ClickPathMaxSessionAge"};
    my $age=$r->request_time-$l[1];
    if( $crc!=$l[0] or ($maxage>0 and $age>$maxage) or $age<0 ) {
      if( $crc!=$l[0] ) {
	$r->log->notice( "Caught invalid session: CRC checksum failed" );
      } else {
	$r->subprocess_env( EXPIRED_SESSION=>$r->subprocess_env( 'SESSION' ) );
      }
      $r->subprocess_env->unset( 'SESSION' );
      $r->subprocess_env->unset( 'CGI_SESSION' );
      $r->subprocess_env->unset( 'REMOTE_SESSION' );
      $r->subprocess_env->unset( 'REMOTE_SESSION_HOST' );
      $r->subprocess_env->unset( 'ClickPathMachineName' );
      $r->subprocess_env->unset( 'ClickPathMachineStore' );
      $newsession++;
      goto NEWSESSION;
    } else {
      $r->subprocess_env( SESSION_START=>$l[1] );
      $r->subprocess_env( SESSION_AGE=>$r->request_time-$l[1] );
    }
    $newsession=0;
  } else {
    $ref=~s!^(\w+://[^/]+)/\Q$tag\E[^/]+!$1!;
    $r->headers_in->{Referer}=$ref;

  NEWSESSION:
    my $ua=$r->headers_in->{'User-Agent'};
    my $disable='';

    foreach my $el (@{_get_ua_exc( $cf )}) {
      if( $ua=~/$el->[1]/ ) {
	$disable=$el->[0];
	last;
      }
    }

    if( length $disable ) {
      $r->subprocess_env( SESSION=>$disable );
      $r->subprocess_env( SESSION_START=>$r->request_time );
      $r->subprocess_env( SESSION_AGE=>0 );
      $r->subprocess_env->unset( 'CGI_SESSION' );
      $r->subprocess_env->unset( 'REMOTE_SESSION' );
      $r->subprocess_env->unset( 'REMOTE_SESSION_HOST' );
    } else {
      if( $ref=~s!^\w+://([^/]+)/+!/! ) {
	my $host=$1;
	my ($tab)=_get_friendly_session( $cf );
	my $el=($tab || {})->{$host};

	if( $el ) {
	  local $_;
	  my $args;
	  ($ref, $args)=split /\?/, $ref, 2;
	  my @uri=split m!/+!, $ref;
	  my %args=map {
	    my ($k, $v)=split /=/;
	    length( $k ) ? ($k=>$v) : ();
	  } split /[;&]/, $args;

	  my @remote_session=map {
	    $_->[0] eq 'uri' ? $uri[$_->[1]] : $_->[1].'='.$args{$_->[1]};
	  } @{$el->[0]};

	  my $remote_session=join( "\n", @remote_session );
	  $r->subprocess_env( REMOTE_SESSION=>$remote_session );
	  $r->subprocess_env( REMOTE_SESSION_HOST=>$host );

	  my %h=('*'=>'**', '!'=>'*!', '='=>'*.', "\n"=>'!',
		 '/'=>'*x', '#'=>'*y');
	  $remote_session=~s^([*!=\n/#])^$h{$1}^ge;

	  $ref=$el->[1].','.$remote_session;
	} else {
	  $r->subprocess_env->unset( 'REMOTE_SESSION' );
	  $r->subprocess_env->unset( 'REMOTE_SESSION_HOST' );
	  $ref='';
	}
      } else {
	$r->subprocess_env->unset( 'REMOTE_SESSION' );
	$r->subprocess_env->unset( 'REMOTE_SESSION_HOST' );
	$ref='';
      }

      my $session_ip=undef;
      if( exists $cf->{"ClickPathMachine"} ) {
	$session_ip=$cf->{"ClickPathMachine"};
      } else {
	my $serverip=$r->connection->local_addr->ip_get;

	if( exists $cf->{"ClickPathMachineTable"} and
	    exists $cf->{"ClickPathMachineTable"}->{$serverip} ) {
	  $session_ip=$cf->{"ClickPathMachineTable"}->{$serverip}->[0];
	  $r->subprocess_env('ClickPathMachineName'=>
			     $cf->{"ClickPathMachineTable"}->{$serverip}->[0]);
	  $r->subprocess_env('ClickPathMachineStore'=>
			     $cf->{"ClickPathMachineTable"}->{$serverip}->[1])
	    if( length $cf->{"ClickPathMachineTable"}->{$serverip}->[1] );
	} else {
	  $r->server->log->error( "Cannot find myself ($serverip) in ClickPathMachineTable" )
	    if( exists $cf->{"ClickPathMachineTable"} );
	  $session_ip=MIME::Base64::encode_base64
	    ( pack( 'C*', split /\./, $serverip, 4 ), '' );
	  $session_ip=~s/={0,2}$//;
	}
      }
      my $session=pack( 'NNnN',
			$r->request_time, $$, $rcounter++,
			$r->connection->id );
      $rcounter%=2**16;

      $session=pack( 'C', Digest::CRC::crc8( $session ) ).$session;

      if( exists $cf->{ClickPathSecret} ) {
	my $crypt=Crypt::CBC->new(
				  -key=>$cf->{ClickPathSecret},
				  -keysize=>length($cf->{ClickPathSecret}),
				  -cipher=>'Crypt::Blowfish',
				  -literal_key=>1,
				  -header=>'none',
				  -iv=>$cf->{ClickPathSecretIV},
				 );
	$session=$crypt->encrypt( $session );
      }
      $session=MIME::Base64::encode_base64( $session, '' );
      $session=~s/={0,2}$//;

      $session=$session_ip.':'.$session;
      $session=~tr[+/][@\-];
      $session.=','.$ref;

      $session=~tr[A-Za-z0-9@\-,][N-Za-z0-9@\-,A-M];
      $r->subprocess_env( SESSION=>$session );
      $r->subprocess_env( SESSION_START=>$r->request_time );
      $r->subprocess_env( SESSION_AGE=>0 );
      $r->subprocess_env( CGI_SESSION=>'/'.$tag.$session );
      $r->pnotes( __PACKAGE__.'::newsession'=>$newsession );
      #print STDERR "$$: Using new session $session\n";
    }
  }

  return Apache2::Const::DECLINED
}

sub OutputFilter {
  my $f=shift;
  my $sess;
  my $host;
  my $sprefix;
  my $context;
  my ($re0, $re1, $re2, $re3, $re4, $the_request);


  unless ($f->ctx) {
    my $r=$f->r;

    if( $r->main ) {
      # skip filtering for subrequests
      $f->remove;
      return Apache2::Const::DECLINED;
    }

    $sess=$r->subprocess_env('CGI_SESSION');
    unless( defined $sess and length $sess ) {
      $f->remove;
      return Apache2::Const::DECLINED;
    }

    $sprefix=$r->pnotes( __PACKAGE__.'::tag' );
    unless( defined $sprefix and length $sprefix ) {
      $f->remove;
      return Apache2::Const::DECLINED;
    }

    $host=$r->headers_in->{Host};

    my $newsession=$r->pnotes( __PACKAGE__.'::newsession' );
    if( $newsession ) {
      $the_request=$r->the_request;
      $the_request=~s/^\s*\w+\s+//;
      $the_request=~s![^/]*[\s?].*$!!;
      #print STDERR "the_request=$the_request\n";
      if( $newsession==2 ) {
	# cut off an timed out old session if given
	$the_request=~s!^/+\Q$sprefix\E[^/]+!!;
	#print STDERR "the_request(2)=$the_request\n";
      }

      my $re=qr,^(https?://\Q$host\E)?(?!\w+:)(?:/\Q$sprefix\E[^/]+)*(.),i;
      $r->headers_out->{Location}=~s!$re!$2 eq '/'
                                                                                  ? $1.$sess.$2
                                                                                  : $1.$sess.$the_request.$2
                                                                                !e
	if( exists $r->headers_out->{Location} );
      $r->err_headers_out->{Location}=~s!$re!$2 eq '/'
	                                     	                                     ? $1.$sess.$2
                                                                                          : $1.$sess.$the_request.$2
                                                                                        !e
	if( exists $r->err_headers_out->{Location} );

      $re=qr,^(\s*\d+\s*;\s*url\s*=\s*(?:https?://\Q$host\E)?)(?!\w+:)(?:/\Q$sprefix\E[^/]+)*(.),i;
      $r->headers_out->{Refresh}=~s!$re!$2 eq '/'
                                                                                ? $1.$sess.$2
                                                                                : $1.$sess.$the_request.$2
                                                                              !e
	if( exists $r->headers_out->{Refresh} );
      $r->err_headers_out->{Refresh}=~s!$re!$2 eq '/'
                                                                                        ? $1.$sess.$2
                                                                                        : $1.$sess.$the_request.$2
                                                                                      !e
	if( exists $r->err_headers_out->{Refresh} );
    } else {
      $the_request="";

      my $re=qr!^(https?://\Q$host\E)?(?:/\Q$sprefix\E[^/]+)*/!i;
      $r->headers_out->{Location}=~s!$re!$1$sess/!
	if( exists $r->headers_out->{Location} );
      $r->err_headers_out->{Location}=~s!$re!$1$sess/!
	if( exists $r->err_headers_out->{Location} );

      $re=qr!^(\s*\d+\s*;\s*url\s*=\s*(?:https?://\Q$host\E)?)(?:/\Q$sprefix\E[^/]+)*/!i;
      $r->headers_out->{Refresh}=~s!$re!$1$sess/!
	if( exists $r->headers_out->{Refresh} );
      $r->err_headers_out->{Refresh}=~s!$re!$1$sess/!
	if( exists $r->err_headers_out->{Refresh} );
    }

    # we only process HTML documents but Location: and Refresh: headers
    # are processed anyway
    unless( $r->content_type =~ m!text/html!i ) {
      $f->remove;
      return Apache2::Const::DECLINED;
    }

    if( $r->pnotes( __PACKAGE__.'::newsession' ) ) {
      # Wenn die Session neu ist, dann muessen auch relative Links
      # reaendert werden
      $re1=qr,(			# $1 start
	       	       <\s*a(?:rea)?\s+	# <a> start
	       	       .*?		# evtl. target=...
                              \bhref\s*=\s*	# href=
	       	       (["'])		# " oder ': Das ist $2 oder \2 (siehe unten)
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# Das alles ist in $1
	      	      (?:/+\Q$sprefix\E[^/]+)?
	      	      (			# $3 start
	       	       (?!(?:\w+:|\043)).*? # ein beliebiger nicht mit http:// o.ae.
								#   beginnender String (moeglichst kurz)
	       	       \2		# das schließende Quote: $2
	      	      )			# $3 ende
	     	     ,xi;

    # nach dieser regexp enthält entweder $2 oder $7 "http-equiv=refresh"
    # $sess darf nur eingefügt werden, wenn eins von beiden nicht leer ist.
      $re2=qr,(			# $1 start         "<meta ..."
	       	       <\s*meta\s+	# <meta> start
	       	       [^>]*?		# evtl. anderes Zeug
	      	      )			# $1 ende

	      	      (			# $2 start         optional "http-equiv=..."
	       	       \bhttp-equiv\s*=\s*(["']?)refresh\3
	       	       [^>]*?		# evtl. anderes Zeug
	      	      )?		# $2 ende

	      	      (			# $4 start         "content=" + opening quote
                              \bcontent\s*=\s*
	       	       (["'])		# " oder ': Das ist \5 (siehe unten)
                              \s*\d+\s*;\s*url\s*=\s*
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# $4 ende

	      	      (?:/+\Q$sprefix\E[^/]+)?

	      	      (			# $6 start         URL + closing quote
	       	       (?!\w+:).*?	# ein beliebiger nicht mit http:// o.ae.
								#   beginnender String (so kurz wie möglich)
	       	       \5		# das schließende Quote: $5
	      	      )			# $6 ende

	      	      (			# $7 start         optional "http-equiv=..."
	       	       [^>]*?		# evtl. anderes Zeug
	       	       \bhttp-equiv\s*=\s*(["']?)refresh\8
	      	      )?		# $7 ende
	     	     ,ix;

      $re3=qr,(			# $1 start
	       	       <\s*form\s+	# <a> start
	       	       [^>]*?		# evtl. target=...
                              \baction\s*=\s*	# href=
	       	       (["'])		# " oder ': Das ist $2 oder \2 (siehe unten)
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# Das alles ist in $1
	      	      (?:/+\Q$sprefix\E[^/]+)?
	      	      (			# $3 start
	       	       (?!\w+:).*?	# ein beliebiger nicht mit http:// o.ae.
								#   beginnender String (moeglichst kurz)
	       	       \2		# das schließende Quote: $2
	      	      )			# $3 ende
	     	     ,xi;

      $re4=qr,(			# $1 start
	       	       <\s*i?frame\s+	# <a> start
	       	       [^>]*?		# evtl. target=...
                              \bsrc\s*=\s*	# href=
	       	       (["'])		# " oder ': Das ist $2 oder \2 (siehe unten)
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# Das alles ist in $1
	      	      (?:/+\Q$sprefix\E[^/]+)?
	      	      (			# $3 start
	       	       (?!\w+:).*?	# ein beliebiger nicht mit http:// o.ae.
								#   beginnender String (moeglichst kurz)
	       	       \2		# das schließende Quote: $2
	      	      )			# $3 ende
	     	     ,xi;
    } else {
      $re1=qr,(			# $1 start
	       	       <\s*a(?:rea)?\s+	# <a> start
	       	       .*?		# evtl. target=...
                              \bhref\s*=\s*	# href=
	       	       (["'])		# " oder ': Das ist $2 oder \2 (siehe unten)
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# Das alles ist in $1
	      	      (?:/+\Q$sprefix\E[^/]+)?
	      	      (			# $3 start
	       	       /.*?		# ein beliebiger mit /
								#   beginnender String (moeglichst kurz)
	       	       \2		# das schließende Quote: $2
	      	      )			# $3 ende
	     	     ,xi;

    # nach dieser regexp enthält entweder $2 oder $7 "http-equiv=refresh"
    # $sess darf nur eingefügt werden, wenn eins von beiden nicht leer ist.
      $re2=qr,(			# $1 start         "<meta ..."
	       	       <\s*meta\s+	# <meta> start
	       	       [^>]*?		# evtl. anderes Zeug
	      	      )			# $1 ende

	      	      (			# $2 start         optional "http-equiv=..."
	       	       \bhttp-equiv\s*=\s*(["']?)refresh\3
	       	       [^>]*?		# evtl. anderes Zeug
	      	      )?		# $2 ende

	      	      (			# $4 start         "content=" + opening quote
                              \bcontent\s*=\s*
	       	       (["'])		# " oder ': Das ist \5 (siehe unten)
                              \s*\d+\s*;\s*url\s*=\s*
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# $4 ende

	      	      (?:/+\Q$sprefix\E[^/]+)?

	      	      (			# $6 start         URL + closing quote
	       	       /.*?		# ein beliebiger mit /
								#   beginnender String (so kurz wie möglich)
	       	       \5		# das schließende Quote: $5
	      	      )			# $6 ende

	      	      (			# $7 start         optional "http-equiv=..."
	       	       [^>]*?		# evtl. anderes Zeug
	       	       \bhttp-equiv\s*=\s*(["']?)refresh\8
	      	      )?		# $7 ende
	     	     ,ix;

      $re3=qr,(			# $1 start
	       	       <\s*form\s+	# <a> start
	       	       [^>]*?		# evtl. target=...
                              \baction\s*=\s*	# href=
	       	       (["'])		# " oder ': Das ist $2 oder \2 (siehe unten)
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# Das alles ist in $1
	      	      (?:/+\Q$sprefix\E[^/]+)?
	      	      (			# $3 start
	       	       /.*?		# ein beliebiger /
								#   beginnender String (moeglichst kurz)
	       	       \2		# das schließende Quote: $2
	      	      )			# $3 ende
	     	     ,xi;

      $re4=qr,(			# $1 start
	       	       <\s*i?frame\s+	# <a> start
	       	       [^>]*?		# evtl. target=...
                              \bsrc\s*=\s*	# href=
	       	       (["'])		# " oder ': Das ist $2 oder \2 (siehe unten)
	       	       (?:https?://\Q$host\E)?	# evtl. Host
	      	      )			# Das alles ist in $1
	      	      (?:/+\Q$sprefix\E[^/]+)?
	      	      (			# $3 start
	       	       /.*?		# ein beliebiger /
								#   beginnender String (moeglichst kurz)
	       	       \2		# das schließende Quote: $2
	      	      )			# $3 ende
	     	     ,xi;
    }

    # store the configuration
    $f->ctx( +{
	        extra => '',
		sess  => $sess,
		req   => $the_request,
		re    => qr/(<[^>]*)$/,
		re1   => $re1,
		re2   => $re2,
		re3   => $re3,
		re4   => $re4,
	      } );

    # output filters that alter content are responsible for removing
    # the Content-Length header, but we only need to do this once.
    $r->headers_out->unset('Content-Length');
  }

  # retrieve the filter context, which was set up on the first invocation
  $context=$f->ctx;

  $sess=$context->{sess};
  $re1=$context->{re1};
  $re2=$context->{re2};
  $re3=$context->{re3};
  $re4=$context->{re4};
  $re0=$context->{re};
  $the_request=$context->{req};

  # now, filter the content
  while( $f->read(my $buffer, 1024) ) {
    # prepend any tags leftover from the last buffer or invocation
    $buffer = $context->{extra} . $buffer if( length $context->{extra} );

    # if our buffer ends in a split tag ('<strong' for example)
    # save processing the tag for later
    if (($context->{extra}) = $buffer =~ m/$re0/) {
      $buffer = substr($buffer, 0, -length($context->{extra}));
    }

    if( length $the_request ) {
      $buffer=~s!$re1!(substr($3, 0, 1) eq '/')
                                            ? $1.$sess.$3
                                            : $1.$sess.$the_request.$3
                                          !ge;
      $buffer=~s!$re2!(length($2) or length($7))
                                            ? ((substr($6, 0, 1) eq '/')
			 			 ? $1.$2.$4.$sess.$6.$7
                                                  : $1.$2.$4.$sess.$the_request.$6.$7
                                                )
		      		      : $1.$2.$4.$6.$7
                                          !ge;
      $buffer=~s!$re3!(substr($3, 0, 1) eq '/')
                                            ? $1.$sess.$3
                                            : $1.$sess.$the_request.$3
                                          !ge;
      $buffer=~s!$re4!(substr($3, 0, 1) eq '/')
                                            ? $1.$sess.$3
                                            : $1.$sess.$the_request.$3
                                          !ge;
    } else {
      $buffer=~s!$re1!$1$sess$3!g;
      $buffer=~s!$re2!(length($2) or length($7))
                                            ? $1.$2.$4.$sess.$6.$7
		      		      : $1.$2.$4.$6.$7
                                          !ge;
      $buffer=~s!$re3!$1$sess$3!g;
      $buffer=~s!$re4!$1$sess$3!g;
    }

    $f->print($buffer);
  }

  if ($f->seen_eos) {
    # we've seen the end of the data stream

    # Hier muss keine Ersetzung durchgeführt werden, da $context->{extra}
    # für richtige HTML Dokumente leer sein muss.

    # print any leftover data
    $f->print($context->{extra}) if( length $context->{extra} );
  }

  return Apache2::Const::OK;
}

1;

__END__