perltoot.pod

来自「ARM上的如果你对底层感兴趣」· POD 代码 · 共 1,696 行 · 第 1/5 页

    sub new {
        my $proto = shift;
        my $class = ref($proto) || $proto;
        my $self  = {
            TITLE       => undef,
            CHRISTIAN   => undef,
            SURNAME     => undef,
            NICK        => undef,
        };
        bless ($self, $class);
        return $self;
    }

    sub christian {
        my $self = shift;
        if (@_) { $self->{CHRISTIAN} = shift }
        return $self->{CHRISTIAN};
    }

    sub surname {
        my $self = shift;
        if (@_) { $self->{SURNAME} = shift }
        return $self->{SURNAME};
    }

    sub nickname {
        my $self = shift;
        if (@_) { $self->{NICK} = shift }
        return $self->{NICK};
    }

    sub title {
        my $self = shift;
        if (@_) { $self->{TITLE} = shift }
        return $self->{TITLE};
    }

    sub as_string {
        my $self = shift;
        my $name = join(" ", @$self{'CHRISTIAN', 'SURNAME'});
        if ($self->{TITLE}) {
            $name = $self->{TITLE} . " " . $name;
        }
        return $name;
    }

    1;

Finally, here's the test program:

    #!/usr/bin/perl -w
    use strict;
    use Person;
    sub END { show_census() }

    sub show_census ()  {
        printf "Current population: %d\n", Person->population;
    }

    Person->debug(1);

    show_census();

    my $him = Person->new();

    $him->fullname->christian("Thomas");
    $him->fullname->surname("Aquinas");
    $him->fullname->nickname("Tommy");
    $him->fullname->title("St");
    $him->age(1);

    printf "%s is really %s.\n", $him->name, $him->fullname;
    printf "%s's age: %d.\n", $him->name, $him->age;
    $him->happy_birthday;
    printf "%s's age: %d.\n", $him->name, $him->age;

    show_census();

=head1 Inheritance

Object-oriented programming systems all support some notion of
inheritance.  Inheritance means allowing one class to piggy-back on
top of another one so you don't have to write the same code again and
again.  It's about software reuse, and therefore related to Laziness,
the principal virtue of a programmer.  (The import/export mechanisms in
traditional modules are also a form of code reuse, but a simpler one than
the true inheritance that you find in object modules.)

Sometimes the syntax of inheritance is built into the core of the
language, and sometimes it's not.  Perl has no special syntax for
specifying the class (or classes) to inherit from.  Instead, it's all
strictly in the semantics.  Each package can have a variable called @ISA,
which governs (method) inheritance.  If you try to call a method on an
object or class, and that method is not found in that object's package,
Perl then looks to @ISA for other packages to go looking through in
search of the missing method.

Like the special per-package variables recognized by Exporter (such as
@EXPORT, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, and $VERSION), the @ISA
array I<must> be a package-scoped global and not a file-scoped lexical
created via my().  Most classes have just one item in their @ISA array.
In this case, we have what's called "single inheritance", or SI for short.

Consider this class:

    package Employee;
    use Person;
    @ISA = ("Person");
    1;

Not a lot to it, eh?  All it's doing so far is loading in another
class and stating that this one will inherit methods from that
other class if need be.  We have given it none of its own methods.
We rely upon an Employee to behave just like a Person.

Setting up an empty class like this is called the "empty subclass test";
that is, making a derived class that does nothing but inherit from a
base class.  If the original base class has been designed properly,
then the new derived class can be used as a drop-in replacement for the
old one.  This means you should be able to write a program like this:

    use Employee;
    my $empl = Employee->new();
    $empl->name("Jason");
    $empl->age(23);
    printf "%s is age %d.\n", $empl->name, $empl->age;

By proper design, we mean always using the two-argument form of bless(),
avoiding direct access of global data, and not exporting anything.  If you
look back at the Person::new() function we defined above, we were careful
to do that.  There's a bit of package data used in the constructor,
but the reference to this is stored on the object itself and all other
methods access package data via that reference, so we should be ok.

What do we mean by the Person::new() function -- isn't that actually
a method?  Well, in principle, yes.  A method is just a function that
expects as its first argument a class name (package) or object
(blessed reference).   Person::new() is the function that both the
C<Person-E<gt>new()> method and the C<Employee-E<gt>new()> method end
up calling.  Understand that while a method call looks a lot like a
function call, they aren't really quite the same, and if you treat them
as the same, you'll very soon be left with nothing but broken programs.
First, the actual underlying calling conventions are different: method
calls get an extra argument.  Second, function calls don't do inheritance,
but methods do.

        Method Call             Resulting Function Call
        -----------             ------------------------
        Person->new()           Person::new("Person")
        Employee->new()         Person::new("Employee")

So don't use function calls when you mean to call a method.

If an employee is just a Person, that's not all too very interesting.
So let's add some other methods.  We'll give our employee
data fields to access their salary, their employee ID, and their
start date.

If you're getting a little tired of creating all these nearly identical
methods just to get at the object's data, do not despair.  Later,
we'll describe several different convenience mechanisms for shortening
this up.  Meanwhile, here's the straight-forward way:

    sub salary {
        my $self = shift;
        if (@_) { $self->{SALARY} = shift }
        return $self->{SALARY};
    }

    sub id_number {
        my $self = shift;
        if (@_) { $self->{ID} = shift }
        return $self->{ID};
    }

    sub start_date {
        my $self = shift;
        if (@_) { $self->{START_DATE} = shift }
        return $self->{START_DATE};
    }

