head	1.2;
access;
symbols;
locks; strict;
comment	@# @;


1.2
date	2007.06.21.08.41.52;	author openpkg;	state Exp;
branches;
next	1.1;
commitid	E3ALEgDFkYfc0Lms;

1.1
date	2007.02.08.12.27.29;	author rse;	state Exp;
branches;
next	;
commitid	B2jC1dMOyyPEwG5s;


desc
@@


1.2
log
@flush and save current state of CVS controlled data
@
text
@#!/v/openpkg/sw/bin/perl
##
##  Copyright (c) 2007 OpenPKG GmbH <http://openpkg.com>
##
##  Permission to use, copy, modify, and distribute this software for
##  any purpose with or without fee is hereby granted, provided that
##  the above copyright notice and this permission notice appear in all
##  copies.
##
##  THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
##  WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
##  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
##  IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
##  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
##  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
##  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
##  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
##  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
##  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
##  OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
##  SUCH DAMAGE.
##
##  global-polling.cgi: Polling (Perl part)
##

require 5.008;
use warnings;
use strict;
use CGI;
use CGI::GuruMeditation (-name => "OpenPKG global polling", -debug => 1);
use DBI;
use DBD::SQLite;
use DBIx::Simple;
use Date::Format;
use OSSP::uuid;

#   establish CGI query object
my $cgi = new CGI;

#   establish Database query object
my $db_filename = "global-polling.d/global-polling.db";
my $db_init = (-f $db_filename ? 0 : 1);
my $db = DBIx::Simple->connect(
    "dbi:SQLite:dbname=$db_filename", "", "",
    { RaiseError => 0, AutoCommit => 0 }
) or die "unable to open database";
if ($db_init) {
    $db->query(q{
        CREATE TABLE polling_peer (
            time            INTEGER,
            peer            TEXT,
            useragent       TEXT,
            polling         TEXT,
            id              VARCHAR(32)
        );
    }) or die $db->error();
    $db->query(q{
        CREATE TABLE polling_value (
            id              VARCHAR(32),
            variable        TEXT,
            value           TEXT
        );
    }) or die $db->error();
    $db->query(q{
        CREATE TABLE polling_event (
            time            INTEGER,
            peer            TEXT,
            useragent       TEXT,
            referer         TEXT,
            polling         TEXT,
            event           TEXT
        );
    }) or die $db->error();
    $db->commit();
}

#   generate unique id
my $uuid = new OSSP::uuid;
$uuid->make("v1");
my $id = $uuid->export("str");
undef $uuid;

#   processing
my $html = "";
my $time = time();
my $peer = ($ENV{"HTTP_X_FORWARDED_FOR"} || $cgi->remote_host());
my $useragent = $cgi->user_agent();
my $referer = $cgi->referer();
my $polling = $cgi->param("polling") || "";
my $event   = $cgi->param("event") || "";
if ($polling ne '') {
    if ($event ne '') {
        $db->query(q{
            INSERT INTO polling_event (time, peer, useragent, referer, polling, event) VALUES (??);
        }, $time, $peer, $useragent, $referer, $polling, $event) or die $db->error();
    }
    else {
        my $checks = {
            "polling_approach" => qr{^.+$},
            "polling_platform_custom" => qr{^(?:|[^\r\n]+)$},
            "polling_solution_custom" => qr{^(?:|[^\r\n]+)$},
            "polling_price_value"     => qr{^[0-9]+(?:\\.[0-9]+)?$},
        };
        foreach my $name (keys %{$checks}) {
            my $value = $cgi->param($name) || "";
            my $regex = $checks->{$name};
            if ($value eq '') {
                die "incorrect structure";
            }
            if ($value !~ $regex) {
                die "incorrect value \"$name\"";
            }
        }
        $db->query(q{
            INSERT INTO polling_peer (time, peer, useragent, polling, id) VALUES (??);
        }, $time, $peer, $useragent, $polling, $id) or die $db->error();
        foreach my $variable (grep { $_ =~ m/^polling_/ } $cgi->param()) {
            my $name = $variable;
            $name =~ s/^polling_//s;
            my $value = $cgi->param($variable);
            $db->query(q{
                INSERT INTO polling_value (id, variable, value) VALUES (??);
            }, $id, $name, $value) or die $db->error();
        }
    }
}

#   send output 
print $cgi->header(
    -status         => "204 No Content",
    -type           => "text/plain",
    -Content_length => length($html),
) . $html;

#   close database
$db->commit();
$db->disconnect();
undef $db;

@


1.1
log
@flush all pending changes to meta.openpkg.org
@
text
@d98 16
@