package Carpet;
use base qw(Class::InsideOut); # base class that does the work
use Class::InsideOut::Accessor; # filter that generates accessors
use Class::InsideOut::YAML; # allow YAML serialisation
sub new {bless [], shift};
{
# declare object attributes
my (%width, %height) : Field;
sub area {
my $self = shift->self; # get the hash key for $self
$width{$self} * $height{$self};
};
}
{
# another object attribute, note the scoping
my %unit_price : Field;
sub price {
my $self = shift;
$self->area * $unit_price{$self->self};
};
};
# note, we are forced to use methods since the hashes are scoped
# to the blocks enclosing the methods - now *that's* private :-)
sub display {
my $self = shift;
my ($width, $height, $area, $unit_price, $price) = ($self->width,
$self->height, $self->area, $self->unit_price, $self->price);
print "$width x $height ($area sq m) @ \$$unit_price = \$$price\n";
};
# note lack of DESTROY method - all done automagically
####
use Carpet;
use YAML;
my $o = Carpet->new;
$o->width(10);
$o->height(10);
$o->unit_price(1.00);
my $o2 = Load(Dump($o)); # serialisation with YAML
$o2->width(15);
$o2->unit_price(0.85);
$o->display;
$o2->display;
print "difference = \$", abs($o->price - $o2->price), "\n";
##
##
10 x 10 (100 sq m) @ $1 = $100
15 x 10 (150 sq m) @ $0.85 = $127.5
difference = $27.5
##
##
#! /usr/bin/perl
use strict;
use warnings;
package Class::InsideOut;
use Attribute::Handlers;
use NEXT;
use Scalar::Util 1.09 qw(blessed refaddr);
our $VERSION = 0.01;
sub self { refaddr shift };
my %Values;
sub Field : ATTR(HASH) {
my ($class, $symbol, $hash) = @_;
my $values = $Values{$class} ||= [];
push @{$values}, $hash;
};
sub DESTROY {
my $self = $_[0];
my $id = $self->self;
while ( my ($class, $values) = each %Values ) {
delete $_->{$id} foreach (@$values);
};
$self->NEXT::DESTROY()
};
package Class::InsideOut::YAML;
sub yaml_dump {
my $item = shift;
my $class = ref $item;
my $self_id = $item->self;
my $inverted = {};
while (my ($class, $values) = each %Values) {
my $class_fields = $inverted->{$class} ||= [];
foreach my $field (@$values) {
push @$class_fields, $field->{$self_id};
};
delete $inverted->{$class} unless @$class_fields;
};
my $ynode = YAML::Node->new({}, "perl/$class");
$ynode->{class} = $class;
$ynode->{object} = bless Storable::dclone($item), 'Class::InsideOut::Frozen';
$ynode->{inverted} = $inverted;
return($ynode);
};
sub yaml_load {
my $ynode = shift;
my $self = bless $ynode->{object}, $ynode->{class};
my $inverted = $ynode->{inverted};
my $self_id = $self->self;
while (my ($class, $values) = each %$inverted) {
my $i = 0;
foreach my $value (@$values) {
$Values{$class}->[$i++]->{$self_id} = $value;
};
};
return(bless $self, $ynode->{class});
};
1;
##
##
#! /usr/bin/perl
package Class::InsideOut::Accessor;
use strict;
use warnings;
use Filter::Simple;
our $VERSION = 0.01;
sub add_accessor {
my $name = shift;
qq[sub $name {
my \$self = shift->self;
\@_ ? \$$name\{\$self\} = shift : \$$name\{\$self\};
};];
};
FILTER {
s [
( \b (my|our) \s* %(\w+) \s* : \s* Field \s* ; )
] [ $1 . add_accessor($3) ]gxse;
s [
( \b (my|our) \s* \( \s* ( .*? ) \s* \) \s* : \s* Field ; )
] [
$1 . join(
'', map {add_accessor(substr($_,1))} split(/\s*,\s*/, $3)
);
]gxse;
};
1;
##
##
package Class::InsideOut::YAML;
use YAML::Node;
use Storable ();
use Class::InsideOut; # where the implementation is
use base qw(Exporter);
our $VERSION = 0.01;
our @EXPORT = qw(yaml_load yaml_dump);
1;