view release on metacpan or  search on metacpan

lib/Bio/Biblio/BiblioBase.pm  view on Meta::CPAN

package Bio::Biblio::BiblioBase;
BEGIN {
  $Bio::Biblio::BiblioBase::AUTHORITY = 'cpan:BIOPERLML';
}
{
  $Bio::Biblio::BiblioBase::VERSION = '1.70';
}
use utf8;
use strict;
use warnings;

use parent qw(Bio::Root::Root);

# ABSTRACT: an abstract base for other biblio classes
# AUTHOR:   Martin Senger <senger@ebi.ac.uk>
# OWNER:    2002 European Bioinformatics Institute
# LICENSE:  Perl_5


our $AUTOLOAD;


sub _accessible { shift->throw_not_implemented(); }


sub _attr_type { shift->throw_not_implemented(); }


sub AUTOLOAD {
    my ($self, $newval) = @_;
    if ($AUTOLOAD =~ /.*::(\w+)/ && $self->_accessible ("_$1")) {
        my $attr_name = "_$1";
        my $attr_type = $self->_attr_type ($attr_name);
        my $ref_sub =
            sub {
                my ($this, $new_value) = @_;
                return $this->{$attr_name} unless defined $new_value;

                # here we continue with 'set' method
                my ($newval_type) = ref ($new_value) || 'string';
                my ($expected_type) = $attr_type || 'string';
#               $this->throw ("In method $AUTOLOAD, trying to set a value of type '$newval_type' but '$expected_type' is expected.")
                $this->throw ($this->_wrong_type_msg ($newval_type, $expected_type, $AUTOLOAD))
                    unless ($newval_type eq $expected_type) or
                      UNIVERSAL::isa ($new_value, $expected_type);

                $this->{$attr_name} = $new_value;
                return $new_value;
            };

        no strict 'refs';
        *{$AUTOLOAD} = $ref_sub;
        use strict 'refs';
        return $ref_sub->($self, $newval);
    }

    $self->throw ("No such method: $AUTOLOAD");
}


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

    # create and bless a new instance
    my ($self) = $class->SUPER::new (@args);

    # make a hashtable from @args
    my %param = @args;
    @param { map { lc $_ } keys %param } = values %param; # lowercase keys

    # set all @args into this object with 'set' values;
    # change '-key' into '_key', and making keys lowercase
    my $new_key;
    foreach my $key (keys %param) {
        ($new_key = $key) =~ s/-/_/og;   # change it everywhere, why not
        my $method = lc (substr ($new_key, 1));   # omitting the first '_'
        no strict 'refs';
        $method->($self, $param { $key });
    }

    # done
    return $self;
}