3.11 Gene.pm: A Fourth Example of a Perl Class

We've now come to the fourth and final version of the Gene class, Gene.pm . This final version adds a few more bells and whistles to make the code more reliable and useful. You'll see how to define the class attributes in such a way as to specify the operations that are permitted on them, thus enforcing more discipline in how the class can be used. You'll also see how to initialize an object with class defaults or clone an already existing object. You'll see the standard and simple way in which the documentation for a class can be incorporated into the .pm file. This will conclude my introduction to OO Perl programming (but check out the exercises at the end of the chapter and see later chapters of this book for more ideas).

3.11.1 Building Gene.pm

Here then is the code for Gene.pm . Again, I recommend that you take the time to read this code and compare it to the previous version, Gene3.pm , before continuing with the discussion that follows :

package Gene;

#
# A fourth and final version of the Gene.pm class
#

use strict;
use warnings;
our $AUTOLOAD; # before Perl 5.6.0 say "use vars '$AUTOLOAD';"
use Carp;

# Class data and methods
{
    # A list of all attributes with default values and read/write/required properties
    my %_attribute_properties = (
        _name        => [ '????',        'read.required'],
        _organism    => [ '????',        'read.required'],
        _chromosome  => [ '????',        'read.write'],
        _pdbref      => [ '????',        'read.write'],
        _author      => [ '????',        'read.write'],
        _date        => [ '????',        'read.write'],
    );
        
    # Global variable to keep count of existing objects
    my $_count = 0;

    # Return a list of all attributes
    sub _all_attributes {
            keys %_attribute_properties;
    }

    # Check if a given property is set for a given attribute
    sub _permissions {
        my($self, $attribute, $permissions) = @_;
        $_attribute_properties{$attribute}[1] =~ /$permissions/;
    }

    # Return the default value for a given attribute
    sub _attribute_default {
            my($self, $attribute) = @_;
        $_attribute_properties{$attribute}[0];
    }

    # Manage the count of existing objects
    sub get_count {
        $_count;
    }
    sub _incr_count {
        ++$_count;
    }
    sub _decr_count {
        --$_count;
    }
}

# The constructor method
# Called from class, e.g. $obj = Gene->new(  );
sub new {
    my ($class, %arg) = @_;
    # Create a new object
    my $self = bless {  }, $class;

    foreach my $attribute ($self->_all_attributes(  )) {
        # E.g. attribute = "_name",  argument = "name"
        my($argument) = ($attribute =~ /^_(.*)/);
        # If explicitly given
        if (exists $arg{$argument}) {
            $self->{$attribute} = $arg{$argument};
        # If not given, but required
        }elsif($self->_permissions($attribute, 'required')) {
            croak("No $argument attribute as required");
        # Set to the default
        }else{
            $self->{$attribute} = $self->_attribute_default($attribute);
        }
    }
    $class->_incr_count(  );
    return $self;
}

# The clone method
# All attributes will be copied from the calling object, unless
# specifically overridden
# Called from an exisiting object, e.g. $cloned_obj = $obj1->clone(  );
sub clone {
    my ($caller, %arg) = @_;
    # Extract the class name from the calling object
    my $class = ref($caller);
    # Create a new object
    my $self = bless {  }, $class;

    foreach my $attribute ($self->_all_attributes(  )) {
        # E.g. attribute = "_name",  argument = "name"
        my($argument) = ($attribute =~ /^_(.*)/);
        # If explicitly given
        if (exists $arg{$argument}) {
            $self->{$attribute} = $arg{$argument};
        # Otherwise copy attribute of new object from the calling object
        }else{
            $self->{$attribute} = $caller->{$attribute};
        }
    }
    $self->_incr_count(  );
    return $self;
}

# This takes the place of such accessor definitions as:
#  sub get_attribute { ... }
# and of such mutator definitions as:
#  sub set_attribute { ... }
sub AUTOLOAD {
    my ($self, $newvalue) = @_;

    my ($operation, $attribute) = ($AUTOLOAD =~ /(getset)(_\w+)$/);
    
    # Is this a legal method name?
    unless($operation && $attribute) {
        croak "Method name $AUTOLOAD is not in the recognized form (getset)_
attribute\n";
    }
    unless(exists $self->{$attribute}) {
        croak "No such attribute $attribute exists in the class ", ref($self);
    }

    # Turn off strict references to enable "magic" AUTOLOAD speedup
    no strict 'refs';

    # AUTOLOAD accessors
    if($operation eq 'get') {

        # Complain if you can't get the attribute
        unless($self->_permissions($attribute, 'read')) {
            croak "$attribute does not have read permission";
        }

        # Install this accessor definition in the symbol table
        *{$AUTOLOAD} = sub {
            my ($self) = @_;
            unless($self->_permissions($attribute, 'read')) {
                croak "$attribute does not have read permission";
            }
            $self->{$attribute};
        };

    # AUTOLOAD mutators
    }elsif($operation eq 'set') {

        # Complain if you can't set the attribute
        unless($self->_permissions($attribute, 'write')) {
            croak "$attribute does not have write permission";
        }

        # Set the attribute value
        $self->{$attribute} = $newvalue;

        # Install this mutator definition in the symbol table
        *{$AUTOLOAD} = sub {
               my ($self, $newvalue) = @_;
            unless($self->_permissions($attribute, 'write')) {
                croak "$attribute does not have write permission";
            }
            $self->{$attribute} = $newvalue;
        };
    }

    # Turn strict references back on
    use strict 'refs';

    # Return the attribute value
    return $self->{$attribute};
}

