I am trying to build an inheritable object, and I am using examples from
the Perl Cookbook, 2nd edition, mostly Recipe 13.1, using the new and
_init methods.  

I created a base class Logon and a subclass called DBLogon, in files
Logon.pm and DBLogon.pm, respectively.  All referenced files are copied
below.  I can create a Logon object and print its contents with no
problem (see test program testlogon.pl).  However, my subclass is not
working.  According to Recipe 13.1 in the cookbook, have an _init()
function called by new() can make the class more inheritable ("separate
the memory allocation and blessing step from the instance data
initialization step", p. 507-508).  

When I try to assign values to the DBLogon object's attributes, I get
the following error: "Can't access 'USERID' field in object of class
DBLogon at testdblogon.pl line 7".  What am I missing?  

# ==================== Logon.pm ====================
package Logon;
use Carp;

# Constructor
sub new {
        my $that = shift;
        my $class = ref($that) || $that;
        my $self = {};
        bless $self, $class;
        $self->_init();

        return $self;
}

sub _init {
        my $self = shift;
        $self->{USERID} = undef;
        $self->{SERVER} = undef;
}

sub display {
        my $self = shift;
        my @keys;

        if (@_ == 0) {
                @keys = sort keys (%$self);
        } else {
                @keys = @_;
        }


        foreach $key (@keys) {
                $key = uc $key;
                my $label = ucfirst lc $key;
                print "$label: $self->{$key}\n";
        }
}

sub userid;
sub server;

sub AUTOLOAD {
        my $self = shift;
        my $type = ref($self) || croak "$self is not an object";
        my $name = uc $AUTOLOAD;
        $name =~ s/.*://;               # Strip fully-qualified portion

        unless ( exists $self->{$name} ) {
                croak "Can't access '$name' field in object of class
$type";
        }

        if (@_) {
                return $self->{$name} = shift;

        } else {
                return $self->{$name};
        }
}
1;

# ==================== DBLogon.pm ====================
package DBLogon;
use Logon;
@ISA = qw (Logon);

use Carp;

# Constructor
sub new {
        my $that = shift;
        my $class = ref($that) || $that;
        my $self = $class->SUPER::new();
        bless $self, $class;

        $self->_init();

        return $self;
}

sub _init {
        my $self = shift;
        $self->{DBNAME} = undef;
}
1;

There are also 2 test programs, testlogon.pm and testdblogon.pm:

# ==================== Logon.pm ====================
#!/usr/bin/perl

use DBLogon;

my $mylogon = DBLogon->new();

$mylogon->userid("user1");
$mylogon->server("server1");
$mylogon->dbname("db1");

$mylogon->display();

# ==================== Logon.pm ====================
#!/usr/bin/perl

use DBLogon;

my $mylogon = DBLogon->new();

$mylogon->userid("user1");
$mylogon->server("server1");
$mylogon->dbname("db1");

$mylogon->display();


Reply via email to