no
strict
qw(refs)
;
use
vars
qw(%DB %CACHE $DefaultGroupIdLength)
;
use
Fcntl
qw(:flock O_RDWR O_CREAT)
;
$DefaultGroupIdLength
= 2;
%DB
= (
SDBM_File
=> [
'.pag'
,
'.dir'
],
DB_File
=> [
''
],
'MLDBM::Sync::SDBM_File'
=> [
'.pag'
,
'.dir'
],
GDBM_File
=> [
''
],
'Tie::TextDir'
=> [
''
],
);
sub
new {
my
(
$asp
,
$id
,
$group
) =
@_
;
if
(
$id
) {
$id
=~
tr
///;
}
else
{
$asp
->Error(
"no id: $id passed into new State"
);
return
;
}
if
(
$group
) {
$group
=~
tr
///;
}
else
{
$group
=
substr
(
$id
, 0,
$DefaultGroupIdLength
)
}
unless
(
$group
) {
$asp
->Error(
"no group defined for id $id"
);
return
;
}
my
$state_dir
=
$asp
->{state_dir};
my
$group_dir
=
$state_dir
.
'/'
.
$group
;
my
$lock_file
=
$group_dir
.
'/'
.
$id
.
'.lock'
;
my
$file
=
$group_dir
.
'/'
.
$id
;
my
(
$state_db
,
$state_serializer
);
if
(
$id
eq
'internal'
) {
$state_db
=
$Apache::ASP::DefaultStateDB
;
$state_serializer
=
$Apache::ASP::DefaultStateSerializer
;
}
elsif
(
$asp
->{Internal} && (
length
(
$id
) >
$DefaultGroupIdLength
)) {
my
$internal
=
$asp
->{Internal};
my
$idata
=
$internal
->{
$id
};
if
(!
$idata
->{state_db} || !
$idata
->{state_serializer}) {
$state_db
=
$idata
->{state_db} ||
$asp
->{state_db} ||
$Apache::ASP::DefaultStateDB
;
$state_serializer
=
$idata
->{state_serializer} ||
$asp
->{state_serializer} ||
$Apache::ASP::DefaultStateSerializer
;
if
(
length
(
$id
) >
$DefaultGroupIdLength
) {
my
$diff
= 0;
if
((
$idata
->{state_db} ||
$Apache::ASP::DefaultStateDB
) ne
$state_db
) {
$idata
->{state_db} =
$state_db
;
$diff
= 1;
}
if
((
$idata
->{state_serializer} ||
$Apache::ASP::DefaultStateSerializer
) ne
$state_serializer
) {
$idata
->{state_serializer} =
$state_serializer
;
$diff
= 1;
}
if
(
$diff
) {
$asp
->{dbg} &&
$asp
->Debug(
"setting internal data for state $id"
,
$idata
);
$internal
->{
$id
} =
$idata
;
}
}
}
else
{
$state_db
=
$idata
->{state_db};
$state_serializer
=
$idata
->{state_serializer};
}
}
else
{
(
$state_db
,
$state_serializer
) = (
$asp
->{state_db},
$asp
->{state_serializer});
}
my
$self
=
bless
{
asp
=>
$asp
,
dbm
=>
undef
,
'dir'
=>
$group_dir
,
id
=>
$id
,
file
=>
$file
,
group
=>
$group
,
group_dir
=>
$group_dir
,
reads
=> 0,
state_dir
=>
$state_dir
,
writes
=> 0,
};
if
(
$group
eq
$id
) {
return
$self
;
}
if
(
$asp
->config(
'StateAllWrite'
)) {
$asp
->{dbg} and
$asp
->{state_all_write} = 1;
$self
->{dir_perms} = 0777;
$self
->{file_perms} = 0666;
}
elsif
(
$asp
->config(
'StateGroupWrite'
)) {
$asp
->{dbg} and
$asp
->{state_group_write} = 1;
$self
->{dir_perms} = 0770;
$self
->{file_perms} = 0660;
}
else
{
$self
->{dir_perms} = 0750;
$self
->{file_perms} = 0640;
}
my
@create_dirs
;
unless
(-d
$state_dir
) {
push
(
@create_dirs
,
$state_dir
);
}
unless
(-d
$group_dir
) {
push
(
@create_dirs
,
$group_dir
);
}
if
(
@create_dirs
) {
$self
->UmaskClear;
for
my
$create_dir
(
@create_dirs
) {
$create_dir
=~ /^(.*)$/s;
$create_dir
= $1;
if
(
mkdir
(
$create_dir
,
$self
->{dir_perms})) {
$asp
->{dbg} &&
$asp
->Debug(
"creating state dir $create_dir"
);
}
else
{
my
$error
= $!;
-d
$create_dir
||
$self
->{asp}->Error(
"can't create group dir $create_dir: $error"
);
}
}
$self
->UmaskRestore;
}
{
local
$MLDBM::UseDB
=
$state_db
||
'SDBM_File'
;
local
$MLDBM::Serializer
=
$state_serializer
||
'Data::Dumper'
;
$self
->{dbm} =
undef
;
local
$SIG
{__WARN__} =
sub
{};
my
$error
;
$self
->{file} =~ /^(.*)$/;
$self
->{file} = $1;
local
$MLDBM::RemoveTaint
= 1;
$self
->{dbm} =
&MLDBM::Sync::TIEHASH
(
'MLDBM'
,
$self
->{file}, O_RDWR|O_CREAT,
$self
->{file_perms});
$asp
->{dbg} &&
$asp
->Debug(
"creating dbm for file $self->{file}, db $MLDBM::UseDB, serializer: $MLDBM::Serializer"
);
$error
= $! ||
'Undefined Error'
;
if
(!
$self
->{dbm}) {
$self
->{asp}->Error(
qq{
Cannot tie to file $self->{file}
,
$error
!!
Make sure you have the permissions on the directory set correctly, and that your
version of Data::Dumper is up to date. Also, make sure you have set StateDir to
to a good directory in the config file. StateDir defaults to Global/.state
});
}
}
$self
;
}
sub
Init {
shift
->{dbm}->CLEAR(); }
sub
Size {
shift
->{dbm}->SyncSize; }
sub
Delete {
shift
->{dbm}->CLEAR(); }
sub
WriteLock {
shift
->{dbm}->Lock; }
sub
ReadLock {
shift
->{dbm}->ReadLock; }
sub
UnLock {
shift
->{dbm}->UnLock; }
sub
DeleteGroupId {
my
$self
=
shift
;
my
$group_dir
=
$self
->{group_dir};
if
(-d
$group_dir
) {
$self
->{asp}{Internal}->LOCK;
if
(
rmdir
(
$group_dir
)) {
$self
->{asp}->Debug(
"deleting group dir $group_dir"
);
}
else
{
$self
->{asp}->Log(
"cannot delete group dir $group_dir: $!"
);
}
$self
->{asp}{Internal}->UNLOCK;
}
}
sub
GroupId {
shift
->{group}; }
sub
GroupMembers {
my
$self
=
shift
;
local
(
*DIR
);
my
(
%ids
,
@ids
);
unless
(
opendir
(DIR,
$self
->{group_dir})) {
$self
->{asp}->Log(
"opening group $self->{group_dir} failed: $!"
);
return
[];
}
for
(
readdir
(DIR)) {
next
if
/^\.\.?$/;
$_
=~ /^(.*?)(\.[^\.]+)?$/;
next
unless
$1;
$ids
{$1}++;
}
closedir
(DIR);
if
(
my
$internal
=
$self
->{asp}{Internal}) {
my
$cached_keys
= {};
unless
(
$cached_keys
=
$self
->{asp}{internal_cached_keys}) {
map
{
if
(/^([0-9a-f]{2})/) {
$cached_keys
->{$1}{
$_
}++
}
}
keys
%$internal
;
$self
->{asp}{internal_cached_keys} =
$cached_keys
;
}
if
(
my
$group_keys
=
$cached_keys
->{
$self
->{group}}) {
%ids
= (
%ids
,
%$group_keys
);
}
}
@ids
=
keys
%ids
;
\
@ids
;
}
sub
DefaultGroups {
my
$self
=
shift
;
my
(
@ids
);
local
*STATEDIR
;
opendir
(STATEDIR,
$self
->{state_dir})
||
$self
->{asp}->Error(
"can't open state dir $self->{state_dir}"
);
my
$time
=
time
;
for
(
readdir
(STATEDIR)) {
next
if
/^\./;
next
unless
(
length
(
$_
) eq
$DefaultGroupIdLength
);
push
(
@ids
,
$_
);
}
closedir
STATEDIR;
\
@ids
;
}
sub
UmaskClear {
my
$self
=
shift
;
return
if
$self
->{asp}{win32};
$self
->{umask_restore} =
umask
(0000);
}
sub
UmaskRestore {
my
$self
=
shift
;
return
if
$self
->{asp}{win32};
if
(
defined
$self
->{umask_restore}) {
umask
(
$self
->{umask_restore});
}
}
sub
DESTROY {
my
$self
=
shift
;
return
unless
%{
$self
};
return
if
$self
->{destroyed}++;
$self
->{dbm} &&
eval
{
$self
->{dbm}->DESTROY };
$self
->{dbm} =
undef
;
}
sub
AUTOLOAD {
my
$self
=
shift
;
my
$AUTOLOAD
=
$Apache::ASP::State::AUTOLOAD
;
$AUTOLOAD
=~ s/^(.*)::(.*?)$/$2/o;
my
$value
;
$value
=
$self
->{dbm}->
$AUTOLOAD
(
@_
);
$value
;
}
sub
TIEHASH {
my
$type
=
shift
;
if
((
ref
$_
[0]) =~ /State/) {
$_
[0];
}
else
{
bless
&new
(
@_
),
$type
;
}
}
sub
FETCH {
my
(
$self
,
$index
) =
@_
;
my
$value
;
if
(
$index
eq
'_FILE'
) {
$value
=
$self
->{file};
}
elsif
(
$index
eq
'_SELF'
) {
$value
=
$self
;
}
else
{
$value
=
$self
->{dbm}->FETCH(
$index
);
$self
->{reads}++;
}
$value
;
}
sub
STORE {
my
$self
=
shift
;
$self
->UmaskClear;
my
$rv
=
$self
->{dbm}->STORE(
@_
);
$self
->UmaskRestore;
$self
->{writes}++;
$rv
;
}
sub
LOCK {
my
$self
=
tied
(%{
$_
[0]});
$self
->{dbm}->Lock(); }
sub
UNLOCK {
my
$self
=
tied
(%{
$_
[0]});
$self
->{dbm}->UnLock(); }
1;