use strict;
use warnings;

# Die Elternklasse
# ~~~~~~~~~~~~~~~~
package Tier;
sub sprich             # wie spricht das Tier?
  {
  my $klasse = shift;
  print $klasse->name, " macht ", $klasse->ton, "!\n";
  }
  
sub farbe              # welche Farbe hat das Tier?
  {
  my $klasse = shift;
  if (ref $klasse)
    { print $klasse->name, " ist ", $klasse->{farbe}, "!\n"; }
  else
    { print $klasse, " ist ", $klasse->standardfarbe, "!\n"; }
  }

sub set_farbe          # Farbe des Tieres aendern
  {
  my $klasse = shift;
  $klasse->{farbe} = shift;
  }
  
sub name               # wie heisst das Tier
  {                    # gibt Objekt- oder Klassenname an
  my $self  = shift;
  ref $self ? $self->{name} : "$self ohne Namen";
  }

sub verspeist 
  {
  my $class  = shift;
  my $futter = shift;
  print $class->name, " verspeist $futter.\n";
  }
  
sub new                # neues Tier-Objekt anlegen
  {
  my $klasse   = shift;
  my $self     = {};
  $self->{name}  = shift;
  $self->{farbe} = $klasse->standardfarbe();
  bless ($self, $klasse);
  }


# jetzt kommen die abgeleiteten Klassen
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
package Marsupilami;
our  @ISA = qw(Tier);   # Angabe der Elternklasse
sub ton { "huba" };     # fuer "sprich"
sub standardfarbe { "gelb mit schwarzen Tupfen" };

package Ente;
our  @ISA = qw(Tier);
sub ton { "quack" };
sub standardfarbe { "braun gesprenkelt" };

package Kuh;
our  @ISA = qw(Tier);
sub ton { "muh" };
sub standardfarbe { "braun" };

package Schabrackenschriller;
our  @ISA = qw(Tier);
sub ton { "SCHRILL" };
sub standardfarbe { "rosa gefiedert" };

package Maus;
our  @ISA = qw(Tier);
sub ton { "piep" }
sub standardfarbe { "schwarz und weiss" };
sub sprich 
  {
  my $class = shift;
  $class->SUPER::sprich;
  print "(Aber ganz leise.)\n";
  }


# Nun testen wir das Ganze in main
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
package main;
sub UNIVERSAL::grmpf
  {
  my ($package, $file, $line) = caller();
  my $func = (caller(1))[3] || $package;
  print STDERR "In $func ($file:$line)\n";
  }
  
# Klassenmethode testen
Ente->sprich;
Kuh->farbe;

# nun ein paar Objekte
my $duck = Ente->new("Donald");
$duck->set_farbe("weiss");
$duck->sprich;
$duck->farbe;
$duck->verspeist("einen Stapel Pfannkuchen");

my $marsu = Marsupilami->new("Bobo");
$marsu->set_farbe("schwarz");
$marsu->sprich;
$marsu->farbe;
$marsu->verspeist("zahlreiche Piranhas");

my $vogel = Schabrackenschriller->new("Joe");
$vogel->sprich;
$vogel->farbe;
$vogel->verspeist("gehaltvolle Körner");

my $kuh = Kuh->new("Zenzi");
$kuh->sprich;
$kuh->farbe;
$kuh->verspeist("leckeres Gras");

my $micky = Maus->new("Mickey");
$micky->sprich;
$micky->farbe;
$micky->verspeist("wohlriechenden Käse");

print "\n";
print $marsu->name, " ist ein Tier\n" if ($marsu->isa("Tier"));
print $marsu->name, " ist ein Marsupilami\n" if ($marsu->isa("Marsupilami"));

print "\n";
print $marsu->name, " kann sprechen\n" if ($marsu->can("sprich"));
print $marsu->name, " kann futtern\n" if ($marsu->can("verspeist"));
print $marsu->name, " hat eine Farbe\n" if ($marsu->can("farbe"));

$marsu->grmpf();