#!/usr/bin/perl -w
use strict;

package Object;
sub new   { return bless {}, shift; }
sub speak { print shift() . " says hello\n"; };

package mixin_simple;
sub yell { print shift() . " says HELLO\n"; }

package mixin_shadow;
sub speak { print shift() . " whispers hello\n"; };

package main;

sub mix {
  my ( $object, @classes ) = @_;
  push @classes, ref $object;
  my $package_name = join ( '_', @classes );
  my $package_list = join ( ' ', @classes );
  my $declaration =
    "package $package_name; use base qw($package_list);";
  eval $declaration; die "declaration error: $@\n"  if  $@;
  return bless $object, $package_name;
}

my $obj = Object->new;
$obj->speak;
mix ( $obj, 'mixin_simple' );
$obj->speak;
$obj->yell;
print "object is still an Object\n"  if  $obj->isa('Object');

my $whisperer = Object->new;
mix ( $whisperer, 'mixin_shadow' );
$whisperer->speak;
print "whisperer is still an Object\n"  if  $whispererpk->isa('Object');

##</code><code>##

sub mix {
  my ( $object, @classes ) = @_;
  push @classes, ref $object;
  my $package_name = join ( '_', @classes );
  my $package_list = join ( ' ', @classes );
  my $check = "package $package_name; \$declared";
  unless ( eval $check ) {
    print " -- creating new package $package_name -- \n";
    my $declaration =
      "package $package_name; use base qw($package_list);
       use vars '\$declared'; \$declared++";
    eval $declaration;
    die "declaration error: $@\n"  if  $@;
  };
  bless $object, $package_name;
}

##</code><code>##

<blob_element>
  <name>picture</name>
  <mixin>XML::Comma::Mixin::Standard_Image</mixin>
  <mixin>XML::Comma::Mixin::Auto_Versioning</mixin>
</blob_element>