#!perl -wT
#
# @(#)$Id: cache.pl.txt,v 1.1 2003/06/04 13:12:53 MichaelRausch Exp nobody $ GNU (C) by Peter Klausner 2003
#
# Michael Rausch 	2003-04-24	Added some sanity checks and cache_control checking
# Michael Rausch	2003-05-27	Made the script strict and tainted (for mod_perl)
# Michael Rausch	2003-06-04	Mod_perl integration (no exec anymore)
#

package cache;

use strict;

use Apache::Server;
use IO::String;

use constant debug => 1;

if(defined($ENV{'MOD_PERL'})) {
#	Apache::Server::warn ( "Running under mod_perl" );

	use TIESTDERR;
	TIESTDERR->main();
}

use debugrender;

# customize manually to save TWiki load & compile time...
my $sep = '__';				# "?" as in URLs doesn't work on windows
my $data = 'd:/Michael/twiki/data';
my $cache = 'd:/Michael/twiki/cache';
#my $render = 'perl -wT d:/Michael/twiki/bin/render';	# you might need full path!
my $renderpath = 'debugrender';
my $webhome = 'WebHome';
#my $maxage = 24 * 14;	# default expiration after ~ hours
my $maxage = 8;	# default expiration after ~ hours

# initialize data...
use CGI::Carp;

# untaint path
#print STDERR "Path: ".$ENV{'PATH'}."\n";
#$ENV{'PATH'} = 'c:\perl\bin;c:\winnt\system32';
#delete @ENV{ qw( IFS CDPATH ENV BASH_ENV ) };


# =========================
# workaround for stupid mod_perl behaviour complaining about a redefined function
my $cacheReadFile_ref = sub
{
    my( $name ) = @_;
    my $data = '';
    undef $/; # set to read to EOF
    open( IN_FILE, "<$name" ) || return "";
    $data = <IN_FILE>;
    $/ = "\n";
    close( IN_FILE );
    $data = "" unless $data; # no undefined
    return $data;
};

# =========================

my $user='';
{
	my %sessionInfo = ();

	#use CGI;
	#my $q = new CGI;
	#my $sessionId = $q->cookie( 'twikisession' ) || '';
	# faster:
	my $cookies = $ENV{'HTTP_COOKIE'} || '';
	#print STDERR "cookies: $cookies\n";
	$cookies =~ /\s*twikisession\=(\d+-\d+)\;?\s*/;
	my $sessionId = $1 || '';

	if( $sessionId ne '') {
		if( -e "$data/.session/$sessionId" ) {
			#my $text = cacheReadFile( "$data/.session/$sessionId" );
			my $text = &$cacheReadFile_ref( "$data/.session/$sessionId" );
			%sessionInfo = map { split( /\|/, $_, 2 ) }
					grep { /[^\|]*\|[^\|]*$/ }
					split( /\n/, $text );
		}
	}

	$user = $sessionInfo{"user"} || '';
	#print STDERR "session user: $user\n";
}

use constant mtime => 9;
my $query = $ENV{'QUERY_STRING'} || '';
my $path = $ENV{'PATH_INFO'} || '';

# extend path if just dir = web given:
$path =~ s:/*$:/$webhome:	if -d "$data$path";

# strip out special caching parm maxage:
$query =~ s/^maxage=([0-9.-]+)&*//	and $maxage = $1	or
$query =~ s/&maxage=([0-9.-]+)//	and $maxage = $1;

# the file names are:
my $source = "$data$path.txt";
my $sourcecompare = $source;
#my $entry = "$cache$path$sep$query";
my $entry = "$cache$path$sep$query" . (($user ne '')?".$user":'') ; 

$entry =~ /(.*)/; $entry = $1; # untaint MR: todo: better taint regex

my $cachedir = $entry;
$cachedir =~ s:/[^/]*$::;	# does the directory exists?

$maxage = $maxage * 3600; # in sekunden

# check for cache-control header from browser
# see http://www.faqs.org/rfcs/rfc2068.html 14.9
my $cache_control = $ENV{'HTTP_CACHE_CONTROL'} || $ENV{'HTTP_PRAGMA'} || "";
my $no_cache = ( $cache_control =~ /no-cache|max-age=(\d+)|no-store|max-stale=|min-fresh=/ );
#if($1>0) { $maxage = $1; }

# handle max age parm...
if ( $maxage == 0 ) {			# re-render on _any_ change in web, i.e.
	$sourcecompare =~ s:/[^/]*$::;	# compare with directory date
	$maxage = 9999 * 3600;
}
if ( $no_cache || ($maxage < 0) ) {	# force flushing cache
	my @utcachefiles;
	foreach my $cf ( glob("$cache$path$sep*") ) {
	    $cf =~ /(.*)/;
	    push @utcachefiles, $1;  # untaint variable
	}
	unlink @utcachefiles;
}

# get times:
my $t_cache = (stat "$entry")[mtime] || 0;
my $t_change = (stat "$source")[mtime] || 0;
my $t_compare = (stat "$sourcecompare")[mtime] || 0;


if ( $t_change == 0 || ! -d $cachedir) 		# there is no original or no cache directory, pass-thru
{
	print STDERR "pth s:$source c:$t_cache s:$t_change m:$maxage u:$user\n" if debug;
	debugrender->main();
}
elsif ( ! $no_cache &&				# no forced reload
	( $t_cache > $t_compare ) &&		# cached copy is newer
	( $t_cache + $maxage > time() ) )	# and expires in the future
{
	print STDERR "get s:$source c:$t_cache s:$t_compare m:$maxage u:$user\n" if debug;
	open CACHE, "<$entry"	or die "can't open $entry, $!";
	while (<CACHE>)	{ print; }	# start sending asap
	close CACHE;
}
else {
	print STDERR "put s:$source c:$t_cache s:$t_compare m:$maxage u:$user\n" if debug;

	my $oldout = select || undef;
	my $str;
	my $io = IO::String->new($str);
	select($io);
	debugrender->main();
	select($oldout) if defined ($oldout);

	print $str;

	open CACHE, ">$entry";		# ignore error
	print CACHE $str;
	close CACHE;
}

1;