# When an object is no longer being used, this will be automatically called
# and will adjust the count of existing objects
sub DESTROY {
    my($self) = @_;
    $self->_decr_count(  );
}

# Other methods.  They do not fall into the same form as the majority handled by 
AUTOLOAD
sub citation {
    my ($self, $author, $date) = @_;
    $self->{_author} = set_author($author) if $author;
    $self->{_date} = set_date($date) if $date;
    return ($self->{_author}, $self->{_date})
}

1;

=head1 Gene

Gene: objects for Genes with a minimum set of attributes

=head1 Synopsis

    use Gene;

    my $gene1 = Gene->new(
        name       => 'biggene',
        organism   => 'Mus musculus',
        chromosome => '2p',
        pdbref     => 'pdb5775.ent',
        author     => 'L.G.Jeho',
        date       => 'August 23, 1989',
    );

    print "Gene name is ", $gene1->get_name(  );
    print "Gene organism is ", $gene1->get_organism(  );
    print "Gene chromosome is ", $gene1->get_chromosome(  );
    print "Gene pdbref is ", $gene1->get_pdbref(  );
    print "Gene author is ", $gene1->get_author(  );
    print "Gene date is ", $gene1->get_date(  );

    $clone = $gene1->clone(name => 'biggeneclone');

    $gene1-> set_chromosome('2q');
    $gene1-> set_pdbref('pdb7557.ent');
    $gene1-> set_author('G.Mendel');
    $gene1-> set_date('May 25, 1865');

    $clone->citation('T.Morgan', 'October 3, 1912');

    print "Clone citation is ", $clone->citation;

=head1 AUTHOR

A kind reader

=head1 COPYRIGHT

Copyright (c) 2003, We Own Gene, Inc.

=cut

3.11.2 Defining Attributes and Their Behaviors

This fourth version of Gene.pm does some additional things with the available attributes:

It collects them in their own hash, %_attribute_properties . This makes it easier to modify the class; you only have to add or delete attributes to this one hash, and the rest of the code will behave accordingly .
It enables you to specify default values for each attribute. In the Gene.pm class, I just specify the string ???? as the default for each attribute, but any values could be specified.
This attribute hash specifies, for each attribute, whether it is permitted to read or write it, and if it is required to have a nondefault value provided.

Here is the hash that supports all this:

# A list of all attributes with default values and read/write/required properties
    my %_attribute_properties = (
        _name        => [ '????',        'read.required'],
        _organism    => [ '????',        'read.required'],
        _chromosome  => [ '????',        'read.write'],
        _pdbref      => [ '????',        'read.write'],
        _author      => [ '????',        'read.write'],
        _date        => [ '????',        'read.write'],
    );

Why have the read/write/required properties been specified? It's because sometimes overwriting an attribute may get you into deep water; for instance, if you have a unique ID number assigned to each object you create, it may be a bad idea to allow the user of the class to overwrite that ID number. Restricting the access to read-only forces the user of the class to destroy an unwanted object and create a new one with a new ID. It depends on the application you're writing, but in general, the ability to enforce read/write discipline on your attributes can help you create safer code.

The required property ensures that the user gives an attribute a value when the object is created. I've already discussed why that is useful in earlier versions of the class; here, I'm just implementing it in a slightly different way.

This way of specifying properties can easily be expanded. For instance, if you want to add a property no_overwrite that prevents overwriting a previously set (nondefault) value, just add such a string to this hash and alter the code of the mutator method accordingly.

Now that we've got a fair amount of information about the attributes collected in a separate data structure, we need a few helper methods to access that information.

First, you need a method that simply returns a list of all the attributes:

# Return a list of all attributes
sub _all_attributes {
        keys %_attribute_properties;
}

Next, you'll want a way to check, for any given attribute and property, if that property is set for that attribute. The return value is the value of the last statement in the subroutine, which is true or false depending on whether or not the property $permissions is set for the given attribute:

