Recently a number of monks have been discussing Perl OO and perl OO
object models. One thing that I've found a interesting is the
number of approaches that are out there. All of them attempt to
resolve problems (or perceived problems) in the perl approach
to OO. A common problem that is attempted to be solved is that
of internal attribute clashes in inherited modules. I personally
find this a little strange as I tend to not find this to be a noteworthy
issue in my day to day use of objects in perl. Now perhaps I am not doing
the kind of heavy inheritance that would cause this type of issue to
be common enough for me to call it a problem, but I think that sometimes
its because I look at it in a different way.
In Perl very rarely do you not have access to the perl code that you
are inheriting. (The only example I can think of is a pure XS object,
and then I wonder if it matters.) So its not particularly difficult to
see if you are walking on attributes. You can review the code (either
in a debugger or with the appropriate calls to a serialization module
and other types of debugging) and see what attributes to be careful
of. If you are paranoid you can use special prefixes on hash
attributes (like the __PACKAGE__ name), or other tricks. But tricks more often then not seem to just lead to yet more tricks to do other things that used to be easy. ( Such as the contortions required to serialize an inside out object. See below).
Of course accidents happen, and tools like
Tie::SecureHash or
other techniques can help to avoid them, but generally
speaking I tend to think that a rigourous approach to testing is
sufficient to make these tools overkill most of the time. If
you've mistyped a hash key somewhere, or negligently walked over a
parent classes attribute then your test cases
should raise
enough alarms that identifying the cause of the error is not
difficult.
As you can see, i'm not particularly inclined to depart from the plain
vanila blessed array or hashref type objects. Despite this I think its
worthwhile exploring these alternate models so as to understand what
pitfalls they hope to avoid and which they don't.
One approach that i'd like to consider in more detail is Abigail-
II's concept of inside-out objects. I think that this is an
interesting idea as it does make subclassing quite easy. I don't think
I would tend to use it much but it is interesting enough that I played
with it for a while today. One aspect that caught my attentio was how
do to serialize an object constructed like this. Its not straight
forward at all. :-) I played around with it for a while and in the end
the solution I came up with involves three aspects that id like to mention breifly, before i present the code.
- Auto Generated Code --
I felt that in order to be able to easily use Abigail-II's framework
autogenerated code was essential. This was to my mind the only way to
keep the various tasks synchronized. (Such as serialization and the deletion of attributes on DESTROY). This also appeals to my sense of lazyness as
the approach is a touch verbose for my taste and this makes it easier
to play with.
- Subclassed Dumper --
In order to make it possible that the object can be dumped anytime any
place without damage it is either require to subclass or patch
Data::Dumper. I took the former approach. Amongst other problems was
that using Freezer also has the unfortunate side effect of causing the
object dumped to go into a "frozen" state after dumping. The sub class
handles reversing this process.
- Mess with UNIVERSAL --
As mentioned before the implementation of Freezer/Toaster in
Data::Dumper is at least partially broken. It only accomdates one
Freezer/Toaster method for all objects, and then it applies both
indiscriminately to any blessed objects, whether they need them or
not. This more or less entails that UNIVERSAL needs to be interfered
with to prevent copious warning messages when dumping InsideOut and
non InsideOut objects at the same time.
Anyway, heres the code, and an example script.
Class::Attributes::InsideOut --site/lib/Class/Attrbutes/InsideOut.pm
#Basic "InsideOut" object
#from http://perlmonks.org/index.pl?node_id=178518
#package BaseballPlayer::Pitcher;
#{
# use vars '@ISA';
# @ISA = 'BaseballPlayer';
#
# my (%ERA, %Strikeouts);
#
# sub ERA : lvalue {$ERA {+shift}}
# sub Strikeouts : lvalue {$Strikeouts {+shift}}
# sub DESTROY {
# my $self = shift;
# delete $ERA {$self}, $Strikeouts {$self}
# }
#}
package Class::Attributes::InsideOut;
use Carp ();
use Data::Dumper;
use strict;
no strict 'refs';
our $DEBUG;
BEGIN {
# see if we can get Scalar::Util to do our dirty work,
# its faster than parsing overload::StrVal($ref)
unless (eval"
require Scalar::Util;
*refaddr=*Scalar::Util::refaddr{CODE};
1;
") {
# Nope. Didn't seem to work. We dont have Scalar::Util avalabl
+e.
warn "Failed require Scalar::Util" if $DEBUG;
#figure out where the ID is in a stringified bless reference.
my $IDXOFS= -(length(bless {})-rindex(bless({}),"("));
require overload;
# Note the $IDXOFS interpolates into a constant when we eval i
+t.
eval "
sub refaddr {
return ref \$_[0]
? substr(overload::StrVal(\$_[0]),$IDXOFS)
: undef;
};
1;
" or die $@;
}
}
sub import {
my $caller=caller;
my $pack=shift;
print Data::Dumper->Dump([$pack,\@_],[qw(pack *_)])
if $DEBUG;
!@_ and Carp::confess("No arguments to Class::Attributes::Insideou
+t");
my $isa="";
if (ref $_[0] ) {
$isa=" ".join(" ",@{shift(@_)});
}
if (my @badargs=grep{/\W/}@_) {
Carp::confess("Illegal arguments @badargs");
}
my @snippets=map{
"sub $_ : lvalue {\$$_\{"
. "Class::Attributes::InsideOut::refaddr(shift)"
. "||Carp::confess 'not a reference!'}}";
} @_;
# Line matching /^\s*>/ are "Here_Doc" quoted strings.
my @dump=map {
(my $code=<<"_EOF_CODE")=~s/^\s*>/ /mg;$code;
> \$as_hash{$_}=\$$_\{\$self}
> if exists (\$$_\{\$self});
_EOF_CODE
}@_;
(my $snippet=<<"_EOF_CODE")=~s/^\s*>/ /mg;
>{
> package $caller;
>
> use vars qw/\@ISA/;
> \@ISA=qw($isa InsideOut::Class );
>
> my (@{[join ", ",map{"%$_"}@_]});
>
> @{[join "\n\t",@snippets]}
>
> sub __As_Hash__ {
> my \$selfobj=shift;
> my \$self=Class::Attributes::InsideOut::refaddr(\$self
+obj);
> print "$caller\::__As_Hash__(\$self)\\n"
> if \$Class::Attributes::InsideOut::DEBUG;
> my %as_hash;
>@{[join(" ",@dump)]}
> scalar(keys(%as_hash)) ? \\%as_hash : ()
> }
>
> sub __DESTROY__ {
> my \$selfobj=shift;
> my \$self=Class::Attributes::InsideOut::refaddr(\$self
+obj);
> print "$caller\::__DESTROY__(\$self)\\n"
> if \$Class::Attributes::InsideOut::DEBUG;
> @{[join ";\n ",map{"delete \$$_\{\$self}"}@_]};
> \$_->can("__DESTROY__") and
> &{\$_."::__DESTROY__"}(\$selfobj)
> foreach \$selfobj->_parents;
> }
>}
>1;
_EOF_CODE
eval $snippet or die "Eval\n$snippet\nfailed with the error $@";
print $snippet if $DEBUG;
}
1;
package InsideOut::Class;
sub new {bless {},shift}
sub __Parents__ {
my ($selfobj)=(@_);
my $self=Class::Attributes::InsideOut::refaddr($selfobj);
print ref($selfobj)."::__Parents__($self)\n"
if $Class::Attributes::InsideOut::DEBUG;
my %hash;
my @queue=[ref $selfobj,0];
my @list;
while (@queue) {
my ($pack,$depth)=@{shift @queue};
next if defined $hash{$pack};
$hash{$pack}=$depth++;
unshift @list,$pack;
foreach my $item ( @{$pack."::ISA"} ) {
push @queue,[$item,$depth];
}
}
@list
}
sub __Freezer__ {
my ($selfobj)=(@_);
my $self=Class::Attributes::InsideOut::refaddr($selfobj);
print ref($selfobj)."::__Freezer__($self)\n"
if $Class::Attributes::InsideOut::DEBUG;
my @list=$selfobj->__Parents__;
my $class=ref $selfobj;
bless $selfobj,"Frozen::InsideOut::Class::Root";
my $return=bless {
"-self" => $selfobj,
"-class" => $class,
( map {
if ($_->can('__As_Hash__')) {
my $frozen=&{$_."::__As_Hash__"}($se
+lfobj);
$frozen ? ( $_ => $frozen ) : ()
} else {
()
}
} @list )
},"Frozen::InsideOut::Class";
return $return;
}
sub DESTROY {
my ($selfobj)=(@_);
my $self=Class::Attributes::InsideOut::refaddr($selfobj);
print ref($selfobj)."::DESTROY($self)\n"
if $Class::Attributes::InsideOut::DEBUG;
my @parents=reverse $selfobj->__Parents__;
foreach (@parents) {
$_->can("__DESTROY__") and
&{$_."::__DESTROY__"}($selfobj);
}
}
1;
package Frozen::InsideOut::Class;
sub Toaster {
my $obj=shift;
print ref($obj)."::__Toaster__($obj)\n"
if $Class::Attributes::InsideOut::DEBUG;
foreach my $pack (keys %$obj) {
next if $pack =~/\W/;
foreach my $attr (keys %{$obj->{$pack}}) {
&{"$pack\::$attr"}($obj->{-self})=$obj->{$pack}{$attr};
}
}
return bless $obj->{-self},$obj->{-class};
}
1;
__END__
=head1 NAME
Class::Attributes::InsideOut - Base class generator for inside-out
classes which know how to serialize themselves.
=head1 SYNOPSIS
package Baz;
use Class::Attributes::InsideOut qw(baz bop);
package Bar;
use Class::Attributes::InsideOut '@ISA'=>[qw(Foo Baz)],qw(foo bang);
=head1 DESCRITION
Evals into existance the required code for a class based on Abigails
"inside-out" OO design pattern. The created modules can be
(relatively) safely serialized with L< Data::Dumper::InsideOut |
Data::Dumper::InsideOut >. In addition, accessors won't get confused
if the class changes, although of course they may not get called, but
if they do they are guaranteed to use the correct data. Cleanup on
destroy is automatically facilitated.
In order to do this all objects created from this class are subclassed
+
from InsideOut::Class (which is automatically used at the same time as
+
this module).
=over 4
=item use Class::Attributes::InsideOut qw(foo bar baz);
The interface is simple. Inside of the package you wish to create you
use() this module with a list of attribute names. If the class is a
subclass then it is necessary to provide the parent classes in a
arrayref as the first parameter in the use clause. That or unshift
them onto the packages @ISA after the use.
The attributes are lvalues into independant lexically scoped hashes,
keyed on the reference address. This class provides the means to
obtain this transparently and consistantly via the subroutine
=item Class::Attributes::InsideOut::refaddr()
Which returns the reference address of the passed object. If possible
this will just be a call into Scalar::Util::refaddr, otherwise it will
+
be obtained by the much slower parsing of the return of
overload::StrVal($ref).
This means that reblessing of the objects does not change the key used
+
to look them up for the various accessors. Such as when using class
type to track object state.
=item $Class::Attributes::InsideOut::DEBUG
Setting C<$Class::Attributes::InsideOut::DEBUG=1> in a begin block
before the use clause will cause the generated code to be printed to
STDOUT.
=back
=head1 NOTE
A number of special methods are created. In order to minimize the
chance of these colliding with anything they are prefixed and
postfixed by 2 underbars. Ie "__DESTROY__".
It is important these methods dont get overriden.
=head1 WARNING
@ISA relationships are used to determine what values need to be
serialized and destroyed.
It may be necessary to improve the logic used to determine which hash
values need to be deleted upon an objects destroy. Currently this
should be done by overriding the base classes DESTROY method (don't
forget to call SUPER::DESTROY however).
Caching could be implemented for the DESTROY. Currently it will do a
depth first traversal, deepest leftmost first through all the
ancestors looking for a __DESTROY__ method.
=head1 BUGS
In code this funky almost certainly. YMMV. Patches welcome.
=head1 AUTHOR and COPYRIGHT
Module Copyright by demerphq - Yves Orton Dec 2002
Based on ideas and code snippet at
http://perlmonks.org/index.pl?node_id=178518 by and copyright -
Abigail 2002
Released under the Perl Artisitic License.
=head1 SEE ALSO
L<Perl>
=cut
Data::Dumper::InsideOut -- site/lib/Data/Dumper/InsideOut.pm
package Data::Dumper::InsideOut;
use Data::Dumper();
require Exporter;
@ISA = qw(Exporter Data::Dumper);
@EXPORT = qw(Dumper);
use strict;
sub Dumper {
# don't want Data::Dumper objects, want the subclass.
return Data::Dumper::InsideOut->Dump([@_]);
}
sub Dump {
# The XS routine doesnt know about us
goto &Data::Dumper::InsideOut::Dumpperl;
}
sub new {
# we need to add some attributes to the dumper object
my $s=shift;
my $obj=$s->SUPER::new(@_);
@{$obj}{qw(frigid frozen freezer _freezer toaster)}
=({},{},"__Inside_Out_Freezer__","__Freezer__","Toaster")
+;
$obj;
}
sub Dumpperl {
my $s=shift;
$s = $s->new(@_) unless ref $s;
my @out=$s->SUPER::Dumpperl(@_);
foreach my $type (keys %{$s->{frigid}}) {
# undo any blessing caused by freezing.
foreach my $itm (@{$s->{frigid}{$type}}) {
$itm=bless $itm,$type;
}
}
wantarray ? @out : join('', @out);
}
sub _dump {
my($s, $val, $name) = @_;
my $type = ref $val;
my $return;
if ($type) {
if ($s->{freezer} and UNIVERSAL::can($val,$s->{_freezer})) {
my ($id)=overload::StrVal($val)=~/\((.*?)\)/;
unless ($s->{frozen}{$id}++) {
# store the class type of this guy so we can restore it la
+ter.
push @{$s->{frigid}{$type}},$val;
my $freezer=$s->{freezer};
return $s->SUPER::_dump($val->$freezer(),$name);
} else {
# already stored
return $s->SUPER::_dump($val,$name);
}
} elsif ($s->{toaster}) {
# remove the Toaster on objects that cant
my $return=$s->SUPER::_dump($val,$name);
$return=~s/->$s->{toaster}\(\)$//;
return $return
}
}
return $s->SUPER::_dump($val,$name);
}
1;
package UNIVERSAL;
sub __Inside_Out_Freezer__ {
my $self=shift;
# prevent non toaster objects from screaming.
$self->can("__Freezer__") ? $self->__Freezer__ : $self
}
1;
__END__
=head1 NAME
Data::Dumper::InsideOut - Data::Dumper subclass that knows how to
serialize "Inside-Out" objects created using
L<Class::Attributes::InsideOut|Class::Attributes::InsideOut>
=head1 SYNOPSIS
use Data::Dumper::InsideOut;
print Dumper($inside_out_obj);
=head1 DESCRITION
See Data::Dumper. Ignore anything to do with Toaster or Freezer there
and youll be fine.
=head1 WARNING
Using this module cause the method __Inside_Out_Freezer__ to be added
to UNIVERSAL object.
=head1 BUGS
In code this funky almost certainly. YMMV. Patches welcome.
=head1 AUTHOR and COPYRIGHT
Copyright by demerphq - Yves Orton Dec 2002
Released under the Perl Artisitic License.
=head1 SEE ALSO
L<Perl>, L<Class::Attributes::InsideOut>
=cut
A test script -- test_insideout.pl
#!perl -l
BEGIN {
$Class::Attributes::InsideOut::DEBUG=0;
}
package Foo;
use Class::Attributes::InsideOut qw(foo bar baz);
package Baz;
use Class::Attributes::InsideOut qw(baz bop);
package Bar;
use Class::Attributes::InsideOut [qw(Foo Baz)],qw(foo bang);
package Plain;
sub new { bless [@_],shift }
package main;
use Data::Dumper::InsideOut;
sub check {
my $obj=shift;
print "# Data::Dumper\n".Data::Dumper::Dumper($obj);
my $dump=Dumper($obj);
print "\n# Data::Dumper::InsideOut\n".$dump;
my $new=eval $dump or die "$dump $@";
print "\n# Evaled Data::Dumper::InsideOut\n".Dumper($new);
}
my $obj=Foo->new();
$obj->foo=10;
$obj->bar=[qw(a b c)];
$obj->baz="Inside-Out";
my $bar=Foo->new();
$bar->foo="foo";
bless $bar,"Baz";
$bar->baz="baz";
$bar->bop="bop";
bless $bar,"Bar";
$bar->bang="Bang!";
$bar->foo="bar";
$bar->bop="bar";
$bar->bar=$obj;
check($obj);
check($bar);
check(Plain->new($bar));
__END__
And Finally, What a mixed inside-out, "normal" object looks like when dumped properly
# last dump from check(Plain->new($bar));
# Evaled Data::Dumper::InsideOut
$VAR1 = bless( [
'Plain',
bless( {
'Foo' => {
'foo' => 'foo',
'bar' => bless( {
'Foo' => {
'foo' => 10,
'baz' => 'Inside-Out',
'bar' => [
'a',
'b',
'c'
]
},
'-self' => bless( {}, 'Frozen::InsideOut::Class::Ro
+ot' ),
'-class' => 'Foo'
}, 'Frozen::InsideOut::Class' )->Toaster()
},
'-self' => bless( {}, 'Frozen::InsideOut::Class::Root' ),
'Bar' => {
'foo' => 'bar',
'bang' => 'Bang!'
},
'Baz' => {
'baz' => 'baz',
'bop' => 'bar'
},
'-class' => 'Bar'
}, 'Frozen::InsideOut::Class' )->Toaster()
], 'Plain' );
As you can see the special "inside-out" attributes are dumped as though they existed in a seperate hash per package the attributes belong to. And when they are Toaster()ed the appropriate updates are made using the packages attribute accessors, (without using OO).
The amount of hassle needed to serialize these modules suggests to me that for a beginner inside out objects will probably be harder to use than more traditional approaches. They may be safer in general, but I think beginners depend on being able to see the data structures that they are working on and not being able to will make deeper comprehension difficult. Hopefully the framework above makes that job a bit easier.
Anyway thanks to whole host of people for motivating this node in one
way or another.
jreades Abigail-II adrianh shotgunfx fruiture BrowserUk
merlyn TheDamian GSAR TOMC
and a whole host of other players no doubt. /msg me if you think I
have forgotten you.
Hope this was interesting, and please let me know about any
suggestions or comments you might have. (I can think of bunch of areas
ripe for improvement, but enough is enought for today :-)
updated:Minor typographical edits and readmore changes. And later again removed a superfluous duplicate line from the code.
--- demerphq
my friends call me, usually because I'm late....