perlmeditation demerphq 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). <readmore> Of course accidents happen, and tools like [cpan://Tie::SecureHash] or [id://178518|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. <ul> <li>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. </li> <li>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. </li> <li>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. </li> </ul> Anyway, heres the code, and an example script. <h3>Class::Attributes::InsideOut --<code>site/lib/Class/Attrbutes/InsideOut.pm</code></h3> <code> #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 avalable. 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 it. 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::Insideout"); 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(\$selfobj); > 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(\$selfobj); > 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__"}($selfobj); $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 </code> <h3>Data::Dumper::InsideOut -- <code>site/lib/Data/Dumper/InsideOut.pm</code></h3> <readmore> <code> 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 later. 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 </code> <h3>A test script -- <code>test_insideout.pl</code></h3> <readmore> <code> #!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__ </code> And Finally, What a mixed inside-out, "normal" object looks like when dumped properly <code> # 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::Root' ), '-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' ); </code> 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 :-) </readmore> 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....