# Check if a given property is set for a given attribute
sub _permissions {
    my($self, $attribute, $permissions) = @_;
    $_attribute_properties{$attribute}[1] =~ /$permissions/;
}

Finally, to set attribute values, you'll want to report on the default value for any given attribute. This returns the value of the last statement in the subroutine, which is the default value for the given attribute (this is a hash of arrays, and the code is returning the first element of the array stored for that attribute, which contains the default value):

# Return the default value for a given attribute
sub _attribute_default {
        my($self, $attribute) = @_;
    $_attribute_properties{$attribute}[0];
}

3.11.3 Initializing the Attributes of a New Object

This fourth and final version of Gene.pm has some alterations to the new constructor method. These alterations incorporate tests and actions relating to the new information being specified about the attributes, namely, their default values and their various properties.

I've also added an entirely new constructor method, clone . Recall that the new constructor method is called as a class method (e.g., Gene->new( ) ) and uses default values for every attribute not specified when called. It is often useful to create a new object by copying an old object and just changing some of its values. clone gives this capability. It is called as an object method (e.g., $geneobject->clone( ) ).

Let's examine the changes that were made to the new constructor; then we'll look at the clone constructor.

3.11.3.1 The newer new constructor

Here is the new version of the code for the new constructor:

# The constructor method
# Called from class, e.g. $obj = Gene->new(  );
sub new {
    my ($class, %arg) = @_;
    # Create a new object
    my $self = bless {  }, $class;

    foreach my $attribute ($self->_all_attributes(  )) {
        # E.g. attribute = "_name",  argument = "name"
        my($argument) = ($attribute =~ /^_(.*)/);
        # If explicitly given
        if (exists $arg{$argument}) {
            $self->{$attribute} = $arg{$argument};
        # If not given, but required
        }elsif($self->_permissions($attribute, 'required')) {
            croak("No $argument attribute as required");
        # Set to the default
        }else{
            $self->{$attribute} = $self->_attribute_default($attribute);
        }
    }
    $class->_incr_count(  );
    return $self;
}

Notice that we start by bless ing an empty anonymous hash: bless { } , and then setting the values of the attributes.

These attribute values are set one by one, looping over their list given by the new helper method _all_attributes . Recall that the attribute names start with an underscore, which indicates they are private to the class code and not available to the user of the class. Each attribute is associated with an argument that has the same name without the leading underscore .

The logic of attribute initialization is three part. If an argument and value for an attribute is given, the attribute is set to that value. If no argument/value is given, but a value is required according to the properties specified for that attribute, the program croak s. Finally, if no argument is given and the attribute isn't required, the attribute is set to the default value specified for that attribute.

As before, at the end of the new constructor, the count of objects is increased, and the new object is returned.

3.11.3.2 The clone constructor

The clone constructor is very similar to the new constructor. In fact, the two subroutines could be combined into one without much trouble. (See the chapter exercises.) However, it makes sense to separate them, especially since it makes it clearer what's happening in the code that uses these subroutines. Besides, you just have to figure that the special ability to clone objects will come in handy in bioinformatics!

Here is the code for the clone constructor:

# The clone method
# All attributes will be copied from the calling object, unless
# specifically overridden
# Called from an exisiting object, e.g. $cloned_obj = $obj1->clone(  );
sub clone {
    my ($caller, %arg) = @_;
    # Extract the class name from the calling object
    my $class = ref($caller);
    # Create a new object
    my $self = bless {  }, $class;

    foreach my $attribute ($self->_all_attributes(  )) {
        # E.g. attribute = "_name",  argument = "name"
        my($argument) = ($attribute =~ /^_(.*)/);
        # If explicitly given
        if (exists $arg{$argument}) {
            $self->{$attribute} = $arg{$argument};
        # Otherwise copy attribute of new object from the calling object
        }else{
            $self->{$attribute} = $caller->{$attribute};
        }
    }
    $self->_incr_count(  );
    return $self;
}

Notice, first of all, that this method is called from an object, in contrast to the new constructor, which is called from the class. That is, to create a new object, you say something like:

$newobject = Myclass->new(  );

As usual, the class Myclass is named explicitly when calling the new constructor.

On the other hand, to clone an existing object, you say something like:

$clonedobject = $newobject->clone(  );

in which the clone constructor is called from an already existing object, in this case, the object $newobject .

Now, in the code for the clone method, the class name must be extracted from the caller by the ref($caller) code because the caller is an object, not a class.

Next, as in the new constructor, an empty anonymous hash is bless ed as an object in the class, and then each attribute is considered in turn in a foreach loop.

Now, the argument name associated with the attribute name is extracted. Here, a simpler two-stage test is made. As before, if the argument is specified, the attribute is set as requested . If not, the attribute is set to the value it had in the calling object. Finally, the count of objects is incremented, and the new object is returned.

