package OO; use strict; use warnings; use Carp qw/croak/; #### #-------------------------------------------------------------------- # The registry itself: storing all the data of your objects #-------------------------------------------------------------------- my %Object = (); # Object => Class => Attribute #### #-------------------------------------------------------------------- # inheritable constructor with generalized behaviour #-------------------------------------------------------------------- sub new { my $class = shift; my $self = bless [caller], $class; # is that neccessary if you can override new()? if( $self->can( 'initialize' ) ){ $self->initialize( @_ ); } return $self; } #### #-------------------------------------------------------------------- # Use these two methods to get and set members of your # object and they will do encapsulation for you # # BE CONSISTENT our your OO will BREAK! # #-------------------------------------------------------------------- sub oo_get { my $obj = shift; my $field = shift; # member hash is based on caller class # and may be overwritten by third argument to get() my $class = @_ ? shift : caller; $Object{ $obj }{ $class }{ $field } } sub oo_set { my $obj = shift; my $field = shift; my $value = shift; my $class = @_ ? shift : caller; $Object{ $obj }{ $class }{ $field } = $value; } #### #-------------------------------------------------------------------- # most important: DESTROY #-------------------------------------------------------------------- sub DESTROY { my $obj = shift; delete $Object{ $obj } #that's why the structure of the registry was chosen like that } #### #-------------------------------------------------------------------- # create_accessor class method to create simple accessor/mutator methods #-------------------------------------------------------------------- sub oo_create_accessor { my $pkg = shift; no strict 'refs'; # we're messing around with the symbol table foreach my $mem ( @_ ){ my $symbol = $pkg . '::' . $mem; if( defined *{ $symbol } ){ croak "Attempt to redefine $symbol via create_accessor"; } else { *{ $symbol } = sub { my $self = shift; if( @_ ){ $self->oo_set( $mem , $_[0] , $pkg ); } else { $self->oo_get( $mem , $pkg ); } }; } } } #### #-------------------------------------------------------------------- # debugging function/method (as you like it) #-------------------------------------------------------------------- sub oo_registry { return \%Object } 1;