use
SPOPS
qw( _w DEBUG )
;
$SPOPS::ClassFactory::DefaultBehavior::VERSION
=
sprintf
(
"%d.%02d"
,
q$Revision: 3.5 $
=~ /(\d+)\.(\d+)/);
my
@PARSE_INTO_HASH
=
qw( field no_insert no_update skip_undef multivalue )
;
my
@PARSE_INTO_ARRAY
=
qw( sql_defaults fetch_by ldap_object_class )
;
sub
conf_modify_config {
my
(
$class
) =
@_
;
DEBUG() && _w( 1,
"Trying to modify configuration for class [$class]"
);
my
$CONFIG
=
$class
->CONFIG;
if
(
ref
$CONFIG
->{field} eq
'ARRAY'
) {
$CONFIG
->{field_list} = [ @{
$CONFIG
->{field} } ];
}
elsif
(
$CONFIG
->{field} ) {
$CONFIG
->{field_list} = [
$CONFIG
->{field} ];
}
else
{
$CONFIG
->{field_list} = [];
}
HASHITEM:
foreach
my
$item
(
@PARSE_INTO_HASH
) {
unless
(
defined
$CONFIG
->{
$item
} ) {
$CONFIG
->{
$item
} = {};
next
HASHITEM;
}
if
(
ref
$CONFIG
->{
$item
} ne
'ARRAY'
) {
$CONFIG
->{
$item
} = [
$CONFIG
->{
$item
} ];
}
DEBUG() && _w( 1,
"Parsing key ($item) into a hash"
);
my
$count
= 1;
my
%new
= ();
foreach
my
$subitem
( @{
$CONFIG
->{
$item
} } ) {
$new
{
$subitem
} =
$count
;
$count
++;
}
$CONFIG
->{
$item
} = \
%new
;
}
foreach
my
$item
(
@PARSE_INTO_ARRAY
) {
unless
(
defined
$CONFIG
->{
$item
} ) {
$CONFIG
->{
$item
} = [];
}
if
(
ref
$CONFIG
->{
$item
} ne
'ARRAY'
) {
$CONFIG
->{
$item
} = [
$CONFIG
->{
$item
} ];
}
}
return
( OK,
undef
);
}
my
$ID_TEMPLATE
=
<<'IDTMPL';
# Get the ID of this object, and optionally set it as well.
sub %%CLASS%%::id {
my ( $self, $new_id ) = @_;
my $id_field = $self->id_field ||
SPOPS::Exception->throw(
"Cannot find ID for object since no ID ",
"field specified for class [",
"ref( $self ) . ']' " );
return $self->{ $id_field } unless ( $new_id );
return $self->{ $id_field } = $new_id;
}
IDTMPL
sub
conf_id_method {
my
(
$class
) =
@_
;
my
$id_method
=
$ID_TEMPLATE
;
$id_method
=~ s/%
%CLASS
%%/
$class
/g;
DEBUG() && _w( 5,
"ID method being created\n$id_method"
);
{
local
$SIG
{__WARN__} =
sub
{
return
undef
};
eval
$id_method
;
if
( $@ ) {
return
( ERROR,
"Cannot generate method 'id' in class "
.
"[$class]. Error: $@"
);
}
}
return
( DONE,
undef
);
}
sub
conf_read_code {
my
(
$class
) =
@_
;
my
$CONFIG
=
$class
->CONFIG;
my
$code_class
=
$CONFIG
->{code_class};
return
( OK,
undef
)
unless
(
$code_class
);
my
@files_used
= ();
$code_class
= [
$code_class
]
unless
(
ref
$code_class
eq
'ARRAY'
);
foreach
my
$read_code_class
( @{
$code_class
} ) {
DEBUG() && _w( 2,
"Trying to read code from [$read_code_class]"
,
"into [$class]"
);
my
$filename
=
$read_code_class
;
$filename
=~ s|::|/|g;
my
$final_filename
=
undef
;
PREFIX:
foreach
my
$prefix
(
@INC
) {
my
$full_filename
=
"$prefix/$filename.pm"
;
DEBUG() && _w( 3,
"Try file: [$full_filename]"
);
if
( -f
$full_filename
) {
$final_filename
=
$full_filename
;
last
PREFIX;
}
}
unless
(
$final_filename
and -f
$final_filename
) {
return
( ERROR,
"Class [$read_code_class] specified in "
.
"'code_class' configuration defintion "
.
"for class [$class] was not found in \@INC"
);
}
DEBUG() && _w( 2,
"File [$final_filename] will be used for "
,
"[$read_code_class]"
);
eval
{
open
( PKG,
$final_filename
) ||
die
$! };
if
( $@ ) {
return
( ERROR,
"Cannot read [$final_filename] specified in "
.
"'code_class' configuration definition for "
.
"class [$class]. Error: $@"
);
}
my
$code_pkg
=
undef
;
push
@files_used
,
$final_filename
;
CODEPKG:
while
( <PKG> ) {
if
( s/^\s
*package
$read_code_class
\s*;\s*$/
package
$class
;/ ) {
$code_pkg
.=
$_
;
DEBUG() && _w( 1,
"Package [$read_code_class] will be "
,
"read in as [$class]"
);
last
CODEPKG;
}
$code_pkg
.=
$_
;
}
{
local
$/ =
undef
;
$code_pkg
.= <PKG>;
}
close
( PKG );
DEBUG() && _w( 5,
"Going to eval code:\n\n$code_pkg"
);
{
local
$SIG
{__WARN__} =
sub
{
return
undef
};
eval
$code_pkg
;
if
( $@ ) {
return
( ERROR,
"Error running 'eval' on code read from "
.
"[$final_filename] as specified in "
.
"'code_class' configuration defintion for "
.
"class [$class]. Error: $@"
);
}
}
}
return
( OK,
undef
);
}
my
$GENERIC_HASA
=
<<'HASA';
sub %%CLASS%%::%%HASA_ALIAS%% {
my ( $self, $p ) = @_;
return undef unless ( $self->{%%HASA_ID_FIELD%%} );
return %%HASA_CLASS%%->fetch( $self->{%%HASA_ID_FIELD%%}, $p );
}
HASA
sub
conf_relate_hasa {
my
(
$class
) =
@_
;
my
$CONFIG
=
$class
->CONFIG;
$CONFIG
->{has_a} ||= {};
foreach
my
$hasa_class
(
keys
%{
$CONFIG
->{has_a} } ) {
DEBUG() && _w( 1,
"Try to alias [$class] hasa [$hasa_class]"
);
my
$hasa_config
=
$hasa_class
->CONFIG;
my
$hasa_id_field
=
$hasa_config
->{id_field};
my
$hasa_sub
=
$GENERIC_HASA
;
$hasa_sub
=~ s/%
%CLASS
%%/
$class
/g;
$hasa_sub
=~ s/%
%HASA_CLASS
%%/
$hasa_class
/g;
my
$id_fields
= (
ref
$CONFIG
->{has_a}{
$hasa_class
} eq
'ARRAY'
)
?
$CONFIG
->{has_a}{
$hasa_class
}
: [
$CONFIG
->{has_a}{
$hasa_class
} ];
my
$num_id_fields
=
scalar
@{
$id_fields
};
foreach
my
$usea_id_info
( @{
$id_fields
} ) {
my
(
$hasa_alias
,
$usea_id_field
) =
''
;
if
(
ref
$usea_id_info
eq
'HASH'
) {
$usea_id_field
= (
keys
%{
$usea_id_info
} )[0];
$hasa_alias
=
$usea_id_info
->{
$usea_id_field
};
}
else
{
$usea_id_field
=
$usea_id_info
;
if
(
$usea_id_field
eq
$hasa_id_field
) {
$hasa_alias
=
$hasa_config
->{main_alias}
}
else
{
$hasa_alias
=
join
(
'_'
,
$usea_id_field
,
$hasa_config
->{main_alias} );
}
}
my
$this_hasa_sub
=
$hasa_sub
;
$this_hasa_sub
=~ s/%
%HASA_ALIAS
%%/
$hasa_alias
/g;
$this_hasa_sub
=~ s/%
%HASA_ID_FIELD
%%/
$usea_id_field
/g;
DEBUG() && _w( 2,
"Aliasing [$hasa_class] with field [$usea_id_field] "
,
"using alias [$hasa_alias] within [$class]"
);
DEBUG() && _w( 5,
"Now going to eval the routine:\n$this_hasa_sub"
);
{
local
$SIG
{__WARN__} =
sub
{
return
undef
};
eval
$this_hasa_sub
;
if
( $@ ) {
return
( ERROR,
"Error reading 'has_a' code for alias "
.
"[$hasa_alias] mapped to class "
.
"[$hasa_class] into [$class]. Error: $@\n"
);
}
}
}
}
return
( OK,
undef
);
}
my
$GENERIC_FETCH_BY
=
<<'FETCHBY';
sub %%CLASS%%::fetch_by_%%FETCH_BY_FIELD%% {
my ( $item, $fb_field_value, $p ) = @_;
$p ||= {};
my $obj_list = $item->fetch_group({ where => "%%FETCH_BY_FIELD%% = ?",
value => [ $fb_field_value ],
%{ $p } });
if ( $p->{return_single} ) {
return $obj_list->[0];
}
return $obj_list;
}
FETCHBY
sub
conf_relate_fetchby {
my
(
$class
) =
@_
;
my
$CONFIG
=
$class
->CONFIG;
$CONFIG
->{fetch_by} ||= [];
foreach
my
$fetch_by_field
( @{
$CONFIG
->{fetch_by} } ) {
my
$fetch_by_sub
=
$GENERIC_FETCH_BY
;
$fetch_by_sub
=~ s/%
%CLASS
%%/
$class
/g;
$fetch_by_sub
=~ s/%
%FETCH_BY_FIELD
%%/
$fetch_by_field
/g;
DEBUG() && _w( 2,
"Creating fetch_by for field ($fetch_by_field)"
);
DEBUG() && _w( 5,
"Now going to eval the routine:\n$fetch_by_sub"
);
{
local
$SIG
{__WARN__} =
sub
{
return
undef
};
eval
$fetch_by_sub
;
if
( $@ ) {
return
( ERROR,
"Cannot eval 'fetch_by' code for field "
.
"[$fetch_by_field] into [$class]. Error: $@"
);
}
}
}
return
( OK,
undef
);
}
my
$GENERIC_RULESET_REFER
=
<<'RULESET';
$%%CLASS%%::RULESET = {};
sub %%CLASS%%::RULESET { return $%%CLASS%%::RULESET }
RULESET
sub
conf_add_rules {
my
(
$class
) =
@_
;
my
$CONFIG
=
$class
->CONFIG;
DEBUG() && _w( 1,
"Adding rules to ($class)"
);
my
$ruleset_info
=
$GENERIC_RULESET_REFER
;
$ruleset_info
=~ s/%
%CLASS
%%/
$class
/g;
{
no
warnings
'redefine'
;
eval
$ruleset_info
;
if
( $@ ) {
return
( ERROR,
"Could not eval ruleset info into [$class]. Error: $@"
);
}
}
my
$rule_classes
=
$CONFIG
->{rules_from} || [];
my
$subs
= SPOPS::ClassFactory->find_parent_methods(
$class
,
$rule_classes
, RULESET_METHOD,
'ruleset_add'
);
foreach
my
$sub_info
( @{
$subs
} ) {
DEBUG() && _w( 2,
"Calling ruleset generation for [$class] "
,
"from [$sub_info->[0]]"
);
$sub_info
->[1]->(
$class
,
$class
->RULESET );
}
return
( OK,
undef
);
}
1;