#!/usr/bin/perl
#-------------------------------------------#
# Upload Smile of the Month images and text #
# December, 2003, by Harley H. Puthuff #
#-------------------------------------------#
#-------Local properties and methods:
$me = $0; $me = $1 if ($me =~ /.*\/(.+)$/);
sub put ($) {print STDOUT shift(),"\n"}
#-------Main loop and dispatch:
$cgi = new Cgi;
if (exists $cgi->{Update})
{processForm()}
else
{displayForm()}
exit 0;
#-------Display the update form:
sub displayForm {
$cgi->headers;
print STDOUT <<"ETX";
Smile Enhancement Studio, Smile of the Month, Photo uploads
ETX
}
#-------Process the updated form data:
sub processForm {
open TEXT,">Commentary.txt";
print TEXT $cgi->{Commentary};
close TEXT;
$cgi->redirect("../monthly.shtml");
}
#-------------------------------------------------------#
# Cgi class - Web server CGI interface #
#-------------------------------------------------------#
package Cgi;
#-------Internal: send line to STDOUT (w/newline appended)
# P1 = text of line
sub put ($) {print STDOUT shift(),"\n"}
#-------Internal: compute a cookie date/expiration in GMT:
# P1 = days to keep cookie (0-n)
# returns a string with GMT expiration date
sub expireDate ($) {
my $days = (shift() * 86400);
my @t = gmtime($days + time);
return sprintf("%3s, %02d %3s %04d %02d:%02d:%02d GMT",
(Sun,Mon,Tue,Wed,Thu,Fri,Sat)[$t[6]],$t[3],
(Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec)[$t[4]],
$t[5]+1900,$t[2],$t[1],$t[0]);
}
#-------Internal: Decode HTTP_COOKIE variable
sub decodeCookies {
my $this = shift;
my ($name,$value);
foreach (split /; /,$ENV{HTTP_COOKIE}) {
($name,$value) = split /=/;
$value =~ tr/\+/ /;
$value =~ s/%(..)/chr(hex($1))/ge;
$this->{cookies}->{$name} = $value;
}
}
#-------Internal: Decode URL-Encoded data
# P1 = encoded string
sub decodeUrlEncoded {
my $this = shift;
my $string = (shift || return);
my ($key,$data);
foreach (split /\\*&/,$string) {
tr/\+/ /;
($key,$data) = split /=/,$_,2;
foreach ($key,$data) {s/%(..)/chr(hex($1))/ge}
if ($this->{$key} ne '')
{$this->{$key} .= ",$data" unless ($data eq '')}
else
{$this->{$key} = $data}
}
}
#-------Internal: Decode Multipart-Form data from STDIN
sub decodeMultipart {
my $this = shift;
my ($buffer,$line,$name,$filename,$type,$pfile);
my ($phandle,$lastname,$thisname,$boundary);
if ($ENV{CONTENT_TYPE} =~ /boundary=(.*)/i)
{$boundary = $1} else {return}
while ($line = ) {
if ($line =~ /$boundary/) {
chomp $buffer;
chop $buffer if (substr($buffer,-1,1) eq "\r");
if ($pfile ne '') {
print $phandle $buffer if ($buffer ne '');
close $phandle;
}
elsif (($name ne '') && ($this->{$name} eq '')) {
$this->{$name} = $buffer;
}
elsif (($name ne '') && ($this->{$name} ne '')) {
$this->{$name} .= ",$buffer" unless ($buffer eq '');
}
$name = ''; $filename = ''; $type = '';
$pfile = ''; $phandle = ''; $buffer = '';
next;
}
if ($line =~ /Content-Type:/i) {
$type = $1 if ($line =~ /Content-Type: (.*)\s*/i);
$line = ;
next if ($line =~ /^\r?\n$/);
redo;
}
if ($line =~ /Content-Disposition:/) {
$name = $1 if ($line =~ /name=\"(.*?)\"/i);
$filename = $2 if ($line =~ /filename=".+(\\|\/)(.+)"/i);
if ($filename ne '') {
$pfile = "$name.jpg";
$this->{$name} = $pfile;
open($phandle,">$pfile");
}
$line = ;
next if ($line =~ /^\r?\n$/);
redo;
}
if ($filename ne '') {
print $phandle $buffer if ($buffer ne '');
$buffer = $line;
next;
}
$buffer .= $line;
}
}
#-------constructor:
# returns a ref. to a new object
sub new {
my $class = shift;
my $this = {};
bless $this, $class;
$this->{cookies} = {};
$this->decodeCookies() if ($ENV{HTTP_COOKIE} ne '');
$this->decodeUrlEncoded($ENV{QUERY_STRING}) if ($ENV{QUERY_STRING} ne '');
$this->decodeUrlEncoded($ENV{QUERY_STRING_UNESCAPED}) if ($ENV{QUERY_STRING_UNESCAPED} ne '');
if ($ENV{REQUEST_METHOD} =~ /post/i) {
if ($ENV{CONTENT_TYPE} =~ /multipart\/form-data/i)
{$this->decodeMultipart()}
else {
my $buffer;
read(STDIN,$buffer,$ENV{CONTENT_LENGTH});
$this->decodeUrlEncoded($buffer);
}
}
return $this;
}
#-------destructor:
sub DESTROY {
my $this = shift;
return;
}
#-------fetch a cookie:
# P1 = cookie name
# returns a string w/cookie value
sub getCookie {
my $this = shift;
my $name = (shift || return);
return $this->{cookies}->{$name};
}
#-------store a set-cookie header:
# P1 = cookie name
# P2 = (optional) cookie value (omitted=delete)
# P3 = (optional) days to keep
# P4 = (optional) path for cookie
# P5 = (optional) domain for cookie
sub setCookie {
my $this = shift;
my $name = (shift || return);
my ($value,$days,$path,$domain) = @_;
my $cookie = "Set-Cookie: $name=";
$this->{cookies}->{$name} = $value;
if ($value ne '') {
$value =~ s/([^a-zA-Z0-9 ])/sprintf("%%%s",uc(unpack('H*',$1)))/ge;
$value =~ tr/ /\+/;
$cookie .= ($value . '; ');
$cookie .= ('expires=' . expireDate($days) . '; ') unless ($days == 0);
}
else {
$cookie .= ('; expires=' . expireDate(-1) . '; ');
}
$path = '/' if ($path eq '');
$cookie .= "path=$path; ";
$cookie .= "domain=$domain; " unless ($domain eq '');
put $cookie;
}
#-------produce HTTP headers:
sub headers {
my $this = shift;
put qq|Expires: Sat, 01 Jan 2000 00:00:00 GMT|;
put qq|Content-type: text/html\n|;
}
#-------produce HTTP redirect headers:
# P1 = redirect to URL
sub redirect {
my $this = shift;
my $url = (shift or return);
put qq|Location: $url\n|;
exit 0;
}