These two constructors give you some flexibility in how new objects are created and initialized in the Gene class. This flexibility may prove convenient and useful for you.

3.11.4 Permissions

The code to AUTOLOAD has been augmented with checks for appropriate permissions for the various attributes. The part of the code that handles the get_ accessor methods now checks to see if the read flag is set in the attribute hash via the _permissions class method. Notice the code that installs the definition of an accessor into the symbol table has also been modified to accommodate this additional test:

# AUTOLOAD accessors
if($AUTOLOAD =~ /.*::get_\w+/) {
    # Install this accessor definition in the symbol table
    *{$AUTOLOAD} = sub {
        my ($self) = @_;
        unless($self->_permissions($attribute, 'read')) {
            croak "$attribute does not have read permission";
        }
        $self->{$attribute};
    };
    # Return the attribute value
    unless($self->_permissions($attribute, 'read')) {
        croak "$attribute does not have read permission";
    }
    return $self->{$attribute};
}

Similarly, the part of AUTOLOAD that defines mutator methods for setting attribute values now checks for write permissions in a similar fashion.

3.11.5 Gene.pm Test Program and Output

Here is a test program testGene that exercises some of the new features of Gene.pm , followed by its output. It's worthwhile to take the time to read the testGene program, looking back at the class module Gene.pm for the definitions of the objects and methods and seeing what kind of output the test program creates. Also, see the exercises for suggestions on how to further modify and extend the capabilities of Gene.pm .

#!/usr/bin/perl

#
# Test the fourth and final version of the Gene module
#

use strict;
use warnings;

# Change this line to show the folder where you store Gene.pm
use lib "/home/tisdall/MasteringPerlBio/development/lib";
use Gene;

print "Object 1:\n\n";

# Create first object
my $obj1 = Gene->new(
        name            => "Aging",
        organism        => "Homo sapiens",
        chromosome      => "23",
        pdbref          => "pdb9999.ent"
); 

# Print the attributes of the first object
print $obj1->get_name, "\n";
print $obj1->get_organism, "\n";
print $obj1->get_chromosome, "\n";
print $obj1->get_pdbref, "\n";
# Test AUTOLOAD failure: try uncommenting one or both of these lines
#print $obj1->get_exon, "\n";
#print $obj1->getexon, "\n";

print "\n\nObject 2:\n\n";

# Create second object
my $obj2 = Gene->new(
        organism        => "Homo sapiens",
        name            => "Aging",
); 

# Print the attributes of the second object ... some will be unset
print $obj2->get_name, "\n";
print $obj2->get_organism, "\n";
print $obj2->get_chromosome, "\n";
print $obj2->get_pdbref, "\n";

# Reset some of the attributes of the second object
# set_name will cause an error
#$obj2->set_name("RapidAging");
$obj2->set_chromosome("22q");
$obj2->set_pdbref("pdf9876.ref");
$obj2->set_author("D. Enay");
$obj2->set_date("February 9, 1952");

print "\n\n";

# Print the reset attributes of the second object
print $obj2->get_name, "\n";
print $obj2->get_organism, "\n";
print $obj2->get_chromosome, "\n";
print $obj2->get_pdbref, "\n";
print $obj2->citation, "\n";

# Use a class method to report on a statistic about all existing objects
print "\nCount is ", Gene->get_count, "\n\n";

print "Object 3: a clone of object 2\n\n";

# Clone an object
my $obj3 = $obj2->clone(
        name            => "screw",
        organism        => "C.elegans",
        author          => "I.Turn",
);

# Print the attributes of the cloned object
print $obj3->get_name, "\n";
print $obj3->get_organism, "\n";
print $obj3->get_chromosome, "\n";
print $obj3->get_pdbref, "\n";
print $obj3->citation, "\n";

print "\nCount is ", Gene->get_count, "\n\n";

print "\n\nObject 4:\n\n";

# Create a fourth object: but this fails
#  because the "name" value is required (see Gene.pm)
my $obj4 = Gene->new(
        organism        => "Homo sapiens",
        chromosome      => "23",
        pdbref          => "pdb9999.ent"
); 

# This line is not reached due to the fatal failure to
#  create the fourth object
print "\nCount is ", Gene->get_count, "\n\n";

Here is the output from running the preceding program:

Object 1:

Aging
Homo sapiens
23
pdb9999.ent

Object 2:

Aging
Homo sapiens
????
????

Aging
Homo sapiens
22q
pdf9876.ref
D. EnayFebruary 9, 1952

Count is 2

Object 3: a clone of object 2

screw
C.elegans
22q
pdf9876.ref
I.TurnFebruary 9, 1952

Count is 3


Object 4:

No name attribute as required at testGene line 89