#!/usr/bin/perl # By Stephen Downes -- http://www.downes.ca -- stephen@downes.ca # Released under GNU Public License # # Copyright (C) # This program is free software; you can redistribute it and/or modify it under the terms of the # GNU General Public License as published by the Free Software Foundation; either version 2 of the # License, or (at your option) any later version. # This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # http://www.opensource.org/licenses/gpl-license.html # You should have received a copy of the GNU General Public License along with this program; if # not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # This General Public License does not permit incorporating your program into proprietary programs. # # May 12, 2002 - Version 1.000 # # # 15. Mai 2002 # Aufgebohrte Version 1.000 mit erweiterter Referrer-Prüfung, # Einsatz auf mehreren Domains am selben Host und Prüfung auf gültige Seiten. # Achtung: die Funktion, um den Seitentitel des Referrers herauszufinden, wurde herausgestrichen, # da unser Server den Verbindungsaufbau zu anderen Webservern via LWP-Modul nicht unterstützt. # # Ernst Michalek, ernst@michalek.at use CGI qw(param); # # Edit these parameters # $datadir = "/gesamter/pfad/zum/datenverzeichnis/"; # Directory muß auf chomd 777 gesetzt werden! @norefs = ( 'eigene-domain1.at', 'eigene-domain2.at', 'eigene-domain3.co.at', 'eigene-domain4.cc', '127.0.0.1', '192.168.0.1', 'google', 'lycos', 'altavista', 'stat', 'alltheweb', 'translate', 'search', 'cgi', ); #Feld mit allen URLs oder Worten innerhalb der URLs, die nicht aufscheinen sollen @validpages = ( 'eigene-domain1.at', 'eigene-domain2.at', 'eigene-domain3.co.at', 'eigene-domain4.cc' ); #Feld mit gültigen Pages, auf denen das Script eingesetzt werden darf require "../cgi-lib.pl"; &ReadParse(%form,%cgi_cfn,%cgi_ct,%cgi_sfn); # Parse the form $valid = 0; foreach $testvalue (@validpages) { if ($form{'out'} =~ $testvalue) {$valid=1; last;} # Unberechtigte Pages rauswerfen } my $save_file = $form{'out'}; # Define data file name if ($form{'out'} =~ "index.php") { $save_file =~ s/index.php//g; } # Indexdatei wegkürzen, funktioniert nicht im Root-Verzeichnis, weil sonst kein Dateiname überbleibt - dann diese Zeile auskommentieren! $save_file =~ s/www//g; # Filename basteln: www wegkürzen $save_file =~ s/http://g; # http wegkürzen foreach $testvalue (@validpages) { $save_file =~ s/$testvalue//g; # Berechtigte URLs um den Domainnamen kürzen } $save_file =~ s////g; # Slashes kürzen $save_file =~ s/.//g; # Punkte rauswerfen $tinfile = $datadir . $save_file . ".dat"; # Define file names for file updates $ttfile = $datadir . $save_file . ".sav"; $bakfile = $datadir . $save_file . ".bak"; print "Content-type: text/javascriptnn"; # Print Javascript header # while (($fx,$fy) = each %form) { $form{$fx} =~ s///\//g; } # Some diagnostics # print "document.write("Hello - In: $form{'in'} -- Out: $form{'out'}");n"; if ($valid==1){ if ($form{'in'} && $form{'out'}) { $save_file = &update_data; } # If referrer detected, update the record if ($form{'out'}) { &show_data($save_file); } # Otherwise, just show the data else { print "document.write("This is test mode, no URL supplied.");n"; } # Or show this message if no values are submitted } else { print "document.write("Unberechtigte Seitenadresse!");n"; # Warum soll ich fremde Logfiles führen? } sub update_data { return if ($form{'out'} =~ "admin"); foreach $noreferrer (@norefs) { return if ($form{'in'} =~ $noreferrer); # Don't track internal site referrals } open OUT,">$ttfile" or print "document.write("Cannot open ttfile");n"; # Open output file, and if (-e $tinfile) { # If it exists, open IN, "$tinfile" # Open the input file or print "document.write("Cannot open tinfile");n"; $match = "no"; # Initialize match flag while () { # For each input file record chomp; ($number,$url) = split /t/,$_; # Get the data if ($url eq $form{'in'}) { # And if the saved url matches the referrer $number++; # Increment the number of hits print OUT "$numbert$urln"; # And save $match = "yes"; # Flagging the match } else { # Otherwise print OUT "$numbert$urln"; # Just save the old record } } } unless ($match eq "yes") { # Now if there was no match (it's a new referrer) print OUT "1t$form{'in'}n"; # Save as a new record } close IN; # Close all our files and close OUT; # Rename if (-e $tinfile) { rename($tinfile, $bakfile) or print "document.write("Rename: $tinfile
");n"; } rename($ttfile, $tinfile) or print "document.write("Can't rename: $ttfile
");n"; return $save_file; } sub show_data { my ($save_file) = @_; print "function referrals() {n"; # Print javascript function name print " document.write("

Seiten, die auf diese Seite verlinken:

");n"; # Print title open NIN,"$tinfile" or print "document.write("Bisher keine Referrer aufgezeichnet.");"; # Open data file while () { # And for each record push @ldata,$_; # Put the data into an array } close NIN; # Close the data file @ldata = sort { $b <=> $a } @ldata; # Sort, most hits to least foreach $lline (@ldata) { # For each record in the array $lline =~ s/n//g; # Kill the line feed $lline =~ s///\//g; # Make the slashes Javascript ready ($dnum,$durl) = split /t/,$lline; # Extract the data print " document.write("- $durl mit $dnum Zugriffen
");n"; # Print out the information } # And a nice closing message print " document.write("

Referral service by Stephen's Web

cuteftppro 6.0 serial");n"; print "}nreferrals();n"; }