File Coverage

blib/lib/OOP/Perlish/Class.pm

Criterion	Covered	Total	%
statement	319	374	85.2
branch	63	112	56.2
condition	27	62	43.5
subroutine	64	68	94.1
pod	12	12	100.0
total	485	628	77.2

#!/usr/bin/perl
# $Id$
# $Author$
# $HeadURL$
# $Date$
# $Revision$
use warnings;
use strict;
{
    ############################################################################################
    ## OOP::Perlish::Class: a Base class for creating Objects that conform to all common OOP
    ## practices, Multiple-Inheritance, Mix-in, Generational-Inheritance, Overriding,
    ## Overloading, Accessor validation, input mutation, singletons, Multitons, etc, etc
    ############################################################################################

    package OOP::Perlish::Class;
    use warnings;
    use strict;
    our $VERSION = '0.45.0';
    use OOP::Perlish::Class::Accessor;
    use Tie::IxHash;
    use Exporter;
    use IO::Handle;

    use constant OOP_PERLISH_CLASS_EMITLEVEL_FATAL   => 0;
    use constant OOP_PERLISH_CLASS_EMITLEVEL_ERROR   => 1;
    use constant OOP_PERLISH_CLASS_EMITLEVEL_WARNING => 2;
    use constant OOP_PERLISH_CLASS_EMITLEVEL_INFO    => 3;
    use constant OOP_PERLISH_CLASS_EMITLEVEL_VERBOSE => 4;
    use constant OOP_PERLISH_CLASS_EMITLEVEL_DEBUG0  => 5;
    use constant OOP_PERLISH_CLASS_EMITLEVEL_DEBUG1  => 6;
    use constant OOP_PERLISH_CLASS_EMITLEVEL_DEBUG2  => 7;

    use Carp qw(carp croak confess cluck);

    our @EXPORT_TAGS = (
                         'emitlevels' => [
                                           'OOP_PERLISH_CLASS_EMITLEVEL_FATAL',   'OOP_PERLISH_CLASS_EMITLEVEL_ERROR',
                                           'OOP_PERLISH_CLASS_EMITLEVEL_WARNING', 'OOP_PERLISH_CLASS_EMITLEVEL_INFO',
                                           'OOP_PERLISH_CLASS_EMITLEVEL_VERBOSE', 'OOP_PERLISH_CLASS_EMITLEVEL_DEBUG0',
                                           'OOP_PERLISH_CLASS_EMITLEVEL_DEBUG1',  'OOP_PERLISH_CLASS_EMITLEVEL_DEBUG2'
                                         ],
                       );

    our @EXPORT_OK = (
                       'OOP_PERLISH_CLASS_EMITLEVEL_FATAL',   'OOP_PERLISH_CLASS_EMITLEVEL_ERROR',
                       'OOP_PERLISH_CLASS_EMITLEVEL_WARNING', 'OOP_PERLISH_CLASS_EMITLEVEL_INFO',
                       'OOP_PERLISH_CLASS_EMITLEVEL_VERBOSE', 'OOP_PERLISH_CLASS_EMITLEVEL_DEBUG0',
                       'OOP_PERLISH_CLASS_EMITLEVEL_DEBUG1',  'OOP_PERLISH_CLASS_EMITLEVEL_DEBUG2'
                     );

    ############################################################################################
    ## We still use Exporter's import, but we need to clean it up first
    ## doing this via export_fail doesn't work because exporter must see 'our @EXPORT_FAIL'
    ## in the namespace of package being imported; and subclasses would not normally have
    ## re-defined that again and again and again; optionally, we'd @EXPORT = qw(@EXPORT <...>)
    ## which would result in every module cascading the exports down all the way to users
    ## of the object (not just inheritors) which would suck.
    ############################################################################################
    sub import
    {
        my ( $proto, @tags ) = @_;
        my $class = ref($proto) || $proto;

        if( bless( {}, $class )->isa(__PACKAGE__) ) {
            $class->____OOP_PERLISH_CLASS_DERIVED_CLASSES()->{$class} = 1;
        }

        return unless(@tags);

        my %non_import_flags;
        ## XXX: Hash slice assignment for LUT
        @non_import_flags{
            '_emitlevel:error', '_emitlevel:warning', '_emitlevel:info', '_emitlevel:verbose',
            '_emitlevel:debug', '_emitlevel:debug1',  '_emitlevel:debug2'
          }
          = undef;

        for my $tag (@tags) {
            for my $setter_tag ( keys %non_import_flags ) {
                $tag =~ m/ ^ \Q$setter_tag\E $ /gsmx && do {
                    my ( $static_method, $argument ) = split( ':', $tag );
                    if( bless( {}, $class )->can($static_method) ) {
                        $class->$static_method($argument);
                    }
                };
            }
        }

        @tags = grep { !exists( $non_import_flags{$_} ) } @tags;
        return Exporter::import(@tags);
    }

    ############################################################################################
    ## Create a new instance of this class; should not require overloading in derived classes.
    ############################################################################################
    sub new
    {
        my ( $proto, @opts ) = @_;

        ## support either ...( foo => 'bar' ); or ...( { foo => 'bar' } );
        my %opts =
            ( @opts == 1 ) ? ( ( ref( $opts[0] ) eq 'HASH' ) ? %{ $opts[0] } : () )
          : ( scalar @opts % 2 == 0 ) ? @opts
          :                             confess('Invalid number or type of arguments to constructor');

        my $class = ref($proto) || $proto;
        my $self = {};

        # obtain the @ISA for whomever inherited us
        no strict 'refs';
        @{ $self->{____CLASS_ISA} } = @{ $class . '::ISA' };
        use strict 'refs';

        #for my $parent_class ( @{ $self->{____CLASS_ISA} } ) {
        #    bless( $self, $parent_class );
        #}

        bless( $self, $class ); ## Bless so we can call _all_isa
        for my $parent_class ( $self->_all_isa() ) {
            bless( $self, $parent_class );
        }
        bless( $self, $class ); ## Bless back into this class last so we deref correctly
        $self = $self->____initialize_object(%opts);

        return $self;
    }

    ############################################################################################
    ## Get an immutable copy of the underlying data
    ############################################################################################
    sub get(@)
    {
        my ( $self, $field ) = @_;

        $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->self($self);
        return $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->value();
    }

    ############################################################################################
    ## Set (and validate) an immutable copy, return the validated data.
    ############################################################################################
    sub set(@)    ## no critic (AmbiguousNames)
    {
        my ( $self, $field, @values ) = @_;

        $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->self($self);
        return $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->value(@values);
    }

    ############################################################################################
    ## return true if the value has been set before (even if set to undef)
    ############################################################################################
    sub is_set(@)
    {
        ## use critic
        my ( $self, $field ) = @_;

        $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->self($self);
        ### Accessors uses -1, 0, and 1, but we make this boolean for Class
        return ( $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->is_set() > 0 );
    }

    ############################################################################################
    ## emit an error
    ############################################################################################
    sub error(@)
    {
        my ( $self, @msgs ) = @_;

        return $self->_emit( 'ERROR', OOP_PERLISH_CLASS_EMITLEVEL_ERROR, @msgs );
    }

    ############################################################################################
    ## emit a warning
    ############################################################################################
    sub warning(@)
    {
        my ( $self, @msgs ) = @_;

        return $self->_emit( 'WARNING', OOP_PERLISH_CLASS_EMITLEVEL_WARNING, @msgs );
    }

    ############################################################################################
    ## emit info
    ############################################################################################
    sub info(@)
    {
        my ( $self, @msgs ) = @_;

        return $self->_emit( 'INFO', OOP_PERLISH_CLASS_EMITLEVEL_INFO, @msgs );
    }

    ############################################################################################
    ## emit something verbose
    ############################################################################################
    sub verbose(@)
    {
        my ( $self, @msgs ) = @_;

        return $self->_emit( 'VERBOSE', OOP_PERLISH_CLASS_EMITLEVEL_VERBOSE, @msgs );
    }

    ############################################################################################
    ## emit debugging info
    ############################################################################################
    sub debug(@)
    {
        my ( $self, @msgs ) = @_;

        return $self->_emit( 'DEBUG0', OOP_PERLISH_CLASS_EMITLEVEL_DEBUG0, @msgs );
    }

    ############################################################################################
    ## emit more obscure debugging info
    ############################################################################################
    sub debug1(@)
    {
        my ( $self, @msgs ) = @_;

        return $self->_emit( 'DEBUG1', OOP_PERLISH_CLASS_EMITLEVEL_DEBUG1, @msgs );
    }

    ############################################################################################
    ## emit the most obscure debugging info
    ############################################################################################
    sub debug2(@)
    {
        my ( $self, @msgs ) = @_;

        return $self->_emit( 'DEBUG2', OOP_PERLISH_CLASS_EMITLEVEL_DEBUG2, @msgs );
    }

    ############################################################################################
    ## croak with the specified message
    ############################################################################################
    sub fatal(@)
    {
        my ( $self, @msgs ) = @_;

        if( $self->_emitlevel() >= OOP_PERLISH_CLASS_EMITLEVEL_FATAL ) {
            croak( map { my $l = defined($_) ? $_ : 'undef'; chomp($l); $l =~ s/^/FATAL: /gms; $l . $/ } @msgs );
        }
        return;
    }

    ############################################################################################
    ## Stub of a _preinit; note that init must return true or object initialization will fail
    ## This method does object initialization _before_ accessors have been set
    ############################################################################################
    sub _preinit(@) {
        my ($self, @args) = @_;
        $self->_all_SUPER('_preinit', @args);
        return 1;
    }

    ############################################################################################
    ## Stub of an _init; note that init must return true or object initialization will fail
    ## This method does object initialization _after_ accessors have been set
    ############################################################################################
    sub _init(@) {
        my ($self, @args) = @_;
        $self->_all_SUPER('_init', @args);
        return 1;
    }

    ############################################################################################
    ## name of the class which we use for accessors; overload if you want to use a different
    ## class
    ############################################################################################
    sub _accessor_class_name(@)
    {
        my ($self) = @_;
        return qw(OOP::Perlish::Class::Accessor);
    }

    ############################################################################################
    ## emit error, warning, info, verbose, debug, debug1, and debug2 messages; overload to
    ## change the way you emit
    ############################################################################################
    sub _emit(@)
    {
        my ( $self, $prefix, $level, @msgs ) = @_;

        if(@msgs) {
            if( $self->_emitlevel() >= $level ) {
                STDERR->print( map { my $l = defined($_) ? $_ : 'undef'; chomp($l); $l =~ s/^/$prefix: /gms; $l . $/ } @msgs );
            }
            push( @{ $self->{ '___' . $prefix } }, @msgs );
        }
        else {
            return @{ $self->{ '___' . $prefix } };
        }
        return;
    }

    ############################################################################################
    ## return a list of all methods that this object ->can() in order of:
    ## (
    ##   methods defined in furthest-ancestors,
    ##   methods defined nearer-ancestors
    ##   methods defined in this-class
    ## )
    ## now memoized, as this becomes a substantial performance hit otherwise.
    ############################################################################################
    sub _all_methods(@)
    {
        my ( $self, $class ) = @_;
        $class ||= ref($self) || $self;

        our %____oop_perlish_class_all_methods;

        unless(exists($____oop_perlish_class_all_methods{$class})) {
            my %all_methods = ();

            ### preserve order so that methods defined in hiarchies are preserved in the order they
            ### occur
            tie %all_methods, q(Tie::IxHash);

            for my $parent_class ( $self->_all_isa($class) ) {
                no strict 'refs';
                for my $symbol ( keys %{ '::' . $parent_class . '::' } ) {
                    $all_methods{$symbol} = 1 if( bless( {}, $class )->can($symbol) );
                }
                use strict 'refs';
            }

            ### Reverse the order of methods found, so that for meta-programming iteration, we run
            ### the methods defined in top-level derived classes last (so they can override
            ### inherited methods return values and such)
            $____oop_perlish_class_all_methods{$class} = [ reverse keys %all_methods ];
        }

        return( @{ $____oop_perlish_class_all_methods{$class} } );
    }

    ############################################################################################
    ## return a list of all-classes that we derive from, in order of:
    ## (
    ##   self
    ##   parents
    ##   parents of parents
    ##   <...>
    ##   furthest-ancestor
    ## )
    ############################################################################################
    sub _all_isa(@)
    {
        my ( $self, $class ) = @_;
        $class ||= ref($self) || $self;

        $self->{____isa_hash} = {} unless( exists( $self->{____isa_hash} ) );
        tie %{ $self->{____isa_hash}->{$class} }, q(Tie::IxHash)
          unless( exists( $self->{____isa_hash}->{$class} ) && defined( $self->{____isa_hash}->{$class} ) );

        $self->____recurse_isa($class);

        return keys %{ $self->{____isa_hash}->{$class} };
    }


    ############################################################################################
    ## run a method in all immediate members of @ISA
    ############################################################################################
    sub _all_SUPER
    {
        my ($self, $method, @args) = @_;
        my $root_class = __PACKAGE__;

        for my $parent_class ( grep { !/^\Q$root_class\E$/ } @{ $self->{____CLASS_ISA} } ) {
            if($parent_class->can($method)) {
                no strict 'refs';
                my $sub = *{ $parent_class . '::' . $method };
                use strict;
                if(*{ $sub }{CODE}) {
                    $sub->($self, @args);
                }
            }
        }
    }


    ############################################################################################
    ## DO NOT USE UNLESS YOU KNOW WHAT YOU ARE DOING!
    ############################################################################################
    ## Returns a reference to underlying storage; bypassing validation, untainting, etc.
    ############################################################################################
    sub _get_mutable_reference(@)
    {
        my ( $self, $name ) = @_;

        if( $self->can($name) ) {
            $self->$name();                               ### Do some internal plumbing to make sure that a reference exists if it can exist.
            return $self->{___fields}->{$name}->{_Value}; ### should always be a reference to something if it exists
        }
    }

    ############################################################################################
    ## Set per-instance emit-level via accessor, or per-class emit-level via static
    ############################################################################################
    sub _emitlevel(@)
    {
        my ( $self, $level ) = @_;
        my $class = ref($self) || $self;

        no strict 'refs';
        my $instance_storage = \$self->{___fields}->{'_emitlevel'}->{_Value} if( ref($self) );
        my $class_storage = \${ '::' . $class . '::_OOP_PERLISH_CLASS_EMITLEVEL' };
        use strict;

        my $storage = ( ref($self) ) ? $instance_storage : $class_storage;

        if($level) {
            $level =~ m/\D/ && do {
                my %level_map = (
                                  'fatal'   => OOP_PERLISH_CLASS_EMITLEVEL_FATAL,
                                  'error'   => OOP_PERLISH_CLASS_EMITLEVEL_ERROR,
                                  'warning' => OOP_PERLISH_CLASS_EMITLEVEL_WARNING,
                                  'info'    => OOP_PERLISH_CLASS_EMITLEVEL_INFO,
                                  'verbose' => OOP_PERLISH_CLASS_EMITLEVEL_VERBOSE,
                                  'debug'   => OOP_PERLISH_CLASS_EMITLEVEL_DEBUG0,
                                  'debug1'  => OOP_PERLISH_CLASS_EMITLEVEL_DEBUG1,
                                  'debug2'  => OOP_PERLISH_CLASS_EMITLEVEL_DEBUG2
                                );
                if( exists( $level_map{ lc($level) } ) ) {
                    $level = $level_map{ lc($level) };
                }
                else {
                    $self->error('invalid level set; cannot set emitlevel');
                }
            };

            return unless( $level =~ m/^\d+$/ );
            ${$storage} = $level;
        }
        $level = ${$storage} || ${$class_storage} || $main::_OOP_PERLISH_CLASS_EMITLEVEL || 0;

        return $level;
    }

    ############################################################################################
    ## set accessors, usually called like 'BEGIN { __PACKAGE__->_accessor(...) }' as the first
    ## section of any derived class.
    ############################################################################################
    sub _accessors(@)
    {
        my ( $self, %accessors ) = @_;

        my $class = ref($self) || $self;

        my $accessor_class = $self->_accessor_class_name();

        for my $field ( keys %accessors ) {
            my %opts = %{ $accessors{$field} };

            $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field} = $accessor_class->new( %opts, name => $field );

            ### Symbol table manipulation; creates a method named for the $field in the package's namespace
            ### The actual method is created via closure in ____oop_perlish_class_accessor_factory();
            no strict 'refs';
            *{ '::' . $class . '::' . $field } = $self->____oop_perlish_class_accessor_factory($field);
            use strict;
        }

        return;
    }

    ############################################################################################
    ## Handle the magic constuctor argument
    ## '_____oop_perlish_class__defer__required__fields__validation', set the key value pair
    ## 'defer_required_fields' to when we see that arg passed to a constructor (and its true)
    ############################################################################################
    #sub _magic_constructor_arg_handler_defer_required(@)
    #{
    #    my ( $self, $opts ) = @_;
    #
    #    my $key = 'defer_required_fields';
    #    my $defer_required_fields;
    #
    #    if( exists( $opts->{_____oop_perlish_class__defer__required__fields__validation} ) ) {
    #        $defer_required_fields = $opts->{_____oop_perlish_class__defer__required__fields__validation};
    #        delete $opts->{_____oop_perlish_class__defer__required__fields__validation};
    #    }
    #    return ( $key, $defer_required_fields );
    #}

    ############################################################################################
    ## List all classes which are derived from a given base class (or the class $self was
    ## instanced from)
    ############################################################################################
    sub _derived_classes
    {
        my ($self) = @_;
        my $class = ref($self) || $self;

        my @derived_classes =
          grep { bless( {}, $_ )->isa($class) && $_ ne $class } keys %{ $self->____OOP_PERLISH_CLASS_DERIVED_CLASSES() };

        return (@derived_classes);
    }

    ############################################################################################
    ## return an accessor subroutine reference
    ############################################################################################
    sub ____oop_perlish_class_accessor_factory(@)
    {
        my ( $class, $key ) = @_;

        return sub {
            my ( $self, @values ) = @_;

            return $self->set( $key, @values ) if(@values);
            return $self->get($key);
        };
    }

    ############################################################################################
    ## recurse @ISA of every class we inherit from
    ############################################################################################
    sub ____recurse_isa(@)
    {
        my ( $self, $class, @traverse_isa ) = @_;
        unshift( @traverse_isa, $class );

        my @parent_isa = ();

        for my $parent_class ( grep { !exists( $self->{____isa_hash}->{$class}->{$_} ) } @traverse_isa ) {
            $self->{____isa_hash}->{$class}->{$parent_class} = 1;
            push( @parent_isa, $parent_class );
            no strict 'refs';
            push( @parent_isa, $self->____recurse_isa( $class, @{ $parent_class . '::ISA' } ) );
            use strict 'refs';
        }

        return @parent_isa;
    }

    ############################################################################################
    ## return a static reference to a hash of accessors for this class; must work for all
    ## derived classes
    ############################################################################################
    sub ____OOP_PERLISH_CLASS_ACCESSORS
    {
        my ($self) = @_;
        my $class = ref($self) || $self;
        our $____OOP_PERLISH_CLASS_ACCESSORS;

        $____OOP_PERLISH_CLASS_ACCESSORS = {} unless( defined($____OOP_PERLISH_CLASS_ACCESSORS) );
        $____OOP_PERLISH_CLASS_ACCESSORS->{$class} = {} unless( exists( $____OOP_PERLISH_CLASS_ACCESSORS->{$class} ) );

        return $____OOP_PERLISH_CLASS_ACCESSORS->{$class};
    }

    ############################################################################################
    ## Keep a list of all classes that derive from OOP::Perlish::Class; used in the utility
    ## method '_derived_classes' to return all children of a given class.
    ############################################################################################
    sub ____OOP_PERLISH_CLASS_DERIVED_CLASSES
    {
        my ($self) = @_;
        our $____OOP_PERLISH_CLASS_DERIVED_CLASSES;
        $____OOP_PERLISH_CLASS_DERIVED_CLASSES = {} unless( defined($____OOP_PERLISH_CLASS_DERIVED_CLASSES) );

        return $____OOP_PERLISH_CLASS_DERIVED_CLASSES;
    }

    ############################################################################################
    ## return a static reference to an array of required fields for this class; must work for
    ## all derived classes
    ############################################################################################
    sub ____OOP_PERLISH_CLASS_REQUIRED_FIELDS
    {
        my ($self) = @_;
        my $class = ref($self) || $self;
        our $____OOP_PERLISH_CLASS_REQUIRED_FIELDS;

        $____OOP_PERLISH_CLASS_REQUIRED_FIELDS = {} unless( defined($____OOP_PERLISH_CLASS_REQUIRED_FIELDS) );
        $____OOP_PERLISH_CLASS_REQUIRED_FIELDS->{$class} = [] unless( exists( $____OOP_PERLISH_CLASS_REQUIRED_FIELDS->{$class} ) );

        return $____OOP_PERLISH_CLASS_REQUIRED_FIELDS->{$class};
    }

    ############################################################################################
    ## object construction, typically it shouldn't be necessary to overload this directly,
    ## instead overload one or more of the things it calls
    ############################################################################################
    sub ____initialize_object(@)
    {
        my ( $self, %opts ) = @_;

        my %magic = $self->____process_magic_arguments( \%opts );
        if( exists( $magic{'return'} ) ) {
            my @ret = @{ $magic{'return'} };
            return @ret if( scalar @ret > 1 );
            return ( $ret[0] );
        }

        ### Grab our version of %opts from $self->{____oop_perlish_class_opts}, or initialize it if its not been set.
        %{ $self->{____oop_perlish_class_opts} } = %opts;

        $self->____inherit_accessors();
        $self->____pre_validate_opts(); #unless( $magic{defer_required_fields} );
        ### XXX: unnessessary, and annoying XXX $self->____inherit_constructed_refs();
        ### XXX: Might want to make a for (@ISA) { $_::_init(@_); } or similar for multiple_inheritance considerations.
        $self->____initialize_required_fields();# unless( $magic{defer_required_fields} );
        return unless( $self->_preinit() );
        $self->____initialize_non_required_fields();
        return unless( $self->_init() );
        $self->{__initialized} = 1; # unless($magic{defer_required_fields});

        return $self;
    }

    ############################################################################################
    ## Run any method named _magic_constructor_arg_handler* and collect its return tuple into a
    ## hash called %magic which will be referenced in ____initialize_object; or may mutate
    ## $self, or do any of a dozen other things.
    ##
    ## The key 'return' is considered magical and sacred; if you return in your tuple
    ## 'return => foo' the constructor will immediately, and before any other initialization
    ## completes, return the thing you said to return; usually a blessed reference to something;
    ## be it a singleton, multiton, another object, acme-time-bomb ala wiley coyote, etc.
    ##
    ## Your method will be passed a reference to the options passed to the constructor; and may
    ## (usually should) delete the magical key you are interested in, so that it is not
    ## considered an accessor later.
    ##
    ## This could have been done via attributes, but then it suffers from all the annoyances of
    ## having to be seen prior to CHECK blocks running, yada yada...
    ############################################################################################
    sub ____process_magic_arguments(@)
    {
        my ( $self, $opts ) = @_;

        my %magic = ();

        for( $self->_all_methods() ) {
            m/^_magic_constructor_arg_handler/ && do {
                my $method = $_;
                my ( $key, $value ) = $self->$method($opts);
                $magic{$key} = $value if( $key && $value );
            };
        }

        return %magic;
    }

    ############################################################################################
    ## verify that we have our required fields, even if they don't have real values but have
    ## defaults instead (a default AND required field would be odd, but is supported)
    ############################################################################################
    sub ____pre_validate_opts(@)
    {
        my ($self) = @_;

        my @required_fields = $self->____identify_required_fields();

        for(@required_fields) {
            confess("Missing required field $_")
              unless(
                      exists( $self->{____oop_perlish_class_opts}->{$_} )
                      || ( exists( $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$_} )
                           && $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$_}->default_is_set() )
                    );
        }
        return;
    }

    ############################################################################################
    ## obtain the names and references to every accessor in our inheritance
    ############################################################################################
    sub ____inherit_accessors(@)
    {
        my ($self) = @_;

        ### Protect overloaded accessors by identifying those in our top-level namespace
        ### This cascaded up through the inheritance tree
        my %top_accessors = ();
        if( scalar( keys %{ $self->____OOP_PERLISH_CLASS_ACCESSORS() } ) ) {
            # XXX: Hash slice assignment
            @top_accessors{ keys %{ $self->____OOP_PERLISH_CLASS_ACCESSORS() } } =
              ( (1) x ( ( scalar keys %{ $self->____OOP_PERLISH_CLASS_ACCESSORS() } ) ) );
        }

        ### Assimilate inherited accessor references
        #for my $parent_class ( @{ $self->{____CLASS_ISA} } ) {
        for my $parent_class ( $self->_all_isa() ) {
            if( $parent_class && bless( {}, $parent_class )->can('____OOP_PERLISH_CLASS_ACCESSORS') ) {
                while( my ( $k, $v ) = each %{ $parent_class->____OOP_PERLISH_CLASS_ACCESSORS() } ) {
                    $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$k} = $v unless( exists( $top_accessors{$k} ) );    #protect overloading
                }
            }
        }
        return;
    }

    ############################################################################################
    ## run constructors of every class we derive from, and assimilate their %{ $self } hash into
    ## our own.
    ############################################################################################
    ## FIXME: We only support deriving from blessed-hashref classes.
    ############################################################################################
    sub ____inherit_constructed_refs
    {
        my ($self) = @_;

        for my $parent_class ( @{ $self->{____CLASS_ISA} } ) {
            next if( $parent_class eq __PACKAGE__ );
            my $tclass = bless( {}, $parent_class );
            my $this;
            if( $tclass->isa(__PACKAGE__) ) {
                $this = $parent_class->new( _____oop_perlish_class__defer__required__fields__validation => 1 );
            }
            elsif( $tclass->can('new') ) {
                $this = $parent_class->new();
            }
            ### FIXME: cleanly handle non-hashref ancestors...
            if( $this && $this->isa('HASH') ) {
                while( my ( $key, $val ) = each %{$this} ) {
                    $self->{$key} = $val unless( exists( $self->{$key} ) );
                }
                if( exists( $this->{___fields} ) ) {
                    while( my ( $key, $val ) = each %{ $this->{___fields} } ) {
                        $self->$key( $val->{_Value} ) unless( exists( $self->{___fields}->{$key} ) );
                    }
                }
            }
        }
        return;
    }

    ############################################################################################
    ## figure out what fields are required for all derived ancestor classes and ourself.
    ############################################################################################
    sub ____identify_required_fields(@)
    {
        my ($self) = @_;

        my $class = ref($self) || $self;

        if( !defined( $self->{____oop_perlish_class_required_fields} ) ) {
            my %required_fields = ();

            ### Obtain REQUIRED_FIELDS static from derived class. Assign it via hashslice
            @required_fields{ @{ $class->____OOP_PERLISH_CLASS_REQUIRED_FIELDS() } } = @{ $class->____OOP_PERLISH_CLASS_REQUIRED_FIELDS() };

            while( my ( $name, $field ) = each %{ $self->____OOP_PERLISH_CLASS_ACCESSORS() } ) {
                $required_fields{$name} = $name if( $field->required() );
            }

            # FIXME: Does not cascade beyond @ISA, should traverse inheritance tree and ensure that all required fields are
            # provided for any hiararchy. ... does cascade via new, but only to ancesters who conform with us. unsure how to fix
            #for my $parent_class ( @{ $self->{____CLASS_ISA} } ) {
            for my $parent_class ( $self->_all_isa() ) {
                if( bless( {}, $parent_class )->can('____OOP_PERLISH_CLASS_REQUIRED_FIELDS') ) {
                    @required_fields{ @{ $parent_class->____OOP_PERLISH_CLASS_REQUIRED_FIELDS() } } =
                      @{ $parent_class->____OOP_PERLISH_CLASS_REQUIRED_FIELDS() };
                }
            }

            @{ $self->{____oop_perlish_class_required_fields} } = keys %required_fields;
        }
        return @{ $self->{____oop_perlish_class_required_fields} };
    }

    ############################################################################################
    ## setup required fields, using their accessors
    ############################################################################################
    sub ____initialize_required_fields(@)
    {
        my ($self) = @_;

        my @required_fields = $self->____identify_required_fields();

        for my $method (@required_fields) {
            $self->$method( $self->{____oop_perlish_class_opts}->{$method} )
              if( exists( $self->{____oop_perlish_class_opts}->{$method} ) && defined( $self->{____oop_perlish_class_opts}->{$method} ) );
            croak("Invalid required attribute for $method") unless( $self->$method() || $self->is_set($method) );
        }
        return;
    }

    ############################################################################################
    ## setup non-required-fields, using their accessors
    ############################################################################################
    sub ____initialize_non_required_fields(@)
    {
        my ($self) = @_;

        ### XXX: Hash slice assignment
        my %required_fields_lut;
        @required_fields_lut{ $self->____identify_required_fields() } = $self->____identify_required_fields();

        my %opts =
          map { ( $_ => $self->{____oop_perlish_class_opts}->{$_} ) }
          grep { !exists( $required_fields_lut{$_} ) } keys %{ $self->{____oop_perlish_class_opts} };

        # prepopulate accessors so that calls that cascade will have values assigned
        # Set everything by accessor that we ->can()
        while( my ( $method, $value ) = each %opts ) {
            $self->$method($value) if( $self->can($method) );
        }

        $self->____validate_defaults();

        # reset all accessors for actually set values, re-running cascades where applicable...
        # there must be a better way, but this works
        while( my ( $method, $value ) = each %opts ) {
            $self->$method($value) if( $self->can($method) );
        }
        return;
    }

    ############################################################################################
    ## verify all default values are valid for the class
    ############################################################################################
    ## FIXME: make this static
    ############################################################################################
    sub ____validate_defaults(@)
    {
        my ($self) = @_;

        for my $field ( keys %{ $self->____OOP_PERLISH_CLASS_ACCESSORS() } ) {
            $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->self($self);
            $self->____OOP_PERLISH_CLASS_ACCESSORS()->{$field}->__validate_default();
        }
        return;
    }
}
1;
__END__