Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??

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


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



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others meditating upon the Monastery: (5)
As of 2024-03-29 00:59 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found