package
InsideOutClass::Attribute;
our
$VERSION
=
'0.02'
;
sub
initialize_instance_slot {
my
(
$self
,
$meta_instance
,
$instance
,
$params
) =
@_
;
my
$init_arg
=
$self
->init_arg;
my
$val
;
$val
=
$params
->{
$init_arg
}
if
exists
$params
->{
$init_arg
};
if
(!
defined
$val
&&
defined
$self
->
default
) {
$val
=
$self
->
default
(
$instance
);
}
my
$_meta_instance
=
$self
->associated_class->get_meta_instance;
$_meta_instance
->initialize_slot(
$instance
,
$self
->name);
$_meta_instance
->set_slot_value(
$instance
,
$self
->name,
$val
);
}
sub
accessor_metaclass {
'InsideOutClass::Method::Accessor'
}
package
InsideOutClass::Method::Accessor;
our
$VERSION
=
'0.01'
;
sub
_generate_accessor_method {
my
$attr
= (
shift
)->associated_attribute;
my
$meta_class
=
$attr
->associated_class;
my
$attr_name
=
$attr
->name;
return
sub
{
my
$meta_instance
=
$meta_class
->get_meta_instance;
$meta_instance
->set_slot_value(
$_
[0],
$attr_name
,
$_
[1])
if
scalar
(
@_
) == 2;
$meta_instance
->get_slot_value(
$_
[0],
$attr_name
);
};
}
sub
_generate_reader_method {
my
$attr
= (
shift
)->associated_attribute;
my
$meta_class
=
$attr
->associated_class;
my
$attr_name
=
$attr
->name;
return
sub
{
confess
"Cannot assign a value to a read-only accessor"
if
@_
> 1;
$meta_class
->get_meta_instance
->get_slot_value(
$_
[0],
$attr_name
);
};
}
sub
_generate_writer_method {
my
$attr
= (
shift
)->associated_attribute;
my
$meta_class
=
$attr
->associated_class;
my
$attr_name
=
$attr
->name;
return
sub
{
$meta_class
->get_meta_instance
->set_slot_value(
$_
[0],
$attr_name
,
$_
[1]);
};
}
sub
_generate_predicate_method {
my
$attr
= (
shift
)->associated_attribute;
my
$meta_class
=
$attr
->associated_class;
my
$attr_name
=
$attr
->name;
return
sub
{
defined
$meta_class
->get_meta_instance
->get_slot_value(
$_
[0],
$attr_name
) ? 1 : 0;
};
}
package
InsideOutClass::Instance;
our
$VERSION
=
'0.01'
;
sub
create_instance {
my
(
$self
,
$class
) =
@_
;
bless
\(
my
$instance
),
$self
->_class_name;
}
sub
get_slot_value {
my
(
$self
,
$instance
,
$slot_name
) =
@_
;
$self
->associated_metaclass->get_package_symbol(
'%'
.
$slot_name
)->{refaddr
$instance
};
}
sub
set_slot_value {
my
(
$self
,
$instance
,
$slot_name
,
$value
) =
@_
;
$self
->associated_metaclass->get_package_symbol(
'%'
.
$slot_name
)->{refaddr
$instance
} =
$value
;
}
sub
initialize_slot {
my
(
$self
,
$instance
,
$slot_name
) =
@_
;
$self
->associated_metaclass->add_package_symbol((
'%'
.
$slot_name
) => {})
unless
$self
->associated_metaclass->has_package_symbol(
'%'
.
$slot_name
);
$self
->associated_metaclass->get_package_symbol(
'%'
.
$slot_name
)->{refaddr
$instance
} =
undef
;
}
sub
is_slot_initialized {
my
(
$self
,
$instance
,
$slot_name
) =
@_
;
return
0
unless
$self
->associated_metaclass->has_package_symbol(
'%'
.
$slot_name
);
return
exists
$self
->associated_metaclass->get_package_symbol(
'%'
.
$slot_name
)->{refaddr
$instance
} ? 1 : 0;
}
1;