{
$Storm::Policy::Object::VERSION
=
'0.240'
;
}
has
'_definitions'
=> (
is
=>
'ro'
,
isa
=> HashRef,
default
=>
sub
{ { } },
init_arg
=>
undef
,
traits
=> [
qw( Hash )
],
handles
=> {
add_definition
=>
'set'
,
get_definition
=>
'get'
,
has_definition
=>
'exists'
,
}
);
has
'_transformations'
=> (
is
=>
'ro'
,
isa
=>
'HashRef[HashRef]'
,
default
=>
sub
{ { } },
init_arg
=>
undef
,
traits
=> [
'Hash'
],
handles
=> {
add_transformation
=>
'set'
,
get_transformation
=>
'get'
,
transformations
=>
'elements'
,
has_transformation
=>
'exists'
,
}
);
sub
BUILD {
my
(
$self
) =
@_
;
$self
->add_definition( Any ,
'VARCHAR(64)'
);
$self
->add_definition( Num ,
'DECIMAL(32,16)'
);
$self
->add_definition( Int ,
'INTEGER'
);
$self
->add_definition( Bool,
'INTEGER'
);
$self
->add_definition( Object,
'VARCHAR(255)'
);
$self
->add_definition( StormArrayRef,
'TEXT'
);
$self
->add_transformation( StormArrayRef, {
inflate
=>
sub
{
my
(
$orm
) =
@_
;
my
$string
=
$_
;
$string
=~ s/\[|\]//g;
my
@objects
;
for
my
$moniker
(
split
/,/,
$string
) {
return
undef
if
!
$moniker
;
my
(
$class
,
$key
) =
split
/=/,
$moniker
;
my
$object
=
$orm
->lookup(
$class
,
$key
);
push
@objects
,
$object
;
}
return
\
@objects
;
},
deflate
=>
sub
{
my
(
$orm
) =
@_
;
my
@values
;
for
my
$object
(
@$_
) {
return
undef
if
!
$object
;
my
(
$class
) =
split
/=/,
ref
$object
;
push
@values
,
join
'='
,
$class
,
$object
->meta->primary_key->get_value(
$object
);
}
return
'['
.
join
(
','
,
@values
) .
']'
;
}
});
}
sub
inflate_value {
my
(
$self
,
$orm
,
$attr
,
$value
,
@args
) =
@_
;
return
$value
if
!
$attr
->has_type_constraint;
my
$type_constraint
=
$attr
->type_constraint;
while
(1) {
if
(
$type_constraint
->parent &&
$type_constraint
->parent->name eq
'Maybe'
) {
return
undef
if
!
defined
$value
;
$type_constraint
= find_type_constraint(
$type_constraint
->{type_parameter});
}
if
(
$attr
->transform ) {
my
$function
=
$attr
->transform->{inflate};
{
local
$_
=
$value
;
return
&$function
(
$orm
,
@args
);
}
}
if
(
$type_constraint
->can(
'class'
) &&
$type_constraint
->class &&
$type_constraint
->class->can(
'meta'
) &&
$type_constraint
->class->meta->does_role(
'Storm::Role::Object'
) ) {
return
undef
if
$value
== 0;
my
$class
=
$type_constraint
->class;
my
$key
=
$value
;
$value
=
$orm
->lookup(
$class
,
$value
);
cluck
"could not inflate value for attribute "
.
$attr
->name .
" because we could not locate a $class object in the database"
.
" with the identifier $key"
if
!
defined
$value
;
return
$value
;
}
elsif
(
$self
->has_transformation(
$type_constraint
->name) ) {
my
$function
=
$self
->get_transformation(
$type_constraint
->name)->{inflate};
{
local
$_
=
$value
;
return
&$function
(
$orm
,
@args
);
}
}
else
{
$type_constraint
=
$type_constraint
->parent;
return
$value
if
!
$type_constraint
;
}
}
}
sub
deflate_value {
my
(
$self
,
$attr
,
$value
,
@args
) =
@_
;
return
$value
if
!
$attr
->has_type_constraint;
my
$type_constraint
=
$attr
->type_constraint;
while
(1) {
if
(
$type_constraint
->parent &&
$type_constraint
->parent->name eq
'Maybe'
) {
return
undef
if
!
defined
$value
;
$type_constraint
= find_type_constraint(
$type_constraint
->{type_parameter});
}
if
(
$attr
->transform ) {
my
$function
=
$attr
->transform->{deflate};
{
local
$_
=
$value
;
return
&$function
(
@args
);
}
}
if
(
$type_constraint
->can(
'class'
) &&
$type_constraint
->class &&
$type_constraint
->class->can(
'meta'
) &&
$type_constraint
->class->meta->does_role(
'Storm::Role::Object'
)) {
my
$class
=
$type_constraint
->class;
return
undef
unless
defined
$value
;
return
$class
->meta->primary_key->get_value(
$value
);
}
elsif
(
$self
->has_transformation(
$type_constraint
->name) ) {
my
$function
=
$self
->get_transformation(
$type_constraint
->name)->{deflate};
{
local
$_
=
$value
;
return
&$function
(
@args
);
}
}
else
{
$type_constraint
=
$type_constraint
->parent;
return
$value
if
!
$type_constraint
;
}
}
}
no
Moose;
__PACKAGE__->meta()->make_immutable();
1;