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;