require
5.005_62;
our
@ISA
=
qw()
;
our
$VERSION
=
'1.03'
;
our
$global_expiration
= 24*60*60;
our
$global_dbh
=
undef
;
our
$global_dbTablename
=
"session"
;
our
$global_cookieName
=
"session"
;
our
$global_keylength
= 16;
our
$colname_key
=
"session_key"
;
our
$colname_time
=
"session_time"
;
our
$colname_data
=
"session_data"
;
sub
new
{
my
$pkg
=
shift
;
my
$dbh
=
shift
;
my
$self
=
bless
({
data
=> {},
expiration
=>
$global_expiration
,
dbTablename
=>
$global_dbTablename
,
cookieName
=>
$global_cookieName
,
dbh
=>
$dbh
||
$global_dbh
,
needsSave
=> 0,
},
$pkg
);
if
(!
$self
->{dbh})
{
&carp
(
"No database connection has been specified. Please use "
.
$pkg
.
"::setDBH()"
);
return
undef
;
}
if
(!
ref
(
$self
->{dbh}) ||
ref
(
$self
->{dbh}) !~ /^(DBI|DBD)\b/)
{
my
$type
=
ref
(
$self
->{dbh}) ?
ref
(
$self
->{dbh}) :
"scalar"
;
&carp
(
"The DBH object is not a valid DBI/DBD connection: $type"
);
return
undef
;
}
my
%cookies
= CGI::Cookie->fetch();
if
(
exists
$cookies
{
$self
->{cookieName}})
{
$self
->{id} =
$cookies
{
$self
->{cookieName}}->value;
if
(!
$self
->loadSessionData())
{
$self
->_newSession();
}
}
else
{
$self
->_newSession();
}
return
$self
;
}
sub
DESTROY
{
my
$self
=
shift
;
if
(
$self
->{needsSave})
{
$self
->saveSessionData();
}
return
$self
;
}
sub
getID
{
my
$self
=
shift
;
return
$self
->{id};
}
sub
getCookie
{
my
$self
=
shift
;
my
$id
=
$self
->getID();
my
$cookie
= CGI::Cookie->new(
-name
=>
$self
->{cookieName},
-value
=>
$id
,
-path
=>
"/"
,
@_
);
return
$cookie
;
}
sub
printCookie
{
my
$self
=
shift
;
my
$cookie
=
$self
->getCookie(
@_
);
print
"Set-Cookie: $cookie\n"
;
}
sub
getAll
{
my
$self
=
shift
;
if
(
wantarray
)
{
return
(%{
$self
->{data}});
}
else
{
return
(
scalar
keys
%{
$self
->{data}});
}
}
sub
get
{
my
$self
=
shift
;
my
$fieldName
=
shift
;
return
undef
if
(!
defined
$fieldName
);
return
$self
->{data}->{
$fieldName
};
}
sub
set
{
my
$self
=
shift
;
while
(
@_
> 0)
{
my
$fieldName
=
shift
;
my
$value
=
shift
;
return
undef
if
(!
defined
$fieldName
);
$self
->{data}->{
$fieldName
} =
$value
;
}
$self
->{needsSave} = 1;
return
$self
;
}
sub
delete
{
my
$self
=
shift
;
foreach
my
$fieldName
(
@_
)
{
delete
$self
->{data}->{
$fieldName
};
}
$self
->{needsSave} = 1;
return
$self
;
}
sub
clear
{
my
$self
=
shift
;
return
$self
->
delete
(
keys
%{
$self
->{data}});
}
sub
loadSessionData
{
my
$self
=
shift
;
my
$id
=
$self
->getID();
return
undef
if
(!
$id
);
my
$dbrow
=
$self
->_getSession(
$id
);
return
undef
if
(!
$dbrow
);
$self
->{data} =
$self
->_explode(
$dbrow
->{
$colname_data
});
if
(!
$self
->{data})
{
$self
->{data} = {};
return
undef
;
}
$self
->{needsSave} = 0;
return
$self
;
}
sub
saveSessionData
{
my
$self
=
shift
;
my
$id
=
$self
->getID();
return
undef
if
(!
$id
);
my
$data
=
$self
->_implode(
$self
->{data});
$data
=
""
if
(!
defined
$data
);
my
$dbh
=
$self
->{dbh};
my
$result
=
$dbh
->
do
(
"update $$self{dbTablename} set "
.
"$colname_data="
.
$dbh
->quote(
$data
) .
","
.
"$colname_time=now() "
.
"where $colname_key='$id'"
);
return
undef
if
((!
$result
) ||
$result
== 0);
return
$self
;
}
sub
isNewSession
{
my
$self
=
shift
;
return
$self
->{newsession};
}
sub
_newSession
{
my
$self
=
shift
;
$self
->{id} =
undef
;
my
$dbh
=
$self
->{dbh};
my
$tries
= 0;
while
(
$tries
++ < 20)
{
my
$id
=
$self
->_newID();
my
$sth
=
$dbh
->prepare(
"select count(*) from $$self{dbTablename} "
.
"where $colname_key=?"
);
$sth
->execute(
$id
);
my
(
$matches
) =
$sth
->fetchrow_array();
$sth
->finish();
if
(
$matches
== 0)
{
$dbh
->
do
(
"insert into $$self{dbTablename} set "
.
"$colname_key='$id',$colname_time=now()"
);
$self
->{id} =
$id
;
$self
->{newsession} = 1;
last
;
}
}
return
$self
;
}
sub
_getSession
{
my
$self
=
shift
;
my
$id
=
shift
;
return
undef
if
(!
$id
);
my
$dbh
=
$self
->{dbh};
my
$sth
=
$dbh
->prepare(
"select *"
.
(
defined
$self
->{expiration} ?
",date_add(now(), interval -$$self{expiration} second) as expires "
:
""
) .
"from $$self{dbTablename} "
.
"where $colname_key=?"
);
$sth
->execute(
$id
);
my
$row
=
$sth
->fetchrow_hashref();
$sth
->finish();
return
undef
if
(!
$row
);
if
(
defined
$self
->{expiration})
{
$row
->{
$colname_time
} =~ s/\D//g;
$row
->{expires} =~ s/\D//g;
if
(
$row
->{
$colname_time
} lt
$row
->{expires})
{
$dbh
->
do
(
"delete from $$self{dbTablename} "
.
"where $colname_key="
.
$dbh
->quote(
$self
->{cachekey}));
return
undef
;
}
}
return
$row
;
}
sub
setDBH
{
my
$pkg
=
shift
;
my
$val
=
shift
;
$global_dbh
=
$val
;
}
sub
setExpiration
{
my
$pkg
=
shift
;
my
$val
=
shift
;
$global_expiration
=
$val
;
}
sub
setTableName
{
my
$pkg
=
shift
;
my
$val
=
shift
;
$global_dbTablename
=
$val
;
}
sub
setCookieName
{
my
$pkg
=
shift
;
my
$val
=
shift
;
$global_cookieName
=
$val
;
}
sub
_implode
{
my
$self
=
shift
;
my
$H_data
=
shift
;
my
@escaped
= (
%$H_data
);
foreach
(
@escaped
)
{
$_
=
""
if
(!
defined
$_
);
$_
= CGI::escape(
$_
);
}
return
join
(
","
,
@escaped
);
}
sub
_explode
{
my
$self
=
shift
;
my
$implosion
=
shift
;
$implosion
=
""
if
(!
defined
$implosion
);
my
@fields
=
split
/,/,
$implosion
, -1;
if
(
@fields
%2 != 0)
{
&carp
(
"not an even number of fields in imploded data"
);
return
undef
;
}
foreach
(
@fields
)
{
$_
= CGI::unescape(
$_
);
}
return
{
@fields
};
}
sub
_newID
{
my
$self
=
shift
;
my
$md5
= Digest::MD5->new();
$md5
->add($$ ,
time
() ,
rand
(9999) );
return
substr
(
$md5
->hexdigest(), 0,
$global_keylength
);
}
sub
setup
{
my
$pkg
=
shift
;
my
$dbh
=
shift
||
$global_dbh
;
my
$tablename
=
shift
||
$global_dbTablename
;
$dbh
->
do
(
"create table if not exists $tablename ("
.
"$colname_key char($global_keylength) primary key not null,"
.
"$colname_time timestamp,"
.
"$colname_data mediumtext)"
);
}
sub
clean
{
my
$pkg
=
shift
;
my
$dbh
=
shift
||
$global_dbh
;
my
$tablename
=
shift
||
$global_dbTablename
;
my
$seconds
=
shift
||
$global_expiration
;
return
$dbh
->
do
(
"delete from $tablename "
.
"where $colname_time < "
.
"date_add(now(),interval -$seconds second)"
);
}
1;