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' );
}
}