Initial commit.
This commit is contained in:
259
lib/perl5/Selima/Session.pm
Normal file
259
lib/perl5/Selima/Session.pm
Normal file
@@ -0,0 +1,259 @@
|
||||
# Selima Website Content Management System
|
||||
# Session.pm: The custom session handler.
|
||||
|
||||
# Copyright (c) 2004-2018 imacat.
|
||||
#
|
||||
# Licensed under the Apache License, Version 2.0 (the "License");
|
||||
# you may not use this file except in compliance with the License.
|
||||
# You may obtain a copy of the License at
|
||||
#
|
||||
# http://www.apache.org/licenses/LICENSE-2.0
|
||||
#
|
||||
# Unless required by applicable law or agreed to in writing, software
|
||||
# distributed under the License is distributed on an "AS IS" BASIS,
|
||||
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
# See the License for the specific language governing permissions and
|
||||
# limitations under the License.
|
||||
|
||||
# Author: imacat <imacat@mail.imacat.idv.tw>
|
||||
# First written: 2004-10-03
|
||||
|
||||
package Selima::Session;
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
BEGIN {
|
||||
sub sorter($);
|
||||
}
|
||||
|
||||
use CGI::Cookie qw();
|
||||
use Data::Dumper qw();
|
||||
use Digest::MD5 qw(md5_hex);
|
||||
use Fcntl qw(:flock :seek);
|
||||
use File::Spec::Functions qw(catfile tmpdir);
|
||||
use IO::File; # To use IO::Handle->flush
|
||||
|
||||
BEGIN {
|
||||
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
|
||||
require Apache2::Connection;
|
||||
}
|
||||
}
|
||||
|
||||
use Selima::DataVars qw(:env :input :output :proctime);
|
||||
use Selima::FormFunc;
|
||||
use Selima::HTTP;
|
||||
use Selima::Logging;
|
||||
|
||||
use vars qw($DIR $NAME $META_SESSION);
|
||||
use constant DEFAULT_DIR => "/dev/shm/cgi";
|
||||
$DIR = DEFAULT_DIR;
|
||||
if (!-e $DIR) {
|
||||
mkdir $DIR or http_500 "$DIR: $!";
|
||||
chmod 0700, $DIR or http_500 "$DIR: $!";
|
||||
} elsif (!(-d $DIR && -w $DIR)) {
|
||||
$DIR = $ENV{"HOME"} . "/tmp";
|
||||
$DIR = tmpdir if !(-d $DIR && -w $DIR);
|
||||
}
|
||||
$NAME = "SID";
|
||||
|
||||
# This is much simpler than CGI::Session and Apache::Session
|
||||
# And the most important, it is working, but they are not. :p
|
||||
# CGI::Session use several storage engines. Session data
|
||||
# are not locked throughout the session, but only on
|
||||
# initialization, flush and close, in order to meet different
|
||||
# capability on different storage engine.
|
||||
# Apache::Session creates a seperate session lock file in order
|
||||
# to meet different capability of different storage engine.
|
||||
# This is doomed to fail. :p
|
||||
# I'm not using different storage engine. That's not useful to
|
||||
# me at all. Besides, using Data::Dumper make things very
|
||||
# easy, easier than working around the problems of them.
|
||||
# It is easier to work on myself.
|
||||
# I am not using Apache mod_perl memory to store the session data
|
||||
# anymore. Using share memory file system /dev/shm to store
|
||||
# the session data if needed, to get rid of disk I/O overhead.
|
||||
# Having multiple copies of session data in memory, in Apache
|
||||
# and /dev/shm, is non-sense. It is a nightmare to decide the
|
||||
# one to use and synchronize the other, too.
|
||||
|
||||
# import: Set the session directory
|
||||
sub import : method { $DIR = $_[1] if defined $_[1]; };
|
||||
|
||||
# init: Initialize the session
|
||||
sub init : method {
|
||||
local ($_, %_);
|
||||
my ($class, $DH, $id, $is_old, $file, $remote);
|
||||
my ($newcookie, $origumask, $FH, $meta);
|
||||
$class = $_[0];
|
||||
|
||||
# Do not initialize twice
|
||||
return $$META_SESSION{"data"} if defined $META_SESSION;
|
||||
|
||||
# Expire old sessions from disk
|
||||
if ($DIR eq DEFAULT_DIR) {
|
||||
opendir $DH, $DIR or http_500 "$DIR: $!";
|
||||
while (defined($_ = readdir $DH)) {
|
||||
next if /^\./;
|
||||
$file = catfile($DIR, $_);
|
||||
next unless -f $file;
|
||||
next if $T_START - (stat $file)[8] < 9000;
|
||||
unlink $file;
|
||||
}
|
||||
closedir $DH or http_500 "$DIR: $!";
|
||||
}
|
||||
|
||||
# Get the remote IP
|
||||
$remote = $IS_MODPERL? ($IS_MP2?
|
||||
Apache2::RequestUtil->request->connection->remote_ip:
|
||||
Apache->request->connection->remote_ip):
|
||||
$ENV{"REMOTE_ADDR"};
|
||||
|
||||
# Obtain the session ID
|
||||
$is_old = 0;
|
||||
$_ = get_or_post;
|
||||
$id = defined $_->param($NAME)? $_->param($NAME):
|
||||
exists $COOKIES{$NAME}? $COOKIES{$NAME}->value: undef;
|
||||
if (defined $id) {
|
||||
$file = catfile($DIR, "sess_" . $id);
|
||||
# Get the session from the disk file, mod_perl or not.
|
||||
# Store on share memory file system /dev/shm to get rid
|
||||
# of disk I/O instead.
|
||||
if (-e $file) {
|
||||
open $FH, "+<$file" or http_500 "$file: $!";
|
||||
flock $FH, LOCK_EX or http_500 "$file: $!";
|
||||
read $FH, $_, (stat $file)[7] or http_500 "$file: $!";
|
||||
$META_SESSION = eval $_;
|
||||
# Not from the same host -- reject it
|
||||
if ($$META_SESSION{"remote"} ne $remote) {
|
||||
flock $FH, LOCK_UN or http_500 "$file: $!";
|
||||
$FH->close or http_500 "$file: $!";
|
||||
undef $FH;
|
||||
undef $META_SESSION;
|
||||
undef $id;
|
||||
} else {
|
||||
$$META_SESSION{"mtime"} = (stat $file)[9];
|
||||
$$META_SESSION{"atime"} = time;
|
||||
$$META_SESSION{"fh"} = $FH;
|
||||
${$$META_SESSION{"data"}}{".meta"} = $META_SESSION;
|
||||
$$META_SESSION{"dump"} = $$META_SESSION{"data"}->dump;
|
||||
$is_old = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Create a new session
|
||||
if (!$is_old) {
|
||||
# Generate a new session ID
|
||||
if (!defined $id) {
|
||||
do {
|
||||
$_ = "";
|
||||
$_ .= chr int rand 256 while length $_ < 32;
|
||||
$id = md5_hex($_);
|
||||
$file = catfile($DIR, "sess_" . $id);
|
||||
} until !-e $file;
|
||||
}
|
||||
$META_SESSION = {
|
||||
"mtime" => time,
|
||||
"atime" => time,
|
||||
"id" => $id,
|
||||
"name" => $NAME,
|
||||
"remote" => $remote,
|
||||
"data" => bless({}, $class),
|
||||
"file" => $file,
|
||||
};
|
||||
# Self-referring, so that we can find ourself later.
|
||||
${$$META_SESSION{"data"}}{".meta"} = $META_SESSION;
|
||||
# Create the session file
|
||||
$origumask = umask 0077;
|
||||
open $FH, "+>$file" or http_500 "$file: $!";
|
||||
flock $FH, LOCK_EX or http_500 "$file: $!";
|
||||
umask $origumask;
|
||||
$$META_SESSION{"fh"} = $FH;
|
||||
# Dump the session
|
||||
$_ = $$META_SESSION{"data"}->dump;
|
||||
$$META_SESSION{"dump"} = $_;
|
||||
print $FH $_ or http_500 "$file: $!";
|
||||
$FH->flush or http_500 "$file: $!";
|
||||
}
|
||||
|
||||
# Set the cookie
|
||||
if (!exists $COOKIES{$NAME} || $COOKIES{$NAME}->value ne $id) {
|
||||
$newcookie = new CGI::Cookie(-name=>$NAME, -value=>$id);
|
||||
$COOKIES{$NAME} = $newcookie;
|
||||
$NEWCOOKIES{$NAME} = $newcookie;
|
||||
}
|
||||
|
||||
return $$META_SESSION{"data"};
|
||||
}
|
||||
|
||||
# sorter: Dump the session
|
||||
sub sorter($) {
|
||||
local ($_, %_);
|
||||
%_ = map { $_ => 1 } keys %{$_[0]};
|
||||
delete $_{"mtime"};
|
||||
delete $_{"atime"};
|
||||
delete $_{"fh"};
|
||||
delete $_{"dump"};
|
||||
return [sort keys %_];
|
||||
}
|
||||
|
||||
# dump: Dump the session
|
||||
sub dump : method {
|
||||
local ($_, %_);
|
||||
my ($self, $meta, $dumper);
|
||||
$self = $_[0];
|
||||
$meta = $$self{".meta"};
|
||||
# Clone the meta-session
|
||||
$dumper = new Data::Dumper([$meta], [qw($_)]);
|
||||
$dumper->Indent(1);
|
||||
$dumper->Sortkeys(\&sorter);
|
||||
return $dumper->Dump;
|
||||
}
|
||||
|
||||
# flush: Flush the session data to the hard disk
|
||||
sub flush : method {
|
||||
local ($_, %_);
|
||||
my ($self, $meta, $FH);
|
||||
$self = $_[0];
|
||||
$meta = $$self{".meta"};
|
||||
# Return if session content not updated
|
||||
return if ($_ = $self->dump) eq $$meta{"dump"};
|
||||
$$meta{"dump"} = $_;
|
||||
# Update the mtime
|
||||
$$meta{"mtime"} = time;
|
||||
# Output and flush the data
|
||||
$FH = $$meta{"fh"};
|
||||
seek $FH, 0, SEEK_SET or http_500 $$meta{"file"} . ": $!";
|
||||
truncate $FH, 0 or http_500 $$meta{"file"} . ": $!";
|
||||
print $FH $$meta{"dump"} or http_500 $$meta{"file"} . ": $!";
|
||||
$FH->flush or http_500 $$meta{"file"} . ": $!";
|
||||
return;
|
||||
}
|
||||
|
||||
# close: Close the session
|
||||
sub close : method {
|
||||
local ($_, %_);
|
||||
my ($self, $meta, $FH);
|
||||
# Only close for once
|
||||
return unless defined $META_SESSION;
|
||||
$self = $_[0];
|
||||
$meta = $$self{".meta"};
|
||||
# Flush the session data
|
||||
$self->flush;
|
||||
# Close the data file
|
||||
$FH = $$meta{"fh"};
|
||||
flock $FH, LOCK_UN or http_500 $$meta{"file"} . ": $!";
|
||||
$FH->close or http_500 $$meta{"file"} . ": $!";
|
||||
# Undefine the session variables
|
||||
# This is not DESTROY. $META_SESSION will not be cleaned automatically.
|
||||
undef $META_SESSION;
|
||||
return;
|
||||
}
|
||||
|
||||
# DESTROY: Flush and close the session before everything ends
|
||||
sub DESTROY : method {
|
||||
$_[0]->close;
|
||||
$_[0]->SUPER::DESTROY if $_[0]->can("SUPER::DESTROY");
|
||||
}
|
||||
|
||||
return 1;
|
||||
Reference in New Issue
Block a user