#!/usr/bin/perl

=head1 NAME

formlite.cgi - Save form data to a database table which supports an easy export to a spreadshet

=head1 SYNOPSIS

Written as "sample code" for using CGI & Sqlite.  This form will save it's values to a database, 
which can be later exported to a spreadsheet, or viewed:

	<form action="/cgi-bin/formlite.cgi" method=post>
	<input type=hidden name=_ok value="ok.html">
	Name: <input type=text name=name>
	Age: <input type=text name="age+int">
	</form>

=cut

use strict;
use CGI ':standard';
use CGI::Carp;
use DBI;
use Data::Dumper;

=head1 PARAMETERS

You can specify some hidden form control values:

_ok	: page to redirect to if everything was OK, passed the "row_id" variable to that page/cgi
_err	: page to redirect to if there was an error, passed the "err_str" variable to that page/cgi
_file	: name of db file to use - think of this as your spreadsheet, specify a different _file for each form.
_debug 	: turn on debugging, never redirect

By default any data passed to formlite that doesn't begin with an underscore is saved to the database.

The fields below are reserved, and are populated automatically, don't use them in your db:

_id	: row id
_ip	: ip address of person who submitted the form
_time	: time row was added 

Data fields can end with special plus-suffixes that change how they are validated.

<field>+word		: validated as string containing \w values (a-zA-Z0-9\._-) only
<field>+name		: validated as string containing words and spaces only
<field>+int		: validated as an integer
<field>+list+<name>	: validated against hidden value named _<name> which is 
			  used as a comma-delimited list to check values against

Data fields without suffixes are not validated, and are saved as-is

Variables in the source code provide usable defaults, you shouldn't need to change these for most scripts.

	my $DB_NAME = 'data';
	my $DB_EXT = 'formlite';
	my $DB_DIR = '';                # defaults to 'same as cgi', might want to change this

	my $MAX_LEN_NAME = 50;
	my $MAX_LEN_VALUE = 5000;
	my $MAX_FIELDS = 100;

=cut

# copy to documentaton above if changed
my $DB_NAME = 'data';
my $DB_EXT = 'formlite';
my $DB_DIR = '';		# defaults to 'same as cgi', might want to change this

my $MAX_LEN_NAME = 50;
my $MAX_LEN_VALUE = 5000;
my $MAX_FIELDS = 100;

# NOTE: This script by default enables anyone to open ANY file named <name>.$DB_EXT in the $DB_DIR directory, and try to save values to it, but only if it's a extant, valid sqlite database that's writable by the CGI script - so it's not so bad.  Paranoid people can hardcode the database name, and turn this off.

my $ALLOW_FILE = 1;

############################################

# initialize

my $DB_PATH;
if (my $f = param('_file') && $ALLOW_FILE) {
	$f .= '.' . $DB_EXT;
	$f =  $DB_DIR ? "$DB_DIR/$f" : $f;
	$DB_PATH = $f if -s $f;
	if (!$DB_PATH) {
		fail("Can't open $f, file does not exist");
	}	
} else {
	$DB_PATH = $DB_DIR ? "$DB_DIR/$DB_NAME.$DB_EXT" : "$DB_NAME.$DB_EXT";
}

# setup debug info
my $DEBUG = param('_debug');
my $DTMP = '';

debug("DB=$DB_PATH");

# connect to DB
my $DB = DBI->connect("dbi:SQLite:dbname=$DB_PATH","","");

fail("Can't open DB $DB_PATH: " . DBI->errstr) if (!$DB);

my $CONF;

configure();

my $ok_url = param_url('_ok', conf('ok'));
my $err_url = param_url('_err', conf('err'));
my $fields = conf('fields');		# comma delimited list of allowed fields;
my $row_id;
my $err_str;

fail('DEBUG') if $DEBUG;

my %fields;

if ($fields) {
	for (split(/\s*,\s*/, $fields)) {
		$fields{lc($_)} = 1;
	}
}

#### time to validate

