use
SPOPS::Tie
qw( IDX_DATA IDX_CHANGE IDX_INTERNAL IDX_TEMP
IDX_CHECK_FIELDS $PREFIX_TEMP $PREFIX_INTERNAL )
;
$SPOPS::Tie::StrictField::VERSION
=
sprintf
(
"%d.%02d"
,
q$Revision: 3.4 $
=~ /(\d+)\.(\d+)/);
my
$log
= get_logger();
my
%FIELDS
= ();
sub
_field_check {
my
(
$class
,
$base_class
,
$p
) =
@_
;
if
(
$base_class
and
ref
$p
->{field} eq
'ARRAY'
) {
unless
(
ref
$FIELDS
{
$base_class
} eq
'HASH'
) {
foreach
my
$key
( @{
$p
->{field} } ) {
$FIELDS
{
$base_class
}->{
lc
$key
} = 1;
}
}
return
1;
}
return
0;
}
sub
_can_fetch {
my
(
$self
,
$key
) =
@_
;
$self
->_storable_field_check
unless
(
$FIELDS
{
$self
->{class} } );
return
1
unless
(
$self
->{ IDX_CHECK_FIELDS() } );
return
1
if
(
$FIELDS
{
$self
->{class} }->{
lc
$key
} );
my
(
$call_package
,
$call_line
) = (
caller
(1))[0,2];
$log
->error(
"[$call_package @ $call_line]: Field '$key' is "
,
"not valid, cannot retrieve value"
);
return
undef
;
}
sub
_can_store {
my
(
$self
,
$key
,
$value
) =
@_
;
$self
->_storable_field_check
unless
(
$FIELDS
{
$self
->{class} } );
return
1
unless
(
$self
->{ IDX_CHECK_FIELDS() } );
return
1
if
(
$FIELDS
{
$self
->{class} }->{
lc
$key
} );
my
(
$call_package
,
$call_line
) = (
caller
(1))[0,2];
$log
->error(
"[$call_package @ $call_line]: Field '$key' is "
,
"not valid, cannot set value"
);
return
undef
;
}
sub
_storable_field_check {
my
(
$self
) =
@_
;
my
$object_class
=
$self
->{class};
return
if
(
$FIELDS
{
$object_class
} );
my
$fields
=
$object_class
->field;
$FIELDS
{
$object_class
} = { %{
$fields
} };
}
sub
EXISTS {
my
(
$self
,
$key
) =
@_
;
return
$self
->SUPER::EXISTS(
$key
)
unless
(
$self
->{ IDX_CHECK_FIELDS() } );
$log
->is_debug &&
$log
->debug(
" tie: Checking for existence of ($key)\n"
);
if
(
$FIELDS
{
$self
->{class} }->{
lc
$key
} ) {
return
exists
$self
->{ IDX_DATA() }->{
lc
$key
};
}
else
{
my
(
$call_package
,
$call_line
) = (
caller
(1))[0,2];
$log
->error(
"[$call_package @ $call_line]: Field '$key' is "
,
"not valid, cannot check existence"
);
return
undef
;
}
}
sub
DELETE {
my
(
$self
,
$key
) =
@_
;
return
$self
->SUPER::DELETE(
$key
)
unless
(
$self
->{ IDX_CHECK_FIELDS() } );
$log
->is_debug &&
$log
->debug(
" tie: Clearing value for ($key)\n"
);
if
(
$FIELDS
{
$self
->{class} }->{
lc
$key
} ) {
$self
->{ IDX_DATA() }->{
lc
$key
} =
undef
;
$self
->{ IDX_CHANGE() }++;
}
else
{
my
(
$call_package
,
$call_line
) = (
caller
(1))[0,2];
$log
->error(
"[$call_package @ $call_line]: Field '$key' is "
,
"not valid, cannot remove data"
);
}
}
1;