Just when you thought it was safe to get back in the water... another variation on the theme of Abigail-II's inside out objects!

First a quick example. Declare classes like this...

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 them like this...

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";

To produce...

10 x 10 (100 sq m) @ $1 = $100 15 x 10 (150 sq m) @ $0.85 = $127.5 difference = $27.5

If you don't know what inside out objects are, take a look at this thread started by Abigail-II, Yet Another Perl Object Model (Inside Out Objects) and A different OO approach.

So what does this variation give you:

... and the downside:

Finally, the code. After my annoying comments on other peoples implementations I thought it only fair that people had the chance to hassle me in return :-) Everything apart from serialisation & accessor generation is in the first 30 29 lines.

It's interesting to compare this with demerphq's "Yet Another Perl Object Model (Inside Out Objects)". Almost the same goals. Very different implementations.

You can download a gziped tar archive from http://www.quietstars.com/perl/ if you find that more convenient.


lib/Class/InsideOut.pm

#! /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::InsideOu +t::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;

lib/Class/InsideOut/Accessor.pm

#! /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;

lib/Class/InsideOut/YAML.pm

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;

Have fun :-)


Updates:

Redundant line removed from DESTROY method. Spotted by John M. Dlugosz


In reply to Class::InsideOut - yet another riff on inside out objects. by adrianh

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":