view release on metacpan or  search on metacpan

lib/OOP/Perlish/Class.pm  view on Meta::CPAN

    ## $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__

=head1 NAME

OOP::Perlish::Class - A Base class implementation providing the fundimental infrastructure for perl OOP

=head1 DESCRIPTION

A Base class for creating Objects that conform to all common OOP practices, while still remaining very much perl.

=head2 Currently supported:

=over

=item Multiple-Inheritance

=item Mix-in

=item Meta-programming (class introspection; quite useful with mix-ins) 

=item Generational Inheritance (complex hiarchies of inheritance)

=item method overriding/overloading

=item operator overriding/overloading

=item Accessor validation

=item accessor cascading via validator subroutine

=item singletons

=item multitons (aka: multi-singletons, keyed singletons, named singletons, singleton-maps)

=item polymorphism (aka duck-typing for ruby folks)