#!/usr/bin/perl
#
# PurpurHain Counter mit File-Locking, Reload-Sperre (optional) und Statistik-Datensammlung
#
# Anzeige wahlweise versteckt (transparent GIF 1*1px),
# oder grafische Ausgabe (= xbitmap schwarzweiss/weissschwarz),
# oder Text Ausgabe (mittels SSI oder Javascript Einbindung),
#
# entwickelt unter Windoof mit "Active Perl", getestet unter Linux mit Apache
#
# Beispiele:
#
# <img src="cgi-bin/counter.cgi?id=nnn&rl=ssss&sh=height&sw=width&ref=referrer" height=1 width=1 alt="">
# <img src="cgi-bin/counter.cgi?id=nnn&rl=ssss&sh=height&sw=width&ref=referrer&maskbw=mmmmmm" alt="">
# <img src="cgi-bin/counter.cgi?id=nnn&rl=ssss&sh=height&sw=width&ref=referrer&maskwb=mmmmmm" alt="">
#         oder
# <!--#include virtual="/cgi-bin/counter.cgi?id=nnn&mask=mmmmmm&incr=0&user=userdata"-->
#         oder
# <script language="JavaScript" src="cgi-bin/counter.cgi?id=nnn&mask=mmmmmm&incr=0&user=userdata"></script>
#
# © Günter Laudenklos 07/2000
# lastchange 07/2001 - filelocking for Win9x
# http://www.purpurhain.de/
# mailto guenter@laudenklos.de
#
package ph_counter;
require "chistsave.pl";
#

$basedir = '../';                                   # back from cgi-bin to domain root
$logfile = $basedir.'sdata/log_.txt';               # file definitions
$histfile = $basedir.'sdata/hist_.txt';             # _ underscore will be replaced by numerical IDs

# ab hier muß normalerweise nichts mehr geändert werden,
# aber falls Du wissen willst was hier noch abgeht ... kannste ja mal nachsehen ...

$lockreq = &initialize;								# initialize processing

open (LOGFILE,"+<$logfile") or &sendIt;				# open counter's logfile, don't count if invalid
&flock(LOGFILE,$logfile,$lockreq);
seek (LOGFILE,0,0);									# position at start

@logrec = <LOGFILE>;								# read current logfile
$counter = shift(@logrec);							# 1st record is counter value
chomp($counter);

if($incr)
{
	$_ = ($rel>0) ? &check_reload : 0;				# check for reload (if "RL" value specified)
	&count_it unless $_;							# increase counter, save loginfo+history
}
close (LOGFILE);									# close counter log
&flock(LOGFILE,$logfile,$lockrel);					# release file
&sendIt;											# return grafic or text
exit;												# that's all

#
# Nun kommen nur noch die "kleinen" Unterroutinen ...
# Und (fast) der ganze Rest der spärlichen Kommentare ist in
# meinem "programmers-bad-pidgin-english-style" gehalten  ;-)
# (fällt mir nach über 28 Jahren DV-Docus-lesen/schreiben leichter beim "kommentieren")
#

