http://qs1969.pair.com?node_id=220776

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:

  • No hand-rolled DESTROY methods for each class. All the DESTROY functionality is handled in Class::InsideOut::DESTROY. This means you are free to write your own class DESTROY methods, as long as you remember to do a $self->NEXT::DESTROY at the end.
  • No new() function in the base class, so you can mix it into "normal" perl objects with no worries.
  • You get direct access to the hashes that store the attributes inside the class - so you get nice compile time errors if you make a typing mistake.
  • Hashes used as object attributes are clearly indicated by the ":Field" attribute - making them easy to differentiate from other uses of hashes in the class. Self documenting code is good.
  • Because of the way the base class handles the DESTROY you can actually have object attributes hashes have a tighter scope than the whole class!
  • You don't have to have accessor functions generated for you if you don't want to - it's a separate source filter. Private attributes can stay private.
  • Object serialisation with YAML (if you want it). I freely admit that I did it this way because I wanted to look at YAML in more detail for some time and this seemed as good an excuse as any :-)
  • Everything works with overloading operations and reblessing objects.
  • DESTROY and serialisation work even if you bless your object into a different class hierarchy!

... and the downside:

  • The flexible DESTROY is slower than the hand-rolled ones.
  • The source filter for auto-generating accessor functions is, well, a source filter. There are probably some cases it doesn't handle 100%... the regexes used haven't been tested much.
  • The YAML serialisation is a bit of a hack because YAML.pm is not re-enterant - which is a pain.
  • It should present better warnings when you try and create accessors with the same name as an existing accessor sub.
  • ... more ? ...

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