my @fds;
my $flds;
my $vals;
for my $f (param()) {
	next if $f =~ /^_/;
	next unless $f =~ /^[a-z0-9_.+-]+$/i;
	if (%fields && !$fields{lc($f)}) {
		$err_str .= "Invalid field '$f'<br>";
		next;
	}
	my $v = param($f);
	next if length($v) > $MAX_LEN_VALUE; 

	my $val = $1 if $f =~ s/\+(int|word|name|(list\+\w+))$//i;
	my $list = $1 if $val =~ s/^list\+(.*)/list/;
	$list = param("_" . $list) if $list;

	next if length($f) > $MAX_LEN_NAME; 

	if ($list) {
		$v =~ s/^\s+//; $v =~ s/\s+$//;
		my %list = map {lc($_), 1} split(/\s*,\s*/, $list);
		$err_str .= "Invalid value '$v' for field '$f'<br>" if !$list{lc($v)};
	}

	if ($val eq 'int') {
		$v =~ s/^\s+//; $v =~ s/\s+$//;
		$err_str .= "Invalid value '$v' for field '$f', need integer<br>" if $v !~ /^\d+$/;
	} elsif ($val eq 'word') {
		$v =~ s/^\s+//; $v =~ s/\s+$//;
		$err_str .= "Invalid value '$v' for field '$f', need word<br>" if $v !~ /^\w+$/;
	} elsif ($val eq 'name') {
		$v =~ s/^\s+//; $v =~ s/\s+$//;
		$err_str .= "Invalid value '$v' for field '$f', need name<br>" if $v !~ /^[\w ]+$/;
	}

	$v =~ s/\\/\\\\/g;
	$v =~ s/'/''/g;

	push @fds, $f;
	$flds .= "$f,";
	$vals .= "'$v',";
}

$flds =~ s/,$//;
$vals =~ s/,$//;

if (!$vals) {
	$err_str .= "No values specified<br>";
}

if ($err_str) {
	save_err();
}

#### time to save, we could blob into 1 field - but that would be boring

local $DB->{PrintError} = 0;
my $s = $DB->prepare("select * from data limit 0");
if (!$s) {
	# easy, make a table to match
	my $qry = "create table data (_id integer primary key autoincrement, _ip text, _time int, " . $flds . ")";
	if (!$DB->do($qry)) {
		save_err($DB->errstr);
	}
} else {
	# fields grew
	my %f;
	my $c;
        for (@{$s->{NAME}}) {
                $f{lc($_)} = 1;
		++$c;
        }
	my $qry;
	my $a;
	for ((@fds , '_id', '_ip', '_time')) {
                $qry .= "alter table data add $_ text;" if ! $f{lc($_)};
		++$a;
	}
	if (($c + $a) > $MAX_FIELDS) {
		save_err("Too many fields.");
	}
	if ($qry && !$DB->do($qry)) {
		save_err($DB->errstr);
	}
	$s->execute();
	$s->finish();
}

my $ip = remote_host();
my $time = time();
my $qry = "insert into data (_ip, _time, $flds) values ('$ip', '$time', $vals)";

if (!$DB->do($qry)) {
	$err_str .= $DB->errstr;
	save_err();
}

save_ok();

sub debug {
	if ($DEBUG) {
		$DTMP .= "$_[0]\n";	
	}
}

sub fail {
	$DTMP .= "$_[0]\n";
	$DTMP=pre($DTMP) if $DTMP;
	print header, start_html('Formlite : Error'), h1('Error'), $DTMP, end_html();	
	exit(0);
}


sub save_ok {
	if ($ok_url) {
		print redirect($ok_url . ($ok_url =~ /\?/ ? '&' : '?') . "row_id=$row_id");
	} else {
		$DTMP=pre($DTMP) if $DTMP;
		print header, start_html('Formlite : OK'), h1('OK'), p, "Information was saved.", $DTMP, end_html();	
	}
	exit(0);
}

sub save_err {
	my ($str) = @_;
	$err_str .= $str if $str;
        if ($err_url) {
                print redirect($err_url . ($err_url =~ /\?/ ? '&' : '?') . "err_str=$err_str");
        } else {
		$DTMP=pre($DTMP) if $DTMP;
                print header, start_html('Formlite : Error'), h1('Error'), p, "Error saving information: <p> $err_str.", $DTMP, end_html();
        }
        exit(0);
}



