sub some_method { my $self = shift; $self->{'_very_internal_flag'} = 1; #... } #### package OO; # RFC use strict; use warnings; use Carp qw/croak/; # # A very base class of all classes # # # The registry # my %Object = (); # Class => field => object # # inheritable constructor (RFC: should there be one?) # sub new { my $class = shift; # so now objects are themselves dummies # why not store debugging information of an object's origin by default? # if you don't like this, don't inherit the constructor! my $self = bless [ caller ], $class; # is that neccessary if you can override new() if( $self->can( 'initialize' ) ){ $self->initialize( @_ ); } return $self; } # # oo_create_accessor class method (RFC: usefull?) # sub oo_create_accessor { my $pkg = shift; no strict "refs"; 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 ); } }; } } } # # 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{ $class }{ $field }{ $obj } } sub oo_set { my $obj = shift; my $field = shift; my $value = shift; my $class = @_ ? shift : caller; $Object{ $class }{ $field }{ $obj } = $value } # # debugging function # sub oo_registry { #intended as class/instance method or funtion return \%Object } 1; #### package Car; use base 'OO'; sub color { #my accessor/mutator my $self = shift; if( @_ ){ $self->oo_set( 'color' , $_[0] ); } else { $self->oo_get( 'color' ); } } package Rover; #a class of it's own ;) sub get_set_color { my $self = shift; if( @_ ){ $self->oo_set( 'color' , $_[0] ); } else { $self->oo_get( 'color' ); } }