#!/usr/bin/perl ######################################### # _session.txt # coordinates all raw input/output # plus formatting and headers for some reason use DBI; use Image::Size; use constants; our $base_path = $BUCKY_CONFIG->{BASE_PATH}; our $temp_path = $base_path."incoming"; our $data_path = $base_path."data"; our $live_path = "/bucky/data"; our $USER = -1; our $input = getargs( { base => $temp_path, file => "temp_[(field)]" } ); our $DEBUG = $ENV{REQUEST_URI} =~ /debug/; if ($DEBUG) { print "Content-type: text/html\n\nENTERING DEBUG MODE . . .
"; }
$input->{object_from_uri} = get_object_from_uri();
$input->{script_from_uri} = get_script_from_uri();
our $cookies = getCookies();
our $dsn = "DBI:mysql:$BUCKY_DB:localhost;mysql_read_default_file=$BUCKY_DB_CNF";
our ($dbh, $sth);
# extract script from URI
sub get_script_from_uri
{
my $request_uri = $ENV{REQUEST_URI};
# /profile
# /profile/
# /profile/jules
# /profile/jules/
# /profile?username=jules
# /profile/jules?username=rakubian
my ($script, $object) = $request_uri =~ /^$BUCKY\/(\w+)\/?(\w+)?\??/;
return $script if (length($script) > 0);
return undef;
}
# extract object from URI, if using / URI delimiters
sub get_object_from_uri
{
my $request_uri = $ENV{REQUEST_URI};
my ($method, $object) = $request_uri =~ /^$BUCKY\/(\w+)\/([a-zA-Z0-9]+)/;
# only return object if it exists and has a length > 0
print "method: $method
\n" if ($DEBUG);
print "view: $object
\n" if ($DEBUG);
return $object if (length($object) > 0);
return undef;
# return $object || undef;
# return "";
}
# check cookies, return userhash, lastlog
sub checkin
{
my $lastlog;
my $user = check_cookie();
if (ref($user) && $user != -1)
{ print "
HELLO $user->{username}
" if $DEBUG; }
elsif ($ENV{REQUEST_URI} =~ /$BUCKY\/invite/)
{ return ( -1 ); }
else
{ logout(0); }
$lastlog = lastlog($user);
touch_user($user->{id}) if ($user != -1);
return ($user, $lastlog);
}
sub check_cookie
{
if (exists($cookies->{name}))
{
if ($cookies->{name} && $cookies->{name} ne 'unknown')
{ $user = auth($cookies->{name}, $cookies->{pass}); }
elsif ($ENV{REQUEST_URI} =~ /$BUCKY\/invite/)
{ return ( -1 ); }
}
}
# check passwords, set cookie
sub auth
{
my ($inname, $inpass) = @_;
$inname = lc($inname);
# $inname = "marc";
my ($dbuh) = get_user($inname);
if ($dbuh != -1 && $dbuh->{ulevel} > 0 && $dbuh->{password} eq $inpass)
{
my $forever = check_key($dbuh->{boxes}, "nologout");
setCookie( { name => "name", value => $inname, path => "$BUCKY/", domain => $BUCKY_COOKIE_DOMAIN, nologout => $forever } );
setCookie( { name => "pass", value => $inpass, path => "$BUCKY/", domain => $BUCKY_COOKIE_DOMAIN, nologout => $forever } );
# setCookie("name", $inname, "$BUCKY/", $BUCKY_COOKIE_DOMAIN );
# setCookie("pass", $inpass, "$BUCKY/", $BUCKY_COOKIE_DOMAIN );
return ($dbuh);
}
else
# { return -1; }
{ logout(0); }
}
sub logout
{
my $error = shift;
my $lender = undef;
my $s = $ENV{'HTTPS'} eq "on" ? "s" : "";
# my $s = "";
setCookie( { name => "name", value => undef, path => "$BUCKY/", domain => $BUCKY_COOKIE_DOMAIN } );
setCookie( { name => "pass", value => undef, path => "$BUCKY/", domain => $BUCKY_COOKIE_DOMAIN } );
# setCookie("name", "", "$BUCKY/", $BUCKY_COOKIE_DOMAIN );
# setCookie("pass", "", "$BUCKY/", $BUCKY_COOKIE_DOMAIN );
print "Location: http$s://$BUCKY_HOST$BUCKY/login";
if ($ENV{REQUEST_URI} !~ /login/ && $ENV{REQUEST_URI} !~ /logout/ && $ENV{REQUEST_URI} ne "$BUCKY/index" && $ENV{REQUEST_URI} ne "/bucky/")
{
$lender .= "redir=$ENV{REQUEST_URI}";
}
if (defined($lender) || $error > 0)
{
print "?";
print "error=$error&" if ($error > 0);
print $lender;
}
print "\n\n";
$dbh->disconnect() if (defined($dbh));
exit (0);
}
sub nice_redirect
{
my $uri = '';
if ($input->{redir} && $input->{redir} ne "/bucky/")
{
redirect($input->{redir});
}
else
{
redirect("$BUCKY/index");
}
}
sub redirect
{
my $uri = shift;
my $s = ($ENV{'HTTPS'} eq "on" || exists($input->{secure})) ? "s" : "";
# my $s = "";
print "Location: http$s://$BUCKY_HOST$uri\n\n";
$dbh->disconnect() if (defined($dbh));
exit (0);
}
sub error
{
my $reason = shift;
# my $f = get_random_flagged_image();
if (defined($USER) && $USER != -1)
{
header("
$reason
"; } footer(); $dbh->disconnect() if (defined($dbh)); exit(1); } sub corral { my ($things, $key) = @_; my @values; foreach my $k (sort keys %$things) { next unless ($k =~ /^$key/); push @values, $things->{$k}; } return sort @values; } # keys -- for storing arrays of ids sub split_keys { my ($string) = @_; my @out; foreach my $v (split(" ", $string)) { if (defined($v)) { push @out, $v; } } return @out; } sub check_key { my ($string, $key) = @_; if ($string =~ /\s$key\s/) { return 1; } else { return 0; } } sub add_key { my ($string, $key) = @_; $string .= " $key " unless (check_key($string, $key)); $string =~ s/( )+/ /g; return $string; } sub toggle_key { my ($string, $key) = @_; if (check_key($string, $key)) { $string =~ s/ $key / /; } else { $string .= " $key "; } $string =~ s/( )+/ /g; return $string; } sub delete_key { my ($string, $key) = @_; $string =~ s/ $key / /; $string =~ s/( )+/ /g; return $string; } 1;