BEGIN { package X; sub A {} sub B {} }
BEGIN { package Y; @ISA=qw(X); sub B {} }
BEGIN { package Z; @ISA=qw(Y); sub A {} }

my $object = ($opt{specialcase} ? 'Z' : 'Y')->new(@newargs);
[download]

-- Randal L. Schwartz, Perl hacker

Excellent solution to the problem.

Another one could be to use the "decorator" design pattern instead of subclassing. Here is an interesting discussion of when and why to use this pattern:

http://www.stevenblack.com/Articles/PTN-Decorator.asp

(it's not Perl, but you get the idea)

From your description I would go with the subclass solution, but it's always good to know your options.

/J

package GenObj;

my %methods = (
  name => sub { $_[0]{DATA}{name} },
  setname => sub { $_[0]{DATA}{name} = $_[1] },
  # ...
);

sub new {
  my ($class) = @_;
  bless { DATA => {}, METHODS => {%methods} }, $class;
}

AUTOLOAD {
  (my $method = $AUTOLOAD) =~ s/.*:://;
  $_[0]{METHODS}{$method} ?
    goto &{$_[0]{METHODS}{$method}} :
    die "unsupported method $method for object";
}

package main;

$foo = GenObj->new;
$foo->setname("Jeff");
print $foo->name;
[download]

$x = new GenObj;       # ref($x) eq 'GenObj::a'
$y = new GenObj -foo;  # ref($y) eq 'GenObj::b'
$x->get_foo;           # calls $x->GenObj::get_foo
$y->get_foo;           # calls $y->GenObj::b::get_foo
[download]

package GenObj;

# the following methods can be generated
# automatically with one of the Class::
# modules...

# these are the EXPECTED inherited methods
# of GenObj objects
sub set_name { $_[0]{name} = $_[1] }
sub get_name { $_[0]{name} }
sub set_age { $_[0]{age} = $_[1] }
sub get_age { $_[0]{age} }


my $CHILD = 'a';

sub new {
  no strict 'refs';  # naughty things transpire

  my $class = shift;
  my $obj = bless {}, "${class}::$CHILD";

  @{"${class}::${CHILD}::ISA"} = ($class);
  for (map s/^-//, @_) {
    *{"${class}::${CHILD}::get_$_"} =
      \&{"${class}::Sub::get_$_"};
    *{"${class}::${CHILD}::set_$_"} =
      \&{"${class}::Sub::set_$_"};
  }

  return $obj;
);


package GenObj::Sub;

# these are the specialized methods
# to be inherited on demand
sub set_name { $_[0]{name} = condense($_[1]) }
sub get_name { expand($_[0]{name}) }
sub set_age { $_[0]{age} = age2sec($_[1]) }
sub get_age { sec2age($_[0]{age}) }

# these are some utility functions
# as called above
sub condense;
sub expand;
sub age2sec;
sub sec2age;

1;
[download]

use GenObj;
my $normal   = new GenObj;
my $diffage  = new GenObj -age;
my $diffname = new GenObj -name;
my $diffboth = new GenObj -age, -name;

$normal->set_age(10);  # GenObj::set_age
$normal->get_name;     # GenObj::get_name

$diffage->set_age(10);  # GenObj::Sub::set_age
$diffage->get_name;     # GenObj::get_name

$diffname->set_age(10);  # GenObj::set_age
$diffname->get_name;     # GenObj::Sub::get_name

$diffboth->set_age(10);  # GenObj::Sub::set_age
$diffboth->get_name;     # GenObj::Sub::get_name
[download]

return $self->SUPER::A();
[download]

$self->SUPER::A();      
return;
[download]

Is the special case exclusive? Meaning, is it a case the all objects of class 'Y' will behave differently based on the command-line switch? Or is it just once in a while?

Based on the answer to that you have two choices:

• Intermittent behaviour: your solution is an excellent one (extending won't work)
• Consistent behaviour: I'd change the constructor so that the method itself works differently

my $0.02

AgentM Systems or Nasca Enterprises is not responsible for the comments made by AgentM- anywhere.

In Perl, if you have class X with methods 'foo' and 'bar', and class Y which inherits from X, but has a method 'foo', then the following takes place:

package X;
sub foo;
sub bar;

package Y;
@ISA = 'X';
sub foo;

package main;
X->foo;  # calls X::foo('X');
X->bar;  # calls X::bar('X');
Y->foo;  # calls Y::foo('Y');
Y->bar;  # calls X::bar('Y');
[download]

In C++, you would have to declare X::foo() to be virtual:

// yes, this is C++, so shoot me
class X {
public:
  virtual int foo () { return 1; }
  int bar () { return 2; }
};

class Y : public X {
  virtual int foo () { return 3; }
};
[download]

You don't need to do that in Perl, since an object's method search tree starts in the object's class (Y, in this case).

Since an object in Y inherits from X, then Y->isa(X) is true, just like you can write a function in C++ like:

void printStuff (X& obj);
[download]

and it will accept an object of class Y (because of the rules of inheritance). In Perl, you can do this checking via the isa() method shown above.

As for ensuring an abstract base class never has objects of IT specifically -- only of it's sub-classes -- you can't stop a person from brute-force bless($obj,'Employee'), but you can make Employee::new die if its first argument is 'Employee':

package Employee;
sub new {
  my ($class,$fname,$lname) = @_;
  die if $class eq 'Employee';
  bless { FNAME => $fname, LNAME => $lname }, $class;
}

package Employee::Boss;
@ISA = qw( Employee );
sub new {
  my ($class,$fname,$lname) = @_;
  my $self = $class->SUPER::new($fname,$lname);
  $self->{PAY} = 1_000_000;
  bless $self, $class;
}

# and so on...
[download]

And then a program would run like:

use Employee;
# defines Employee, Employee::Boss,
# Employee::Hourly, and Employee::Intern
$joe = Employee::Intern->new('Joe', 'Schmoe');
$jay = Employee::Boss->new('Jay','Schmay');
$not = Employee->new('Not', 'Happening');       # <-- dies
[download]



$_="goto+F.print+chop;\n=yhpaj";F1:eval