Bio::Phylo::Matrices::TypeSafeData - Superclass for objects that contain

 # No direct usage

 $Id: TypeSafeData.pm 1660 2011-04-02 18:29:40Z rvos $

# $Id: TypeSafeData.pm 1660 2011-04-02 18:29:40Z rvos $
package Bio::Phylo::Matrices::TypeSafeData;
use strict;
use base 'Bio::Phylo::Listable';
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::CONSTANT qw'_MATRIX_ /looks_like/';
use Bio::Phylo::Matrices::Datatype;
{
    my $logger = __PACKAGE__->get_logger;
    my %type;
    my $MATRIX_CONSTANT = _MATRIX_;

    sub new {

        # is child class
        my $class = shift;

        # process args
        my %args = looks_like_hash @_;

        # notify user
        if ( not $args{'-type'} and not $args{'-type_object'} ) {
            $logger->info("No data type provided, will use 'standard'");
            unshift @_, '-type', 'standard';
        }
        if ( $args{'-characters'} ) {
            if ( $args{'-type'} ) {
                $args{'-characters'}->set_type( $args{'-type'} );
            }
            elsif ( $args{'-type_object'} ) {
                $args{'-characters'}->set_type_object( $args{'-type_object'} );
            }
        }

        # notify user
        $logger->debug("constructor called for '$class'");

        # go up inheritance tree, eventually get an ID
        return $class->SUPER::new(@_);
    }

    sub set_type {
        my $self = shift;
        my $arg  = shift;
        my ( $type, @args );
        if ( looks_like_instance( $arg, 'ARRAY' ) ) {
            @args = @{$arg};
            $type = shift @args;
        }
        else {
            @args = @_;
            $type = $arg;
        }
        $logger->info("setting type '$type'");
        my $obj = Bio::Phylo::Matrices::Datatype->new( $type, @args );
        $self->set_type_object($obj);
        eval { looks_like_object $self, $MATRIX_CONSTANT };
        if ( not $@ ) {
            for my $row ( @{ $self->get_entities } ) {
                $row->set_type_object($obj);
            }
        }
        else {
            undef($@);
        }
        return $self;
    }

    sub set_missing {
        my ( $self, $missing ) = @_;
        if ( $self->can('get_matchchar') and $missing eq $self->get_matchchar )
        {
            throw 'BadArgs' =>
              "Missing character '$missing' already in use as match character";
        }
        $logger->info("setting missing '$missing'");
        $self->get_type_object->set_missing($missing);
        $self->validate;
        return $self;
    }

    sub set_gap {
        my ( $self, $gap ) = @_;
        if ( $self->can('get_matchchar') and $gap eq $self->get_matchchar ) {
            throw 'BadArgs' =>
              "Gap character '$gap' already in use as match character";
        }
        $logger->info("setting gap '$gap'");
        $self->get_type_object->set_gap($gap);
        $self->validate;
        return $self;
    }

    sub set_lookup {
        my ( $self, $lookup ) = @_;
        $logger->info("setting character state lookup hash");
        $self->get_type_object->set_lookup($lookup);
        $self->validate;
        return $self;
    }

    sub set_type_object {
        my ( $self, $obj ) = @_;
        $logger->info("setting character type object");
        $type{ $self->get_id } = $obj;
        eval { $self->validate };
        if ($@) {
            undef($@);
            if ( my @char = $self->get_char ) {
                $self->clear;
                $logger->warn(
"Data contents of $self were invalidated by new type object."
                );
            }
        }
        return $self;
    }

    sub get_type {
        my $to = shift->get_type_object;
        if ($to) {
            return $to->get_type;
        }
        else {
            throw 'API' => "Missing data type object!";
        }
    }

    sub get_missing {
        my $to = shift->get_type_object;
        if ($to) {
            return $to->get_missing;
        }
        else {
            throw 'API' => "Missing data type object!";
        }
    }

    sub get_gap { shift->get_type_object->get_gap }

    sub get_lookup { shift->get_type_object->get_lookup }

    sub get_type_object { $type{ $_[0]->get_id } }

    sub clone {
        my $self = shift;
        $logger->info("cloning $self");
        my %subs = @_;

        # we'll create type object during construction
        $subs{'set_type'}    = 0;
        $subs{'set_missing'} = 0;
        $subs{'set_gap'}     = 0;
        $subs{'set_lookup'}  = 0;

        # we'll override this, the type object is created from scratch
        $subs{'set_type_object'} = 0;

        # this will create type object during construction
        $subs{'new'} = [
            '-type'    => $self->get_type,
            '-missing' => $self->get_missing,
            '-gap'     => $self->get_gap,
            '-lookup'  => $self->get_lookup,
        ];
        return $self->SUPER::clone(%subs);
    }

    sub validate {
        shift->_validate;
    }

    sub _validate {
        throw 'NotImplemented' => 'Not implemented!';
    }

    sub _cleanup {
        my $self = shift;
        if ( $self and defined( my $id = $self->get_id ) ) {
            $logger->debug("cleaning up '$self'");
            delete $type{ $self->get_id };
        }
    }
}

# podinherit_insert_token

1;