view release on metacpan or  search on metacpan

lib/Object/Generic.pm  view on Meta::CPAN

package Object::Generic;
#
# Object::Generic.pm
#
# A generic base class for objects including 
# several set/get interfaces for key/value pairs within the object.
#
#    use Object::Generic;
#    $thing = new Object::Generic  color => 'red';
#
#    $color = $thing->get('color');
#    $color = $thing->get_color;
#    $color = $thing->color
#
#    $thing->set( color => 'blue' );
#    $thing->set_color('blue');
#    $thing->color('blue');
#
# See the bottom of this file for the documentation.
#
# $Id: Generic.pm 403 2005-09-08 20:17:37Z mahoney $
#
#
use strict;
use warnings;
use Object::Generic::False qw(false);

our $VERSION = '0.13';

my $false = Object::Generic::false();

sub new {
  my $class = shift;
  my $self  = bless {} => $class;
  $self->args(@_);
  return $self;
}

# Return a list of the current keys.
sub keys {
  my $self = shift;
  return keys %$self;
}

# Return true or false depending on whether a key has been defined.
sub exists {
  my $self = shift;
  my ($key) = @_;
  return 0 unless defined $key;
  return exists($self->{$key});
}

#
# If the hash for a given class is empty, then any key is allowed 
# in ->set_key() and its variants for that class.
# Otherwise, only the given keys are allowed.
# The allowed keys are defined relative to a given class name
# so that inherited classes will each have their own list of allowed keys.
#
# In other words, if MyClass inherits from Object::Generic,
# and only 'color' and 'height' are allowed keys for that class,
# then this hash will include  
#   $allowed_keys = { MyClass => { color=>1, height=>1 } }
# On the other hand, since there is no $allowed_keys->{Object::Generic},
# any key is allowed (by default) in Object::Generic.
#
our $allowed_keys = { };

# Usage: InheritedClass->set_allowed_keys( 'color', 'size' );
# This sets the keys for an entire class,  *not* for one instance.  
# If you want different objects with different sets of allowed keys, 
# define several classes that inherit from Object::Generic.
sub set_allowed_keys {
  my $class = shift;
  return 0 if ref($class); # do nothing and return false if this is an object.
  my @keys = @_;
  $allowed_keys->{$class}{$_} = 1 foreach @keys;
  return 1;  # return true
}

#
# Usage: if ( InheritedClass->allows_key($key) ){ ... }
#    or  if ( $object->allows_key($key) ){ ... }
sub allows_key {
  my $self_or_class = shift;  # either class or object method; don't care.
  my $class = ref($self_or_class) || $self_or_class;
  my ($key) = @_;
  return 1 unless exists($allowed_keys->{$class});
  return $allowed_keys->{$class}{$key};
}


# Usage: InheritedClass->define_accessors( @keys );
# For each $key, defines $obj->get_key(), $obj->set_key(), and $obj->key().