$Util::Medley::Cache::VERSION
=
'0.055'
;
has
rootDir
=> (
is
=>
'ro'
,
isa
=>
'Str'
,
lazy
=> 1,
builder
=>
'_buildRootDir'
);
has
enabled
=> (
is
=>
'rw'
,
isa
=>
'Bool'
,
lazy
=> 1,
builder
=>
'_buildEnabled'
,
);
has
expireSecs
=> (
is
=>
'rw'
,
isa
=>
'Int'
,
default
=> 0,
);
has
ns
=> (
is
=>
'rw'
,
isa
=>
'Str'
,
);
has
l1Enabled
=> (
is
=>
'rw'
,
isa
=>
'Bool'
,
lazy
=> 1,
builder
=>
'_buildL1Enabled'
,
);
has
l2Enabled
=> (
is
=>
'rw'
,
isa
=>
'Bool'
,
lazy
=> 1,
builder
=>
'_buildL2Enabled'
,
);
has
_chiObjects
=> (
is
=>
'rw'
,
isa
=>
'HashRef'
,
default
=>
sub
{ {} }
);
has
_l1Cache
=> (
is
=>
'rw'
,
isa
=>
'HashRef'
,
default
=>
sub
{ {} }
);
multi method clear (Str :
$ns
) {
$self
->_l1Clear(
@_
)
if
$self
->l1Enabled;
$self
->_l2Clear(
@_
)
if
$self
->l2Enabled;
return
1;
}
multi method clear (Str
$ns
?) {
my
%a
;
$a
{ns} =
$ns
if
$ns
;
return
$self
->clear(
%a
);
}
multi method
delete
(Str :
$key
!,
Str :
$ns
) {
$self
->_l1Delete(
@_
)
if
$self
->l1Enabled;
$self
->_l2Delete(
@_
)
if
$self
->l1Enabled;
return
1;
}
multi method
delete
(Str
$key
,
Str
$ns
?) {
my
%a
;
$a
{key} =
$key
;
$a
{ns} =
$ns
if
$ns
;
return
$self
->
delete
(
%a
);
}
multi method destroy (Str :
$ns
) {
$self
->_l1Destroy(
@_
)
if
$self
->l1Enabled;
$self
->_l2Destroy(
@_
)
if
$self
->l1Enabled;
return
1;
}
multi method destroy (Str
$ns
?) {
my
%a
;
$a
{ns} =
$ns
if
$ns
;
return
$self
->destroy(
%a
);
}
multi method get (Str :
$key
!,
Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
)
if
!
$ns
;
if
(
$self
->l1Enabled ) {
my
$data
=
$self
->_l1Get(
@_
);
if
(
$data
) {
$self
->Logger->verbose(
"L1 cache hit - get ('$ns', '$key')"
);
return
$data
;
}
}
if
(
$self
->l2Enabled ) {
my
$data
=
$self
->_l2Get(
@_
);
if
(
$data
) {
$self
->Logger->verbose(
"L2 cache hit - get ('$ns', '$key')"
);
$self
->_l1Set(
@_
,
data
=>
$data
);
return
$data
;
}
}
}
multi method get (Str
$key
, Str
$ns
?) {
my
%a
;
$a
{key} =
$key
;
$a
{ns} =
$ns
if
$ns
;
return
$self
->get(
%a
);
}
multi method getKeys (Str :
$ns
) {
if
(
$self
->l2Enabled ) {
return
$self
->_l2GetKeys(
@_
);
}
if
(
$self
->l1Enabled ) {
return
$self
->_l1GetKeys(
@_
);
}
}
multi method getKeys (Str
$ns
?) {
my
%a
;
$a
{ns} =
$ns
if
$ns
;
return
$self
->getKeys(
ns
=>
$ns
);
}
multi method getNamespaceDir (Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
);
return
sprintf
"%s/%s"
,
$self
->rootDir,
$ns
;
}
multi method getNamespaceDir (Str
$ns
?) {
my
%a
;
$a
{ns} =
$ns
if
$ns
;
return
$self
->getNamespaceDir(
%a
);
}
multi method set (Str :
$key
!,
Any :
$data
!,
Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
)
if
!
$ns
;
$self
->Logger->verbose(
"cache set ('$ns', '$key')"
);
$self
->_l1Set(
@_
)
if
$self
->l1Enabled;
$self
->_l2Set(
@_
)
if
$self
->l2Enabled;
return
1;
}
multi method set (Str
$key
,
Any
$data
,
Str
$ns
?) {
my
%a
;
$a
{key} =
$key
;
$a
{data} =
$data
;
$a
{ns} =
$ns
if
$ns
;
return
$self
->set(
%a
);
}
method _getChiObject (Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$href
=
$self
->_chiObjects;
if
(
exists
$href
->{
$ns
} ) {
return
$href
->{
$ns
};
}
my
%params
= (
driver
=>
'File'
,
root_dir
=>
$self
->rootDir,
namespace
=>
$ns
,
);
my
$chi
= CHI->new(
%params
);
$href
->{
$ns
} =
$chi
;
$self
->_chiObjects(
$href
);
return
$chi
;
}
method _buildL1Enabled {
if
(
$self
->enabled ) {
if
( !
$ENV
{MEDLEY_CACHE_L1_DISABLED} ) {
return
1;
}
}
return
0;
}
method _buildL2Enabled {
if
(
$self
->enabled ) {
if
( !
$ENV
{MEDLEY_CACHE_L2_DISABLED} ) {
return
1;
}
}
return
0;
}
method _buildRootDir {
if
(
defined
$ENV
{HOME} ) {
return
"$ENV{HOME}/.chi"
;
}
confess
"unable to determine HOME env var"
;
}
method _buildEnabled {
if
(
$ENV
{MEDLEY_CACHE_DISABLED} ) {
return
0;
}
return
1;
}
method _l1Get (Str :
$ns
,
Str :
$key
!) {
$ns
=
$self
->_getNamespace(
$ns
);
$self
->_l1Expire(
@_
);
my
$l1
=
$self
->_l1Cache;
if
(
$l1
->{
$ns
}->{
$key
}->{data} ) {
return
$l1
->{
$ns
}->{
$key
}->{data};
}
return
;
}
method _l1Expire (Str :
$ns
,
Str :
$key
!) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$l1
=
$self
->_l1Cache;
if
(
$l1
->{
$ns
}->{
$key
} ) {
my
$href
=
$l1
->{
$ns
}->{
$key
};
if
(
$href
->{expire_epoch} ) {
if
(
time
() >
$href
->{expire_epoch} ) {
$self
->_l1Delete(
@_
);
}
}
else
{
}
}
return
;
}
method _l1Delete (Str :
$ns
,
Str :
$key
!) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$l1
=
$self
->_l1Cache;
if
(
$l1
->{
$ns
}->{
$key
} ) {
delete
$l1
->{
$ns
}->{
$key
};
}
return
;
}
method _l1Destroy (Str :
$ns
) {
$self
->_l1Clear(
@_
);
}
method _l2Destroy (Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$href
=
$self
->_chiObjects;
if
(
$href
->{
$ns
}) {
delete
$href
->{
$ns
};
}
remove_tree(
$self
->getNamespaceDir(
ns
=>
$ns
));
}
method _l1Clear (Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$l1
=
$self
->_l1Cache;
$l1
->{
$ns
} = {};
}
method _l2Clear (Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$chi
=
$self
->_getChiObject(
ns
=>
$ns
);
$chi
->clear;
}
method _l1Set (Str :
$ns
,
Str :
$key
!,
Any :
$data
!) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$node
= {
data
=>
$data
,
expire_epoch
=> 0,
};
if
(
$self
->expireSecs ) {
$node
->{expire_epoch} =
time
+
int
(
$self
->expireSecs );
}
my
$l1
=
$self
->_l1Cache;
$l1
->{
$ns
}->{
$key
} =
$node
;
return
;
}
method _l1GetKeys (Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$l1
=
$self
->_l1Cache;
if
(
$l1
and
$l1
->{
$ns
} ) {
return
keys
%{
$l1
->{
$ns
} };
}
}
method _getExpireSecsForChi {
if
(
$self
->expireSecs ) {
return
$self
->expireSecs;
}
return
'never'
;
}
method _l2Set (Str :
$ns
,
Str :
$key
!,
Any :
$data
!) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$chi
=
$self
->_getChiObject(
ns
=>
$ns
);
return
$chi
->set(
$key
,
$data
,
$self
->_getExpireSecsForChi );
}
method _l2Delete (Str :
$ns
,
Str :
$key
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$chi
=
$self
->_getChiObject(
ns
=>
$ns
);
$chi
->expire(
$key
);
return
;
}
method _l2Get (Str :
$ns
,
Str :
$key
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
$chi
=
$self
->_getChiObject(
ns
=>
$ns
);
return
$chi
->get(
$key
);
}
method _l2GetKeys (Str :
$ns
) {
$ns
=
$self
->_getNamespace(
$ns
);
my
@keys
;
my
$chi
=
$self
->_getChiObject(
ns
=>
$ns
);
if
(
$chi
) {
@keys
=
$chi
->get_keys;
}
return
@keys
;
}
method _getNamespace (Str|Undef
$ns
) {
if
( !
$ns
) {
if
( !
$self
->ns ) {
confess
"must provide namespace"
;
}
return
$self
->ns;
}
return
$ns
;
}
1;