sub initialize
{
	if($^O =~ /MSWin32/o && !$ENV{'REMOTE_ADDR'})		# der switch ist nur für meine Entwicklungsumgebung
	{
		$buffer = 'ID=100&RL=30&ref=http%3A//my.testserv.de/private.html&sh=1024&sw=1280&mask=0&incr=1';
		$Mode = 1;
	}
	else
	{
		if($ENV{'REQUEST_METHOD'} eq "GET")				# entspricht ?Text=Hallo+dies+ist+ein+Test&Zeichen=%25
		{ $buffer = $ENV{'QUERY_STRING'}; } 
		else
		{ read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'}); }	# input via forms
		
		$Mode = (substr($ENV{'SERVER_ADDR'},0,3) eq '127') ? 1 : 0;
	}
	$buffer =~ tr/+/ /;

	@parms = split(/&/,$buffer);
	foreach $parm (@parms)												#&;`'\"|*?~<>^()[]{}$\n\r
	{
		$parm =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;		# replace %xx characters with ASCII
		$parm =~ s/([\&;\`'\\\|"*?~<>^\(\)\[\]\{\}\$\n\r])/\\$1/g;		# mask unwanted special characters =phrack.com-55 recommandation
																		# refer to http://www.phrack.com/search.phtml?view&article=p55-7
		($name,$value) = split(/=/,$parm,2);							# initial parsing routine
		$name = uc($name);												# lowercase all names
		if($name ne 'REF')
		{
			$value =~ s/false/0/igo;
			$value =~ s/true/1/igo;
			$value =~ s/\D//go;											# remove all chars except 0-9
		}
		$FORM{$name} = $value;
	}
	$cid = ($FORM{'ID'} ne '') ? 1*$FORM{'ID'} : -1;
	$rel = ($FORM{'RL'} ne '') ? 1*$FORM{'RL'} : 0;
	$incr = ($FORM{'INCR'} ne '') ? 1*$FORM{'INCR'} : 1;
	$user = ($FORM{'USER'} ne '') ? "\x01".$FORM{'USER'} : '';
	$mask = ($FORM{'MASK'} ne '') ? 1 : 0;
	$maskbw = ($FORM{'MASKBW'} ne '') ? 1 : 0;
	$maskwb = ($FORM{'MASKWB'} ne '') ? 1 : 0;
	$msk = ($mask) ? length($FORM{'MASK'}) : 0;
	$msk = length($FORM{'MASKBW'}) if($maskbw);
	$msk = length($FORM{'MASKWB'}) if($maskwb);
	
	&invalid('ID',$value) unless ($cid>=0 && $cid<=99999);
	&invalid('RL',$value) unless ($rel>=0 && $rel<=86400);
					
	$logfile =~ s/_/$cid/o;
	$histfile =~ s/_/$cid/o;
	$version = "1.1";											# counter version
	($lockshr,$lockexc,$locktst,$lockrel) = (1,2,4,8);          # Konstanten fuer flock()

	return $lockshr unless $incr;

	($ss,$mm,$hh,$tag,$monat,$jahr,$wtag,$ytag,$isdst) = localtime(time);

	$jahr = $jahr + 1900 if($jahr < 1900);
	$cur_dat = sprintf("%.5f",($jahr * 1000+$ytag+($hh * 3600 + $mm * 60 + $ss)/100000));

	return $lockexc;
}


sub sendIt
{
	print "Pragma: no-cache\n";

	if(!$msk)														# transparent GIF 1*1px ?
	{
		print "Content-type: image/gif\n\n";
		print "GIF89a\x01\x00\x01\x00\x80\x00\x00\x00\x00\x00\xff\xff\xff\x21\xf9\x04\x01\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x01\x00\x01\x00\x40\x02\x02\x44\x01\x00\x3b";

		return;
	}

	$_ = '%0'.$msk.'u';
	my $tcount = sprintf("$_",$counter);							# format counter

	if($ENV{'SERVER_PROTOCOL'} eq 'INCLUDED')						# SSI ?
	{
		print "Content-type: text/html\n\n";
		print $tcount;

		return;
	}

	if($mask)														# javascript ?
	{
		print "Content-type: application/x-javascript\n\n";
		print "document.write('$tcount');";

		return;
	}

	if($maskbw)  # bitmap for each digit, each digit is 8 pixels wide, 10 high
	{ @digits = ("3c 66 66 66 66 66 66 66 66 3c",		# 0 digits black on white
				 "30 38 30 30 30 30 30 30 30 30",		# 1
               	 "3c 66 60 60 30 18 0c 06 06 7e",		# 2
               	 "3c 66 60 60 38 60 60 60 66 3c",		# 3
               	 "30 30 38 38 34 34 32 7e 30 78",		# 4
               	 "7e 06 06 06 3e 60 60 60 66 3c",		# 5
               	 "38 0c 06 06 3e 66 66 66 66 3c",		# 6
               	 "7e 66 60 60 30 30 18 18 0c 0c",		# 7
               	 "3c 66 66 66 3c 66 66 66 66 3c",		# 8
               	 "3c 66 66 66 66 7c 60 60 30 1c"); }	# 9 
	else
	{ @digits = ("c3 99 99 99 99 99 99 99 99 c3",		# 0 digits white on black
				 "cf c7 cf cf cf cf cf cf cf c7",		# 1
				 "c3 99 9f 9f cf e7 f3 f9 f9 81",		# 2
				 "c3 99 9f 9f c7 9f 9f 9f 99 c3",		# 3
				 "cf cf c7 c7 cb cb cd 81 cf 87",		# 4
				 "81 f9 f9 f9 c1 9f 9f 9f 99 c3",		# 5
				 "c7 f3 f9 f9 c1 99 99 99 99 c3",		# 6
				 "81 99 9f 9f cf cf e7 e7 f3 f3",		# 7
				 "c3 99 99 99 c3 99 99 99 99 c3",		# 8
				 "c3 99 99 99 99 83 9f 9f cf e3"); }	# 9

	$tcleng = length($tcount);

	@bytes = &blankrows();								# add three blank rows to each digit

	for($iy = 0; $iy < 10; $iy++)
	{
		for($ix = 0; $ix < $tcleng; $ix++)
		{
			$digit = substr($tcount,$ix,1);
			$byte = substr($digits[$digit],$iy*3,2);
			push(@bytes,$byte);
		}
	}

	@bytes = &blankrows(@bytes);						# add three blank rows to each digit

	print ("Content-type: image/x-xbitmap\n\n");
	printf ("#define count_width %d\n#define count_height 16\n", $tcleng*8);

	printf "static char count_bits[] = {\n";
	for($ix = 0; $ix < ($#bytes + 1); $ix ++)
	{
		print("0x$bytes[$ix]");
		if ($ix != $#bytes)
		{
			print(",");
			print("\n") unless(($ix+1) % 7);
		}
	}
	print("};\n");
	
	return;
}


sub blankrows
{
	for($ix = 0; $ix < $tcleng*3; $ix ++)				# add three blank rows to each digit
	{
		if($maskbw)
		{ push(@_,"00"); }
		else
		{ push(@_,"ff"); }
	}
	return (@_);
}


sub check_reload
{
	$rec_nr = 0;
	$rel_val = sprintf("%.5f",($rel/100000));

	while($rec_nr <= $#logrec)
	{
		($_,$log_dat,$log_ip,$log_usragent) = split(/\x01/,$logrec[$rec_nr]);
		if(($cur_dat - $log_dat) < $rel_val)
		{
			return 1 if(($log_ip eq $ENV{'REMOTE_ADDR'})); # && ($log_usragent eq $ENV{'HTTP_USER_AGENT'}));
	    }
		else
		{
			return 0;
		}
		$rec_nr++;
	}
	return 0;
}


sub count_it
{
	$counter ++;

	$monat ++;
	$tag = '0'.$tag if($tag<10);
	$monat = '0'.$monat if($monat<10);
	$hh = ($hh<10) ? '0'.$hh.':' : $hh.':'; 
	$mm = ($mm<10) ? '0'.$mm.':' :  $mm.':';
	$ss = '0'.$ss if($ss < 10);

	$host = ($ENV{'REMOTE_ADDR'}) ? (gethostbyaddr(pack("C4", split(/\./, $ENV{'REMOTE_ADDR'})), 2))[0] : 'unbekannt';

	$newrec = "$tag.$monat$wtag$hh$mm$ss\x01$cur_dat"."\x01$ENV{'REMOTE_ADDR'}"."\x01$ENV{'HTTP_USER_AGENT'}"."\x01$host"."\x01$ENV{'HTTP_REFERER'}"."\x01$FORM{'REF'}"."\x01$ENV{'REMOTE_USER'}"."\x01$ENV{'SERVER_NAME'}"."\x01$FORM{'SH'}"."\x01$FORM{'SW'}$user\n";
	unshift(@logrec,"$counter\n",$newrec);

	$rec_nr = $#logrec;										# read backwards
	$cur_yyyyddd = substr($cur_dat,0,7);

	@newhist= ();
	while($rec_nr)
	{
		($log_dat1,$log_dat2,$_) = split(/\x01/,$logrec[$rec_nr],3);
		$log_yyyyddd = substr($log_dat2,0,7);
		if($log_yyyyddd < $cur_yyyyddd)
		{
			push(@newhist,$logrec[$rec_nr]);				# save yesterdays (& older) history records
		}
		else 
		{
			$#logrec = &hist_save unless($#newhist<0);	# save previous history records
			$rec_nr = 1;
		}
		$rec_nr --;
	}
	seek (LOGFILE,0,0);
	print (LOGFILE @logrec);
	truncate (LOGFILE,tell(LOGFILE));
}


sub invalid
{
	my($parm,$value) = (shift,shift);
	print "Content-type: text/html\n\n";
	print "<body><div align=center><h1>Fehlender oder ung&uuml;ltiger Parameter</h1>\n";
	print "<h2>$parm=$value</h2></div></body></html>\n";
	exit;
}