#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 =cut