use
version;
our
$VERSION
= qv(
sprintf
'0.6.%d'
,
q$Rev: 285 $
=~ /\d+/gmx );
has
'backup'
=>
is
=>
'rw'
,
isa
=>
'Str'
,
default
=> NUL;
has
'extn'
=>
is
=>
'rw'
,
isa
=>
'Str'
,
default
=> NUL;
has
'schema'
=>
is
=>
'ro'
,
isa
=>
'Object'
,
required
=> 1,
weak_ref
=> TRUE,
handles
=> {
_cache
=>
q(cache)
,
_debug
=>
q(debug)
,
_lock
=>
q(lock)
,
_log
=>
q(log)
,
_perms
=>
q(perms)
};
sub
delete
{
my
(
$self
,
$path
,
$element_obj
) =
@_
;
my
$element
=
$element_obj
->_resultset->source->name;
$self
->validate_params(
$path
,
$element
);
my
(
$data
) =
$self
->_read_file(
$path
, TRUE );
my
$name
=
$element_obj
->{name};
if
(
exists
$data
->{
$element
} and
exists
$data
->{
$element
}->{
$name
}) {
delete
$data
->{
$element
}->{
$name
};
scalar
keys
%{
$data
->{
$element
} } or
delete
$data
->{
$element
};
$self
->_write_file(
$path
,
$data
);
return
TRUE;
}
$self
->_lock->
reset
(
k
=>
$path
->pathname );
return
FALSE;
}
sub
dump
{
my
(
$self
,
$path
,
$data
) =
@_
;
$self
->validate_params(
$path
, TRUE );
$self
->_lock->set(
k
=>
$path
);
return
$self
->_write_file(
$path
,
$data
, TRUE );
}
sub
insert {
my
(
$self
,
$path
,
$element_obj
) =
@_
;
return
$self
->_update(
$path
,
$element_obj
, FALSE,
sub
{ TRUE } );
}
sub
load {
my
(
$self
,
@paths
) =
@_
;
$paths
[0] or
return
{};
scalar
@paths
== 1
and
return
(
$self
->_read_file(
$paths
[0], FALSE ))[0] || {};
my
(
$data
,
$meta
,
$newest
) =
$self
->_cache->get_by_paths( \
@paths
);
my
$cache_mtime
=
$self
->_meta_unpack(
$meta
);
my
$stale
= !
defined
$newest
|| !
defined
$cache_mtime
||
$newest
>
$cache_mtime
? TRUE : FALSE;
defined
$data
and not
$stale
and
return
$data
;
$data
= {};
$newest
= 0;
for
my
$path
(
@paths
) {
my
(
$red
,
$path_mtime
) =
$self
->_read_file(
$path
, FALSE );
$red
or
next
;
$path_mtime
>
$newest
and
$newest
=
$path_mtime
;
for
(
keys
%{
$red
}) {
$data
->{
$_
} =
exists
$data
->{
$_
}
? merge(
$data
->{
$_
},
$red
->{
$_
} )
:
$red
->{
$_
};
}
}
$self
->_cache->set_by_paths( \
@paths
,
$data
,
$self
->_meta_pack(
$newest
) );
return
$data
;
}
sub
select
{
my
(
$self
,
$path
,
$element
) =
@_
;
$self
->validate_params(
$path
,
$element
);
my
(
$data
) =
$self
->_read_file(
$path
, FALSE );
return
exists
$data
->{
$element
} ?
$data
->{
$element
} : {};
}
sub
txn_do {
my
(
$self
,
$path
,
$code_ref
) =
@_
;
$self
->validate_params(
$path
, TRUE );
my
$key
=
q(txn:)
.
$path
;
my
$wantarray
=
wantarray
;
my
$res
;
try
{
$self
->_lock->set(
k
=>
$key
);
if
(
$wantarray
) { @{
$res
} =
$code_ref
->() }
else
{
$res
=
$code_ref
->() }
$self
->_lock->
reset
(
k
=>
$key
);
}
catch
{
$self
->_lock->
reset
(
k
=>
$key
);
$self
->throw(
$_
) };
return
$wantarray
? @{
$res
} :
$res
;
}
sub
update {
my
(
$self
,
$path
,
$element_obj
,
$overwrite
,
$condition
) =
@_
;
defined
$overwrite
or
$overwrite
= TRUE;
$condition
||=
sub
{ TRUE };
return
$self
->_update(
$path
,
$element_obj
,
$overwrite
,
$condition
);
}
sub
validate_params {
my
(
$self
,
$path
,
$element
) =
@_
;
$path
or
$self
->throw(
'No file path specified'
);
blessed
$path
or
$self
->throw(
error
=>
'Path [_1] is not blessed'
,
args
=> [
$path
] );
$element
or
$self
->throw(
error
=>
'Path [_1] no element specified'
,
args
=> [
$path
] );
return
;
}
sub
_meta_pack {
my
(
$self
,
$mtime
) =
@_
;
return
{
mtime
=>
$mtime
};
}
sub
_meta_unpack {
my
(
$self
,
$attrs
) =
@_
;
return
$attrs
?
$attrs
->{mtime} :
undef
;
}
sub
_read_file {
my
(
$self
,
$path
,
$for_update
) =
@_
;
$self
->_lock->set(
k
=>
$path
);
my
(
$data
,
$meta
) =
$self
->_cache->get(
$path
);
my
$cache_mtime
=
$self
->_meta_unpack(
$meta
);
my
$path_mtime
=
$path
->
stat
->{mtime};
if
(not
defined
$data
or not
defined
$cache_mtime
or
$path_mtime
>
$cache_mtime
) {
try
{
$data
= inner(
$path
->
lock
);
$path
->
close
}
catch
{
$self
->_lock->
reset
(
k
=>
$path
);
$self
->throw(
$_
) };
$self
->_cache->set(
$path
,
$data
,
$self
->_meta_pack(
$path_mtime
) );
$self
->_debug and
$self
->_log->debug(
"Read file $path"
);
}
else
{
$self
->_debug and
$self
->_log->debug(
"Read cache $path"
);
}
$for_update
or
$self
->_lock->
reset
(
k
=>
$path
);
return
(
$data
,
$path_mtime
);
}
sub
_update {
my
(
$self
,
$path
,
$element_obj
,
$overwrite
,
$condition
) =
@_
;
my
$element
=
$element_obj
->_resultset->source->name;
$self
->validate_params(
$path
,
$element
);
my
(
$data
) =
$self
->_read_file(
$path
, TRUE );
my
$name
=
$element_obj
->{name};
if
(not
$overwrite
and
exists
$data
->{
$element
}->{
$name
}) {
$self
->_lock->
reset
(
k
=>
$path
);
$self
->throw(
error
=>
'File [_1] element [_2] already exists'
,
args
=> [
$path
,
$name
] );
}
my
$updated
= File::DataClass::HashMerge->merge
(
$element_obj
, \
$data
->{
$element
}->{
$name
},
$condition
);
if
(
$updated
) {
$self
->_write_file(
$path
,
$data
) }
else
{
$self
->_lock->
reset
(
k
=>
$path
) }
return
$updated
;
}
sub
_write_file {
my
(
$self
,
$path
,
$data
,
$create
) =
@_
;
$create
or
$path
->is_file
or
$self
->throw(
error
=>
'File [_1] not found'
,
args
=> [
$path
] );
$path
->is_file or
$path
->perms(
$self
->_perms );
if
(
$self
->backup and
$path
->is_file and not
$path
->empty) {
copy(
$path
.NUL,
$path
.
$self
->backup ) or
$self
->throw(
$ERRNO
);
}
try
{
$data
= inner(
$path
->atomic->
lock
,
$data
) }
catch
{
$path
->
delete
;
$self
->_lock->
reset
(
k
=>
$path
);
$self
->throw(
$_
) };
$path
->
close
;
$self
->_cache->remove(
$path
);
$self
->_lock->
reset
(
k
=>
$path
);
return
$data
;
}
__PACKAGE__->meta->make_immutable;
no
Moose;
1;