sub configure {

#load config
	loadconf();

#create config
	if (!$CONF) {
		$DB->do("create table conf (name text not null primary key, value text)");
		loadconf();
	}

	if (!$CONF) {
		fail("Can't create/load config table");
	}


	if (!(conf('pwd') eq param('_pwd'))) {
	  if (conf('pwd') && (!param() || param('_pwd'))) {
		print header, start_html('Formlite : Login'), h1('Login');
        	print start_form(),
                "<p> Password: ",
                password_field('_pwd'),
		submit('Go');
                end_form;
        	end();
	  }
	  return;
	}

# check password


# lightweight admin page
	if (param('_save')) {
		setconf('ok', param('ok'));	
		setconf('err', param('err'));	
		if (param('newpwd')) {
			param('_pwd',param('newpwd')); 
			setconf('pwd', param('newpwd'));	
			param('newpwd','');
		}
	}

	if (param('_view') || param('_export')) {
	    my ($where, $limit);

	    $where = "where _id > " . (conf('last') + 0) if param('since'); 
	    $limit = "limit " . param('num') if param('num');

	    my $qry = "select * from data $where order by _id desc $limit";
            my $s = $DB->prepare($qry);
	    if (!$s || !$s->execute()) {
		fail(!$s ? $DB->errstr : $s->errstr);
	    }

	    my $idx = -1;

	    {
	    	my $i=0;	
	    	grep {$idx=$i && last if $_ eq '_id'; ++$i} @{$s->{NAME}};
	    }

	    fail("Can't find _id field") unless $idx >= 0;

	    my $l;
	    if (param('_export')) {
		print header('application/vnd.ms-excel');

		my @d;
		my $idx;
		for (@{$s->{NAME}}) {
			push @d, $_;
		}
		print join(',',@d) . "\r\n";
	
		while (my $r = $s->fetchrow_arrayref()) {
			my @d = ();
			for (@{$r}) {
				if ($_ =~ /,/) {
					s/\"/\"\"/g;
					$_ = '"' . $_ . '"';
				}
				push @d, $_;
			}
			print join(',',@d) . "\r\n";
			$l = $r->[$idx] if $r->[$idx] > $l;
		}
	    } elsif (param('_view')) {
                print header;

		print start_html;

                my @d;
                print "<table border=1><tr>";
                for (@{$s->{NAME}}) {
                        print "<th>$_</th>";
                }
                print "</tr>";

                while (my $r = $s->fetchrow_arrayref()) {
                	print "<tr>";
                        for (@{$r}) {
                        print "<td>$_</td>";
			}
                	print "</tr>";
			$l = $r->[$idx] if $r->[$idx] > $l;
                }
		print end_html;
	    }

	    setconf('last', $l);
	    exit(0);
        }

	print header, 
		start_html(
			-title=>'Formlite : Admin',
			-style=>{-code=>'
				body {
				font-familiy: sans;
				}
				.aligned input {
				color: blue;
				position: absolute;
				left: 20%;
				clear: both;
				}
				.aligned p {
				vertical-align: top;
				}
			'}
		), h1('Administration');

	if (conf('pwd')) {

	print "<div class=aligned>";
	print start_form(),
		hidden('_pwd',param('_pwd')),
		checkbox(-name=>'since', -label=>"Only show data since last view/export");

	print '<p>Limit Number of Rows: ',
		textfield(-name=>'num', -size=>4);
	print "</div>";

	print	p
		submit('_view','View Data'),
		submit('_export','Export Data');

	} else {
		print "<p>Configuring $DB_NAME for first use by formlite." 
	}

	print "<div class=aligned>";
	print start_form(),
		hidden('_pwd',param('_pwd')),
		"<p> Redirect on OK: ",
		textfield('ok',conf('ok')),
		"<p> Redirect on ERROR: ",
		textfield('err',conf('err')),
		"<p> Allowed fields: ",
		textfield('fields',conf('fields'),40),
		"<p> Change Password: ",
		password_field('newpwd'), p;
	print "</div>";

	print "<p>Leave the field list blank, or fill with a comma-delimited list of fields with optional plus-suffixes.  If present, this will cause the form to fail if other unmatched fields are present.";

	print
		p, submit('_save','Save Settings'),
		end_form;

	end();
}


sub loadconf {
        undef $CONF;
        local $DB->{PrintError} = 0;
	my $r = $DB->selectall_arrayref("select name, value from conf");
	if ($r) {
		$CONF = {};
	}
        for (@{$r}) {
                $CONF->{$_->[0]} =$_->[1] if $_->[0];
        }
}



sub end {
	print pre($DTMP) if $DTMP;
	print end_html();
	exit(0);
}


sub conf {
	my ($name, $default) = @_;
	if ($default) {
		return $CONF->{$name} ? $CONF->{$name} : $default;
	} else {
		return $CONF->{$name};
	}
}

sub setconf {
        my ($name, $value) = @_;
        $value =~ s/\\/\\\\/g;
        $value =~ s/'/''/g;

        my ($exists) = $DB->selectrow_array("select name from conf where name='$name'");
        my $res;
        if ($exists) {
                $res = $DB->do("update conf set value='$value' where name ='$name'");
        } else {
                $res = $DB->do("insert into conf (name, value) values ('$name', '$value')");
        }
        $CONF->{$name} = $value;

	return $res;
}

sub param_url {
	my ($name, $def) = @_;
	return $def if !param($name);
	if (param($name) =~ /^[a-z0-9:@\/&%,;=_#-]+$/) {
		return param($name);
	} else {
		debug("$name is not a valid url");
	}
	return undef;	
}

sub param_word {
        my ($name, $def) = @_;
        return $def if !param($name);
        if (param($name) =~ /^\w+$/) {
                return param($name);
	} else {
		debug("$name is not a simple word");
        }
        return undef;
}


=head1 COPYRIGHT

Copyright 2008 Erik Aronesty

Free software distributed under the Perl Artistic License.

See L<perlartistic>

=head1 WARRANTY

The program is free. IT COMES WITHOUT WARRANTY OF ANY KIND.

=cut