#!/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("

error: $reason
"); print qq(
); print qq(
); print qq(
); my $filename = lc($f->{filename}); print qq!
\n!; print "

sorry, there was an error:

$reason

"; print qq!go back | home\n!; print qq(

); print qq(
); } else { header("error: $reason"); print "there was an error:

$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;