=head2 Overridden Methods

What happens when both a derived class and its base class have the same
method defined?  Well, then you get the derived class's version of that
method.  For example, let's say that we want the peers() method called on
an employee to act a bit differently.  Instead of just returning the list
of peer names, let's return slightly different strings.  So doing this:

    $empl->peers("Peter", "Paul", "Mary");
    printf "His peers are: %s\n", join(", ", $empl->peers);

will produce:

    His peers are: PEON=PETER, PEON=PAUL, PEON=MARY

To do this, merely add this definition into the Employee.pm file:

    sub peers {
        my $self = shift;
        if (@_) { @{ $self->{PEERS} } = @_ }
        return map { "PEON=\U$_" } @{ $self->{PEERS} };
    }

There, we've just demonstrated the high-falutin' concept known in certain
circles as I<polymorphism>.  We've taken on the form and behaviour of
an existing object, and then we've altered it to suit our own purposes.
This is a form of Laziness.  (Getting polymorphed is also what happens
when the wizard decides you'd look better as a frog.)

Every now and then you'll want to have a method call trigger both its
derived class (also known as "subclass") version as well as its base class
(also known as "superclass") version.  In practice, constructors and
destructors are likely to want to do this, and it probably also makes
sense in the debug() method we showed previously.

To do this, add this to Employee.pm:

    use Carp;
    my $Debugging = 0;

    sub debug {
        my $self = shift;
        confess "usage: thing->debug(level)"    unless @_ == 1;
        my $level = shift;
        if (ref($self))  {
            $self->{"_DEBUG"} = $level;
        } else {
            $Debugging = $level;            # whole class
        }
        Person::debug($self, $Debugging);   # don't really do this
    }

As you see, we turn around and call the Person package's debug() function.
But this is far too fragile for good design.  What if Person doesn't
have a debug() function, but is inheriting I<its> debug() method
from elsewhere?  It would have been slightly better to say

    Person->debug($Debugging);

But even that's got too much hard-coded.  It's somewhat better to say

    $self->Person::debug($Debugging);

Which is a funny way to say to start looking for a debug() method up
in Person.  This strategy is more often seen on overridden object methods
than on overridden class methods.

There is still something a bit off here.  We've hard-coded our
superclass's name.  This in particular is bad if you change which classes
you inherit from, or add others.  Fortunately, the pseudoclass SUPER
comes to the rescue here.

    $self->SUPER::debug($Debugging);

This way it starts looking in my class's @ISA.  This only makes sense
from I<within> a method call, though.  Don't try to access anything
in SUPER:: from anywhere else, because it doesn't exist outside
an overridden method call.

Things are getting a bit complicated here.  Have we done anything
we shouldn't?  As before, one way to test whether we're designing
a decent class is via the empty subclass test.  Since we already have
an Employee class that we're trying to check, we'd better get a new
empty subclass that can derive from Employee.  Here's one:

    package Boss;
    use Employee;        # :-)
    @ISA = qw(Employee);

And here's the test program:

    #!/usr/bin/perl -w
    use strict;
    use Boss;
    Boss->debug(1);

    my $boss = Boss->new();

    $boss->fullname->title("Don");
    $boss->fullname->surname("Pichon Alvarez");
    $boss->fullname->christian("Federico Jesus");
    $boss->fullname->nickname("Fred");

    $boss->age(47);
    $boss->peers("Frank", "Felipe", "Faust");

    printf "%s is age %d.\n", $boss->fullname, $boss->age;
    printf "His peers are: %s\n", join(", ", $boss->peers);

Running it, we see that we're still ok.  If you'd like to dump out your
object in a nice format, somewhat like the way the 'x' command works in
the debugger, you could use the Data::Dumper module from CPAN this way:

    use Data::Dumper;
    print "Here's the boss:\n";
    print Dumper($boss);

Which shows us something like this:

    Here's the boss:
    $VAR1 = bless( {
	 _CENSUS => \1,
	 FULLNAME => bless( {
			      TITLE => 'Don',
			      SURNAME => 'Pichon Alvarez',
			      NICK => 'Fred',
			      CHRISTIAN => 'Federico Jesus'
			    }, 'Fullname' ),
	 AGE => 47,
	 PEERS => [
		    'Frank',
		    'Felipe',
		    'Faust'
		  ]
       }, 'Boss' );

Hm.... something's missing there.  What about the salary, start date,
and ID fields?  Well, we never set them to anything, even undef, so they
don't show up in the hash's keys.  The Employee class has no new() method
of its own, and the new() method in Person doesn't know about Employees.
(Nor should it: proper OO design dictates that a subclass be allowed to
know about its immediate superclass, but never vice-versa.)  So let's
fix up Employee::new() this way:

    sub new {
        my $proto = shift;
        my $class = ref($proto) || $proto;
        my $self  = $class->SUPER::new();
        $self->{SALARY}        = undef;
        $self->{ID}            = undef;
        $self->{START_DATE}    = undef;
        bless ($self, $class);          # reconsecrate
        return $self;
    }

Now if you dump out an Employee or Boss object, you'll find
that new fields show up there now.

=head2 Multiple Inheritance