#!/usr/local/bin/perl -w
# counter3.pl -- Ein DBI-basierter komplexer Webcounter mit Tie::RDBM

use strict;

use CGI qw(:standard);                       # Unser CGI.pm Modul
use CGI::Carp qw(fatalsToBrowser);           # Fehlermeldungen zum Browser
use GD;                                      # Zum Erzeugen von GIFs
use Tie::RDBM;                               # Datenbankzugriffe
use Socket;                                  # Wegen which_domain()
use Data::Dumper;                            # in output_statistics()

# Konfigurationsdaten fuer die verwendete DBI-Datenbank
use constant DB_DSN   => 'mysql:www';        # Welche Datenbank?
use constant DB_USER  => $ENV{'user'};       # User-Login
use constant DB_PASS  => 'wwwpass';          # User-Passwort
use constant DB_TABLE => 'counter_cmplex';   # Tabelle mit Zaehlerdaten

# Fuer welche Seite soll der Zaehler inkrementiert werden?
my $sessionid = $ENV{'PATH_INFO'};
$sessionid =~ s!/!_!g;
my $query = new CGI;
error("Usage: Set PATH_INFO first!") if (!$sessionid);

# Wir stellen eine Verbindung zur DBI-Datenbank her.
my %counter;
tie %counter, 'Tie::RDBM', DB_DSN, { user  => DB_USER, password => DB_PASS,
                     table => DB_TABLE, create  => 1 }
    or die "Can't tie to database: $!\n";

# Wir holen die Zaehlerdaten in eine lokale Variable:
tied(%counter)->{'dbh'}->do("LOCK TABLES " . DB_TABLE . " WRITE");
die $DBI::errstr if $DBI::err;

    my $tmpcounter = $counter{$sessionid};
        my $newvalue = ++$tmpcounter->{'MaxHits'};
        ++$tmpcounter->{'Domain'}->{which_domain()};
        ++$tmpcounter->{'Day'}->{which_day()};
        ++$tmpcounter->{'Week'}->{which_week()};
        ++$tmpcounter->{'Month'}->{which_month()};
        ++$tmpcounter->{'Browser'}->{which_browser()};
    $counter{$sessionid} = $tmpcounter;

tied(%counter)->{'dbh'}->do("UNLOCK TABLES");
die $DBI::errstr if $DBI::err;

# Abhaengig von der Aufruf-Art, senden wir das Bildchen mit dem
# Zaehlerstand zurueck, oder aber eine Seite mit Statistiken.
if (defined ($query->param('getstats'))) {
    output_statistics($tmpcounter, $query->param('getstats'));
} else {
    output_as_gif($newvalue);
}

# Verbindung zur Datenbank wieder loesen.
untie %counter;

# output_as_gif($message) gibt den String in $message als
# GIF-Bild (MIME-Typ: image/gif) aus.
sub output_as_gif {
    my $message = shift;    # Die auszugebende Nachricht
    my ($x,$y) = (length($message) * gdLargeFont->width() + 10,
          gdLargeFont->height() + 10);
    my $im = new GD::Image($x, $y);

    $im->transparent();
    $im->interlaced('true');
    $im->rectangle(0,0,$x,$y,$im->colorAllocate(0,0,0));

    $im->string(gdLargeFont,5,5,
        $message,$im->colorAllocate(255,255,255));
    my $gif = $im->gif();

    # GIF-Bild zum Browser senden:
    print
    $query->header(-type => 'image/gif', -expires => '-1d'),
    $gif;
}

# Gibt detaillierte Statistiken zum aktuellen Zaehler aus.
# Ist getstats=1, wird eine textuelle Data::Dumper-Darstellung
#           des Statistik-Hashes ausgegeben (text/plain).
# Ist getstats=2, wird eine HTML-Seite mit verschieden Tabellen gedruckt,
#           basierend auf dem Statistik-Hash (text/html).
sub output_statistics {
    my $stats = shift;        # Die Statistik-Struktur
    my $kind  = shift;        # 1: text/plain, 2: text/html

    if ($kind eq '1') {
    # Hier geben wir eine einfache Data::Dumper Darstellung
    # des Statistik-Hashes %{ $stats } aus.
    print
        $query->header(-type => 'text/plain'),
        Dumper($stats);
    } elsif ($kind eq '2') {
    # Hier geben wir HTML-Tabellen aus mit dem Inhalt
    # des Statistik-Hashes %{ $stats }.
    print
        $query->header(),
        $query->start_html("Counter Statistics ($sessionid)"),
        $query->h1("Counter Statistics ($sessionid)"),
        $query->h2("Counter Value"),
        "Counter hit ", $query->b($stats->{'MaxHits'}), " times",
        $query->p();

    foreach my $key (sort keys %{ $stats }) {
        next if $key eq 'MaxHits';
        print
          $query->h2($key),
          $query->table(
             map { $query->Tr( $query->td ( [ $stats->{$key}->{$_},
                          $_ ] ) ) } 
                 sort { $stats->{$key}->{$b}
                   <=>
            $stats->{$key}->{$a} } keys %{ $stats->{$key} }
              ),
          $query->p();
    }

    print
        $query->end_html();

    } else {
    # Nur getstats=1 oder getstats=2 zur Zeit implementiert
    error("Usage: counter3.pl/countername?getstats=1 or =2");
    }
}

# error($message) gibt eine Fehlermeldung im GIF-Format aus
# und beendet das Programm.
sub error {
    my $message = shift;
    output_as_gif($message);
    exit 0;
}

# Identifiziert die Top-level Domain anhand der Umgebunsvariable
# REMOTE_ADDR mit Hilfe des DNS. Ausgabe z.B.: "net", "com", "edu", "de"
# Wenn die IP-Adresse nicht zu einem Namen aufgeloest werden konnte,
# wird einfach "???" zurueckgegeben.
sub which_domain {
    my $dnsname = gethostbyaddr(inet_aton($ENV{'REMOTE_ADDR'}), AF_INET);

    if (defined $dnsname) {
    $dnsname =~ s/^.*\.(.*?)$/$1/;  # bsd-1.meta.net -> net
    } else {
    $dnsname = '???';               # unbekannte Domain
    }

    return $dnsname
}

# Liefert den heutigen Wochentag zurueck: "mon", "tue", "wed", ...
sub which_day {
    return ('sun', 'mon', 'tue', 'wed',
            'thu', 'fri', 'sat')[(localtime(time()))[6]];
}

# Liefert die aktuelle Kalenderwoche zurueck.
sub which_week {
    return int((localtime(time))[7]/7) + 1; # yday/7 + 1
}

# Liefert den heutigen Monat als String zurueck: "jan", "feb", "mar", ...
sub which_month {
    return ('jan', 'feb', 'mar', 'apr',
            'may', 'jun', 'jul', 'aug',
            'sep', 'oct', 'nov', 'dec')[(localtime(time()))[4]];
}

# Liefert den Browser-String zurueck.
sub which_browser {
    return $ENV{'HTTP_USER_AGENT'};
}