package My::UNIVERSAL;

use base qw(Class::Data::Inheritable);

1;

##</code><code>##

package My::UNIVERSAL;

use strict;
use warnings;

use base qw(
  Class::Data::Inheritable
  Class::Accessor
);

1;

##</code><code>##

package Creature;

use base 'My::UNIVERSAL';

__PACKAGE__->mk_classdata( mortal => 1 );
__PACKAGE__->mk_accessors( qw/name gender/ );

1;

# in the code

my $creature = Creature->new({
    name   => 'Alice',
    gender => 'female',
} );

##</code><code>##

$VAR1 = bless( {
  gender => 'female',
  name   => 'Alice'
}, 'Creature' );

##</code><code>##

sub mk_accessors {
    my ( $class, @accessors ) = @_;
    foreach my $accessor (@accessors) {
        no strict 'refs';
        my $key  = "$class\::$accessor";
        *$key = sub {
            my $self = shift;
            return $self->{$key} unless @_;
            $self->{$key} = shift;
            return $self;
        };
    }
}

##</code><code>##

sub area {
    my $self = shift;
    return $self->height * $self->width;
}

##</code><code>##

use Scalar::Util 'reftype';

sub new {
    my ( $class, $args ) = @_;
    $args = {} unless defined $args;
    unless ( 'HASH' eq reftype $args ) {
        croak "Argument to new() must be a hash reference";
    }
    my $self = bless {} => $class;
    while ( my ( $key, $value ) = each %$args ) {
        $self->$key($value);
    }
    return $self;
}

##</code><code>##

$VAR1 = bless( {
  'Creature::gender' => 'female',
  'Creature::name'   => 'Alice'
}, 'Creature' );

##</code><code>##

$creature->name('Bob')
         ->gender('unknown');

##</code><code>##

my $creature = Creature->new( {
    name   => 'Alice',
    gender => 'female',
    foo    => 1,
} );

##</code><code>##

__PACKAGE__->mk_class_data('__data_key');

sub new {
    my ( $class, $args ) = @_;

    # XXX I don't like doing this for every instance, but 
    # use 'base' doesn't call import()
    my $key = " $class data ";
    $class->__data_key($key);
    $args ||= {};
    unless ( 'HASH' eq reftype $args ) {
        croak('Argument to new() must be a hashref');
    }
    my $self = bless { $key => $args } => $class;
    $self->_initialize;
    delete $self->{$key};
    return $self;
}

sub _initialize {
    my $class = ref($_[0]);
    croak "_initialize() must be overridden in a ($class)";
}

# a truly private method!
my $check_attribute = sub {
    my ( $self, $attribute ) = @_;
    my $value = delete $self->{ $self->__data_key }->{$attribute};
    if ( ! defined wantarray ) {
        $self->$attribute($value);
    }
    else {
        return $value;
    }
};

sub _must_have {
    my ( $self, $attribute ) = @_;

    croak("Mandatory attribute ($attribute) not found")
      unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}


sub _may_have {
    my ( $self, $attribute ) = @_;
    return unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}

##</code><code>##

package Creature;

use base 'My::UNIVERSAL';

__PACKAGE__->mk_classdata( mortal => 1 );
__PACKAGE__->mk_accessors(qw/name gender/);

sub _initialize {
    my ( $self, $args ) = @_;
    $self->_must_have('name');
    $self->_may_have('gender');
}

##</code><code>##

package IP::Address;

use base 'My::Universal';
__PACKAGE__->mk_accessors('address');

sub _initialize {
    my $self = shift;
    $self->address( $self->_must_have('ip') );
}

1;

#

use IP::Address;

my $ip = IP::Address->new({ ip => $some_ip });
print $ip->address;   # prints $some_ip

##</code><code>##

my $check_keys = sub {
    my $self = shift;
    my $data = delete $self->{ $self->__data_key };
    if ( my @keys = keys %$data ) {
        local $" = ', ';
        croak("Unknown keys to constructor:  (@keys)");
    }
};

sub new {
    my ( $class, $args ) = @_;
    my $key = " $class data ";
    $class->__data_key($key);
    $args ||= {};
    unless ( 'HASH' eq reftype $args ) {
        croak('Argument to new() must be a hashref');
    }
    my $self = bless { $key => $args } => $class;
    $self->_initialize;
    $self->$check_keys;
    return $self;
}

##</code><code>##

my $creature = Creature->new( {
    name   => 'Alice',
    gender => 'female',
    foo    => 1,
    bar    => 1,
} );

# Unknown keys to constructor:  (bar, foo)

##</code><code>##

package Tall::Square;

use Scalar::Util 'looks_like_number';
use base 'My::UNIVERSAL';

__PACKAGE__->mk_accessors(
  width  => sub { looks_like_number($_[1]) && $_[1] > 0 ),
  height => sub {
      my ( $self, $height ) = @_;
      return looks_like_number($height) && $height > $self->width;
  },
);

sub _initialize {
    my $self = shift;
    $self->_must_have('height');
    $self->_must_have('width');
}

sub area {
    my $self = shift;
    return $self->height * $self->width;
}

1;

##</code><code>##

package My::UNIVERSAL;

use strict;
use warnings;
use Scalar::Util 'reftype';
use Carp 'croak';

use base qw(Class::Data::Inheritable);
__PACKAGE__->mk_classdata('__data_key');

sub mk_accessors {
    my ( $class, @accessors ) = @_;
    foreach my $accessor (@accessors) {
        no strict 'refs';
        my $key  = "$class\::$accessor";
        *$key = sub {
            my $self = shift;
            return $self->{$key} unless @_;
            $self->{$key} = shift;
            return $self;
        };
    }
}

my $check_keys = sub {
    my $self = shift;
    my $data = delete $self->{ $self->__data_key };
    if ( my @keys = keys %$data ) {
        local $" = ', ';
        croak("Unknown keys to constructor:  (@keys)");
    }
};

sub new {
    my ( $class, $args ) = @_;
    my $key = " $class data ";
    $class->__data_key($key);
    $args ||= {};
    unless ( 'HASH' eq reftype $args ) {
        croak('Argument to new() must be a hashref');
    }
    my $self = bless { $key => $args } => $class;
    $self->_initialize;
    $self->$check_keys;
    return $self;
}

sub _initialize {
    my $class = ref($_[0]);
    croak "_initialize() must be overridden in a ($class)";
}

my $check_attribute = sub {
    my ( $self, $attribute ) = @_;
    my $value = delete $self->{ $self->__data_key }->{$attribute};
    if ( !defined wantarray ) {
        $self->$attribute($value);
    }
    else {
        return $value;
    }
};

sub _must_have {
    my ( $self, $attribute ) = @_;

    croak("Mandatory attribute ($attribute) not found")
      unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}

sub _may_have {
    my ( $self, $attribute ) = @_;
    return unless exists $self->{ $self->__data_key }->{$attribute};
    goto $check_attribute;
}

1;