File Coverage

blib/lib/Class/Prototyped.pm

Criterion	Covered	Total	%
statement	681	807	84.3
branch	270	386	69.9
condition	77	119	64.7
subroutine	83	94	88.3
pod	7	7	100.0
total	1118	1413	79.1

#############################################################################
#
# Class::Prototyped - Fast prototype-based OO programming in Perl
#
# Author: Ned Konz and Toby Ovod-Everett
#############################################################################
# Copyright 2001-2004 Ned Konz and Toby Ovod-Everett.  All rights reserved.
#
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
# For comments, questions, bugs or general interest, feel free to
# contact Toby Ovod-Everett at [e-mail]
#############################################################################

# Class::Prototyped - Fast prototype-based OO programming in Perl

package Class::Prototyped::Mirror;
sub PREFIX()        { 'PKG0x' }
sub PREFIX_LENGTH() { 5 }


package Class::Prototyped;
use strict;
use Carp();

$Class::Prototyped::VERSION = '1.13';

sub import {
	while (my $symbol = shift) {
		if ($symbol eq ':OVERLOAD') {
			unless (scalar keys %Class::Prototyped::overloadable_symbols) {
				eval "use overload";
				@Class::Prototyped::overloadable_symbols{ map { split }
						values %overload::ops } = undef;
			}
		}
		elsif ($symbol eq ':REFLECT') {
			*UNIVERSAL::reflect =
				sub { Class::Prototyped::Mirror->new($_[0]) };
		}
		elsif ($symbol eq ':EZACCESS') {
			no strict 'refs';

			foreach my $call (
				qw(addSlot addSlots deleteSlot deleteSlots getSlot getSlots super)
			) {
				*{$call} = sub {
					my $obj = shift->reflect;
					UNIVERSAL::can($obj, $call)->($obj, @_);
				};
			}
		}
		elsif ($symbol eq ':SUPER_FAST') {
			*Class::Prototyped::Mirror::super =
				\&Class::Prototyped::Mirror::super_fast;
		}
		elsif ($symbol eq ':NEW_MAIN') {
			*main::new = sub { Class::Prototyped->new(@_) };
		}
	}
}

# Constructor. Pass in field definitions.
sub new {
	my $class = shift;

	Carp::croak("odd number of slot parameters to new\n") if scalar(@_) % 2;

	$class->newCore('new', undef, @_);
}

sub newPackage {
	my $class   = shift;
	my $package = shift;

	Carp::croak("odd number of slot parameters to newPackage\n") if scalar(@_) % 2;

	$class->newCore('newPackage', $package, @_);
}

# Creates a copy of an object
sub clone {
	my $original = shift;

	Carp::croak("odd number of slot parameters to clone\n") if scalar(@_) % 2;

	$original->newCore('clone', undef, @_);
}

sub clonePackage {
	my $original = shift;
	my $package = shift;

	Carp::croak("odd number of slot parameters to clonePackage\n") if scalar(@_) % 2;

	$original->newCore('clonePackage', $package, @_);
}


sub newCore {
	my $class   = shift;
	my $caller  = shift;
	my $package = shift;

	my $isPackage = substr($caller, -7) eq 'Package';
	my $isNew = substr($caller, 0, 3) eq 'new';
	my $isClone = substr($caller, 0, 5) eq 'clone';

	Carp::croak("odd number of slot parameters to $caller\n") if scalar(@_) % 2;

	my $class_mirror = $class->reflect;

	my($self, $tied);
	{
		no strict 'refs';

		if ( $isPackage ) {
			if (scalar(keys %{"$package\::"})) {
				Carp::croak(
					"attempt to use newPackage with already existing package\n"
						. "package: $package");
			}
			my %self;
			tie %self, $class_mirror->tiedInterfacePackage();
			$tied = tied %self;
			$Class::Prototyped::Mirror::objects{$package} = $self = \%self;
		}
		else {
			$self = {};
			$package = Class::Prototyped::Mirror::PREFIX . substr("$self", 7, -1);    # HASH($package)

			tie %$self, $class->reflect->tiedInterfacePackage();

			$tied = tied %$self;
			*{"$package\::DESTROY"} = \&Class::Prototyped::DESTROY;
		}
	}

	$tied->package($package);
	@{ $tied->{isa} } = qw(Class::Prototyped);
	$tied->{vivified_parents} = 1;
	$tied->{vivified_methods} = 1;
	$tied->{defaults} = $class_mirror->_defaults;

	bless $self, $package;    # in my own package

	my $parsedSlots = scalar @_ || $isClone ?
			$self->reflect->addSlotsParser( ( $isClone ? $class->reflect->getSlots() : () ), @_ ) :
			[];

	if ( $isNew )	{
		my $classstar = ( ref($class) &&
				substr(ref($class), 0, Class::Prototyped::Mirror::PREFIX_LENGTH) ne
					Class::Prototyped::Mirror::PREFIX
			) ? ref($class) : $class;   # allow object for named class to provide a class name

		if (!(grep { $_->[0] eq 'class*' } @$parsedSlots) && $classstar ne 'Class::Prototyped')
		{
			unshift(@$parsedSlots, @{$self->reflect->addSlotsParser('class*' => $classstar)});
		}
	}

	$self->reflect->addParsedSlots($parsedSlots) if scalar(@$parsedSlots);

	return $self;
}

sub reflect {
	return $Class::Prototyped::Mirror::mirrors{ $_[0] } || Class::Prototyped::Mirror->new($_[0]);
}

sub destroy {
	my $self   = shift;
	my $mirror = $self->reflect;
	my(@otherOrder) = @{$mirror->_otherOrder};
	$mirror->deleteSlots(@otherOrder);
}

# Remove my symbol table
sub DESTROY {
	my $self    = shift;
	my $package = ref($self);
	if ((substr($package, 0, Class::Prototyped::Mirror::PREFIX_LENGTH) eq
			Class::Prototyped::Mirror::PREFIX)
		&& ($package ne 'Class::Prototyped'))
	{
		no strict 'refs';

		my $tied        = tied(%$self) or return;
		my $parentOrder = $tied->{parentOrder};
		my $isa         = $tied->{isa};
		my $slots       = $tied->{slots};

		my (@deadIndices);
		foreach my $i (0 .. $#$parentOrder) {
			my $parent = $slots->{ $parentOrder->[$i] };
			my $parentPackage = ref($parent) || $parent;
			push (@deadIndices, $i)
				unless scalar(keys %{"$parentPackage\::"});
		}

		foreach my $i (@deadIndices) {
			delete($slots->{ $parentOrder->[$i] });
			splice(@$parentOrder, $i, 1);
			splice(@$isa,         $i, 1);
		}

		# this is required to re-cache @ISA
		delete ${"$package\::"}{'::ISA::CACHE::'};
		@$isa=@$isa;

		my $parent_DESTROY;
		my (@isa_queue) = @{"$package\::ISA"};
		my (%isa_cache);
		while (my $pkg = shift @isa_queue) {
			exists $isa_cache{$pkg} and next;
			my $code = *{"$pkg\::DESTROY"}{CODE};
			if (defined $code && $code != \&Class::Prototyped::DESTROY) {
				$parent_DESTROY = $code;
				last;
			}
			unshift (@isa_queue, @{"$pkg\::ISA"});
			$isa_cache{$pkg} = undef;
		}

		$self->destroy;    # call the user destroy function

		$parent_DESTROY->($self) if defined $parent_DESTROY;

		$self->reflect->deleteSlots($self->reflect->slotNames('PARENT'));

		foreach my $key (keys %{"$package\::"}) {
			delete ${"$package\::"}{$key};
		}

		# this only works because we're not a multi-level package:
		delete($main::{"$package\::"});

		delete($Class::Prototyped::Mirror::parents{$package});
	}
}

$Class::Prototyped::Mirror::ending = 0;
sub END { $Class::Prototyped::Mirror::ending = 1 }

package Class::Prototyped::Tied;
$Class::Prototyped::Tied::VERSION = '1.13';
@Class::Prototyped::Tied::DONT_LIE_FOR = qw(Data::Dumper);

sub TIEHASH {
	bless $_[1] || {
			package          => undef,
			isa              => undef,
			parentOrder      => [],
			otherOrder       => [],
			slots            => {},
			types            => {},
			attribs          => {},
			defaults         => undef,
			vivified_parents => 0,
			vivified_methods => 0,
		},
		$_[0];
}

sub FIRSTKEY {
	$_[0]->{dont_lie} = 0;
	my $caller = (caller(0))[0];
	foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) {
		$_[0]->{dont_lie} = $caller eq $i and last;
	}
	$_[0]->{iter}        = 1;
	$_[0]->{cachedOrder} = [@{ $_[0]->{parentOrder} }, @{ $_[0]->{otherOrder} }];

	unless ($_[0]->{dont_lie}) {
		my $slots = $_[0]->{slots};
		@{ $_[0]->{cachedOrder} } =
			grep { !UNIVERSAL::isa($slots->{$_}, 'CODE') }
			@{ $_[0]->{cachedOrder} };
	}
	return $_[0]->{cachedOrder}->[0];
}

sub NEXTKEY {
	return $_[0]->{cachedOrder}->[ $_[0]->{iter}++ ];
}

sub EXISTS {
	exists $_[0]->{slots}->{ $_[1] } or return 0;
	UNIVERSAL::isa($_[0]->{slots}->{ $_[1] }, 'CODE') or return 1;
	my $dont_lie = 0;
	my $caller   = (caller(0))[0];
	foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) {
		$dont_lie = $caller eq $i and last;
	}
	return $dont_lie ? 1 : 0;
}

sub CLEAR {
	Carp::croak("attempt to call CLEAR on the hash interface"
			. " of a Class::Prototyped object\n");
}

sub package {
	return $_[0]->{package} unless @_ > 1;
	no strict 'refs';
	$_[0]->{isa}     = \@{"$_[1]\::ISA"};
	$_[0]->{package} = $_[1];
}

#### Default Tied implementation
package Class::Prototyped::Tied::Default;
$Class::Prototyped::Tied::Default::VERSION = '1.13';
@Class::Prototyped::Tied::Default::ISA = qw(Class::Prototyped::Tied);

sub STORE {
	my $slots = $_[0]->{slots};

	Carp::croak(
		"attempt to access non-existent slot through tied hash object interface"
		)
		unless exists $slots->{ $_[1] };

	Carp::croak(
		"attempt to access METHOD slot through tied hash object interface")
		if UNIVERSAL::isa($slots->{ $_[1] }, 'CODE');

	Carp::croak(
		"attempt to modify parent slot through the tied hash object interface")
		if substr($_[1], -1) eq '*';

	$slots->{ $_[1] } = $_[2];
}

sub FETCH {
	my $slots = $_[0]->{slots};

	Carp::croak(
"attempt to access non-existent slot through tied hash object interface:\n"
			. "$_[1]")
		unless exists $slots->{ $_[1] };

	if (UNIVERSAL::isa($slots->{ $_[1] }, 'CODE')) {
		my $dont_lie = 0;
		my $caller   = (caller(0))[0];
		foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) {
			$dont_lie = $caller eq $i and last;
		}
		Carp::croak(
			"attempt to access METHOD slot through tied hash object interface")
			unless $dont_lie;
	}

	$slots->{ $_[1] };
}

sub DELETE {
	Carp::croak "attempt to delete a slot through tied hash object interface";
}

#### AutoVivifying Tied implementation
package Class::Prototyped::Tied::AutoVivify;
$Class::Prototyped::Tied::AutoVivify::VERSION = '1.13';
@Class::Prototyped::Tied::AutoVivify::ISA = qw(Class::Prototyped::Tied);

sub STORE {
	my $slots = $_[0]->{slots};

	Carp::croak(
		"attempt to modify parent slot through the tied hash object interface")
		if substr($_[1], -1) eq '*';

	if (exists $slots->{ $_[1] }) {
		Carp::croak(
			"attempt to access METHOD slot through tied hash object interface")
			if UNIVERSAL::isa($slots->{ $_[1] }, 'CODE');
	}
	else {
		my $slot = $_[1];
		$slots->{ $_[1] } = $_[2];
		my $implementation = bless sub {
			@_ > 1 ? $slots->{$slot} = $_[1] : $slots->{$slot};
		}, 'Class::Prototyped::FieldAccessor';
		no strict 'refs';
		local $^W = 0;    # suppress redefining messages.
		*{ $_[0]->package . "::$slot" } = $implementation;
		push (@{ $_[0]->{otherOrder} }, $slot);
		$_[0]->{types}->{$slot} = 'FIELD';
	}

	Carp::croak(
		"attempt to access non-existent slot through tied hash object interface"
		)
		unless exists $slots->{ $_[1] };

	$slots->{ $_[1] } = $_[2];
}

sub FETCH {
	my $slots = $_[0]->{slots};

	if (exists $slots->{ $_[1] }
		and UNIVERSAL::isa($slots->{ $_[1] }, 'CODE'))
	{
		my $dont_lie = 0;
		my $caller   = (caller(0))[0];
		foreach my $i (@Class::Prototyped::Tied::DONT_LIE_FOR) {
			$dont_lie = $caller eq $i and last;
		}
		Carp::croak(
			"attempt to access METHOD slot through tied hash object interface")
			unless $dont_lie;
	}

	$slots->{ $_[1] };
}

sub EXISTS {
	exists $_[0]->{slots}->{ $_[1] };
}

sub DELETE {
	my $slots = $_[0]->{slots};

	if (UNIVERSAL::isa($slots->{ $_[1] }, 'CODE')
		&& (caller(0))[0] ne 'Data::Dumper')
	{
		Carp::croak
			"attempt to delete METHOD slot through tied hash object interface";
	}

	my $package = $_[0]->package;
	my $slot    = $_[1];
	{
		no strict 'refs';
		my $name = "$package\::$slot";

		# save the glob...
		local *old = *{$name};

		# and restore everything else
		local *new;
		foreach my $type (qw(HASH IO FORMAT SCALAR ARRAY)) {
			my $elem = *old{$type};
			next if !defined($elem);
			*new = $elem;
		}
		*{$name} = *new;
	}
	my $otherOrder = $_[0]->{otherOrder};
	@$otherOrder = grep { $_ ne $slot } @$otherOrder;
	delete $slots->{$slot};    # and delete the data/sub ref
	delete $_[0]->{types}->{$slot};
}

# Everything that deals with modifying or inspecting the form
# of an object is done through a reflector.

package Class::Prototyped::Mirror;
$Class::Prototyped::Mirror::VERSION = '1.13';
$Class::Prototyped::Mirror::PROFILE::VERSION = '1.13';
$Class::Prototyped::Mirror::SUPER::VERSION = '1.13';

sub new {
	my $class = shift;
	my($entity) = @_;

	if ( ref($entity) ) {
		if (substr(ref($entity), 0, Class::Prototyped::Mirror::PREFIX_LENGTH) eq
				Class::Prototyped::Mirror::PREFIX)
		{
			return bless \$entity, 'Class::Prototyped::Mirror';
		}
		elsif ($Class::Prototyped::Mirror::objects{ ref($entity) } == $entity) {
			return $Class::Prototyped::Mirror::mirrors{ $entity } ||= bless \$entity, 'Class::Prototyped::Mirror';
		}
		else {
			return Class::Prototyped::Mirror::Normal->new($entity);
		}
	}

	my $object;
	unless ($object = $Class::Prototyped::Mirror::objects{ $entity }) {
		my (%self);
		my $tiepkg;
		if ($entity eq 'Class::Prototyped') {
			$tiepkg = 'Class::Prototyped::Tied::Default';
		}
		else {
			no strict 'refs';
			$tiepkg = eval { ${"$entity\::ISA"}[0]->reflect->tiedInterfacePackage() };
			$tiepkg = Class::Prototyped->reflect->tiedInterfacePackage() if $@;
		}
		tie %self, $tiepkg;
		$object = $Class::Prototyped::Mirror::objects{ $entity } = \%self;
		tied(%self)->package($entity);

		my $defaults;
		if ($entity eq 'Class::Prototyped') {
			$defaults = {FIELD => undef, METHOD => undef, PARENT => undef};
		}
		else {
			no strict 'refs';
			$defaults = eval { ${"$entity\::ISA"}[0]->reflect->_defaults() };
			$defaults = Class::Prototyped->reflect->_defaults() if $@;
		}

		tied(%self)->{defaults} = $defaults;

		bless $object, $entity;
	}
	return $Class::Prototyped::Mirror::mirrors{ $entity } ||= bless \$object, 'Class::Prototyped::Mirror';
}


#This code exists to support calling ->reflect->super on a "normal" object that
#is blessed into a C::P class.

package Class::Prototyped::Mirror::Normal;
$Class::Prototyped::Mirror::Normal::VERSION = '1.13';
@Class::Prototyped::Mirror::Normal::ISA = qw(Class::Prototyped::Mirror);

sub new {
	my $class = shift;
	my($entity) = @_;

	my $temp = Class::Prototyped::Mirror->new(ref($entity));

	my $self = bless \(my $o = ${$temp}), $class;
	$Class::Prototyped::Mirror::Normal::superselfs->{$self} = $entity;
	return $self;
}

sub super {
	my $mirror = shift;
	(bless \$Class::Prototyped::Mirror::Normal::superselfs->{$mirror}, 'Class::Prototyped::Mirror')->super(@_);
}

sub DESTROY {
	delete $Class::Prototyped::Mirror::Normal::superselfs->{$_[0]};
}

package Class::Prototyped::Mirror;

#### Interface to tied object

sub autoloadCall {
	my $mirror  = shift;

	my $package = $mirror->package();
	no strict 'refs';
	my $call = ${"$package\::AUTOLOAD"};
	$call =~ s/.*:://;
	return $call;
}

sub package {
	ref(${ $_[0] });
}

sub tiedInterfacePackage {
	my $self = shift;

	if ($_[0]) {
		my $package = {
			'default'    => 'Class::Prototyped::Tied::Default',
			'autovivify' => 'Class::Prototyped::Tied::AutoVivify',
		}->{$_[0]} || $_[0];

		if ($package eq $_[0] && scalar(keys %{"$package\::"}) == 0) {
			eval "use $package";
			Carp::croak "attempt to import package for :TIED_INTERFACE failed:\n$package"
				if $@;
		}

		tie %{ ${ $self } }, $package, tied(%{ ${ $self } });
		return $package;
	}
	else {
		return ref(tied(%{ ${ $self } }));
	}
}

sub defaultAttributes {
	my $mirror = shift;

	tied(%{ ${ $mirror } })->{defaults} = $_[0] if scalar(@_);
	my $defaults = $mirror->_defaults;

	my $retval = {};
	$retval->{FIELD}  = defined $defaults->{FIELD} ? {%{$defaults->{FIELD}}} : undef;
	$retval->{METHOD} = defined $defaults->{METHOD} ? {%{$defaults->{METHOD}}} : undef;
	$retval->{PARENT} = defined $defaults->{PARENT} ? {%{$defaults->{PARENT}}} : undef;
	return $retval;
}

sub _isa {
	tied(%{ ${ $_[0] } })->isa;
}

sub _parentOrder {
	my $tied = tied(%{ ${ $_[0] } });
	$_[0]->_autovivify_parents unless $tied->{vivified_parents};
	$tied->{parentOrder};
}

sub _otherOrder {
	my $tied = tied(%{ ${ $_[0] } });
	$_[0]->_autovivify_methods unless $tied->{vivified_methods};
	$tied->{otherOrder};
}

sub _slotOrder {
	my $tied = tied(%{ ${ $_[0] } });
	$_[0]->_autovivify_parents unless $tied->{vivified_parents};
	$_[0]->_autovivify_methods unless $tied->{vivified_methods};
	[@{ $tied->{parentOrder} }, @{ $tied->{otherOrder} }];
}

sub _slots {
	my $tied = tied(%{ ${ $_[0] } });
	$_[0]->_autovivify_parents unless $tied->{vivified_parents};
	$_[0]->_autovivify_methods unless $tied->{vivified_methods};
	$tied->{slots};
}

sub _types {
	tied(%{ ${ $_[0] } })->{types};
}

sub _attribs {
	tied(%{ ${ $_[0] } })->{attribs};
}

sub _defaults {
	tied(%{ ${ $_[0] } })->{defaults};
}

sub _vivified_parents {
	@_ > 1 ? tied(%{ ${ $_[0] } })->{vivified_parents} = $_[1] :
		tied(%{ ${ $_[0] } })->{vivified_parents};
}

sub _vivified_methods {
	@_ > 1 ? tied(%{ ${ $_[0] } })->{vivified_methods} = $_[1] :
		tied(%{ ${ $_[0] } })->{vivified_methods};
}

#The following returns package, _isa, _parentOrder, _otherOrder,
#_slots, _types, _attribs, and _defaults;
sub _everything {
	my $tied = tied(%{ ${ $_[0] } });
	$_[0]->_autovivify_parents unless $tied->{vivified_parents};
	$_[0]->_autovivify_methods unless $tied->{vivified_methods};

	return (
		ref(${ $_[0] }),
		$tied->{isa},
		$tied->{parentOrder},
		$tied->{otherOrder},
		$tied->{slots},
		$tied->{types},
		$tied->{attribs},
		$tied->{defaults},
	);
}

#### Autovivifivation support

sub _autovivify_parents {
	my $tied = tied(%{ ${ $_[0] } });
	return if $tied->{vivified_parents};

	my $mirror = shift;
	$tied->{vivified_parents} = 1;

	my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
		$mirror->_everything;

	if (scalar(grep { UNIVERSAL::isa($_, 'Class::Prototyped') } @$isa)
		&& $isa->[-1] ne 'Class::Prototyped')
	{
		push (@$isa, 'Class::Prototyped');
		no strict 'refs';
		delete ${"$package\::"}{'::ISA::CACHE::'};    # re-cache @ISA
		@$isa=@$isa;
	}

	if (@{$parentOrder}) {
		Carp::croak("attempt to autovivify in the "
				. "presence of an existing parentOrder\n" . "package: $package");
	}
	my @isa = @$isa;
	pop (@isa) if scalar(@isa) && $isa[-1] eq 'Class::Prototyped';

	foreach my $parentPackage (@isa) {
		my $count = '';
		my $slot  = "$parentPackage$count*";
		while (exists $slots->{$slot} || $slot eq 'self*') {
			$slot = $parentPackage . (++$count) . '*';
		}
		push (@$parentOrder, $slot);
		$slots->{$slot} = $parentPackage;
		$types->{$slot} = 'PARENT';
	}
}

sub _autovivify_methods {
	my $tied = tied(%{ ${ $_[0] } });
	return if $tied->{vivified_methods};

	my $mirror = shift;
	$tied->{vivified_methods} = 1;

	my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
		$mirror->_everything;

	no strict 'refs';
	foreach my $slot (grep { $_ ne 'DESTROY' } keys %{"$package\::"}) {
		my $code = *{"$package\::$slot"}{CODE} or next;
		ref($code) =~ /^Class::Prototyped::FieldAccessor/ and next;
		Carp::croak("the slot self* is inviolable") if $slot eq 'self*';

		if (exists $slots->{$slot}) {
			Carp::croak("you overwrote a slot via an include $slot")
				if !UNIVERSAL::isa($slots->{$slot}, 'CODE')
				|| $slots->{$slot} != $code;
		}
		else {
			push (@$otherOrder, $slot);
			$slots->{$slot} = $code;
			$types->{$slot} = 'METHOD';
		}
	}
}

sub object {
	$_[0]->_autovivify_parents;
	$_[0]->_autovivify_methods;
	${ $_[0] };
}

sub class {
	return $_[0]->_slots->{'class*'};
}

sub dump {
	eval "package main; use Data::Dumper;"
		unless (scalar keys(%Data::Dumper::));

	Data::Dumper->Dump([ $_[0]->object ], [ $_[0]->package ]);
}


sub slotStruct_name () {0};
sub slotStruct_value () {1};
sub slotStruct_type () {2};
sub slotStruct_attribs () {3};
sub slotStruct_implementor () {4};
sub slotStruct_filters () {5};
sub slotStruct_advisories () {6};


#### The support for attribute rationalization is not very fancy
$Class::Prototyped::Mirror::attributes = {
	FIELD => {
		constant => {
			type => 'implementor',
			code => sub {
				my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_;

				$slotAttribs->{constant} = 1;
				return bless sub {
					$slots->{$slotName};
				}, 'Class::Prototyped::FieldAccessor::Constant';
			}
		},

		autoload => {
			type => 'filter',
			rank => 50,
			code => sub {
				my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_;

				if ($slotAttribs->{autoload} = $slotAttribs->{autoload} ? 1 : undef) {
					my $self = $mirror->object;
					$implementation = bless sub {
						my $retval = &$slotValue;
						my $attribs = $self->reflect->_attribs->{$slotName};
						delete($attribs->{autoload});
						$self->reflect->addSlot([$slotName, %$attribs] => $retval);
						return $retval;
					}, 'Class::Prototyped::FieldAccessor::Autoload';
				}
				return $implementation;
			}
		},

		profile => {
			type => 'filter',
			rank => 80,
			code => sub {
				my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_;

				my $profileLevel = $slotAttribs->{profile};
				if ($profileLevel) {
					package Class::Prototyped::Mirror::PROFILE;
					my $old_implementation = $implementation;
					my $package = ref( ${ $mirror } );
					$implementation = sub {
						my $caller = '';
						if ($profileLevel == 2) {
							my($pack, $file, $line) = caller;
							$caller = "$file ($line)";
							$Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}->{$caller}++;
						} else {
							$Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}++;
						}
						goto &$old_implementation;
					};
				}
				return $implementation;
			},
		},

		'wantarray' => {
			type => 'filter',
			rank => 90,
			code => sub {
				my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_;

				if ($slotAttribs->{'wantarray'} = $slotAttribs->{'wantarray'} ? 1 : undef) {
					my $old_implementation = $implementation;
					$implementation = bless sub {
						my $retval = &$old_implementation;
						if (ref($retval) eq 'ARRAY' && wantarray) {
							return (@$retval);
						}
						else {
							return $retval;
						}
					}, 'Class::Prototyped::FieldAccessor::Wantarray';
				}
				return $implementation;
			}
		},

		description => {
			type => 'advisory',
		},
	},

	METHOD => {
		superable => {
			type => 'filter',
			rank => 10,
			code => sub {
				my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_;

				if ($slotAttribs->{superable} = $slotAttribs->{superable} ? 1 : undef) {
					package Class::Prototyped::Mirror::SUPER;
					my $old_implementation = $implementation;
					my $package = ref( ${ $mirror } );
					$implementation = sub {
						local $Class::Prototyped::Mirror::SUPER::package =
							$package;
						&$old_implementation;
					};
					package Class::Prototyped::Mirror;
				}
				return $implementation;
			}
		},

		profile => {
			type => 'filter',
			rank => 90,
			code => sub {
				my($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots) = @_;

				my $profileLevel = $slotAttribs->{profile};
				if ($profileLevel) {
					package Class::Prototyped::Mirror::PROFILE;
					my $old_implementation = $implementation;
					my $package = ref( ${ $mirror } );
					$implementation = sub {
						my $caller = '';
						if ($profileLevel == 2) {
							my($pack, $file, $line) = caller;
							$caller = "$file ($line)";
							$Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}->{$caller}++;
						} else {
							$Class::Prototyped::Mirror::PROFILE::counts->{$package}->{$slotName}++;
						}
						goto &$old_implementation;
					};
				}
				return $implementation;
			},
		},

		overload => {
			type => 'advisory',
		},

		description => {
			type => 'advisory',
		},
	},

	PARENT => {
		description => {
			type => 'advisory',
		},

		promote => {
			type => 'advisory',
		},
	},
};

sub addSlotsParser {
	my $mirror = shift;

	Carp::croak("odd number of arguments to addSlotsParser\n")
		if scalar(@_) % 2;

	my($package, undef, undef, undef, $slots, undef, undef, $defaults) =
		$mirror->_everything();

	my(@retvals);

	while (my($slotThing, $slotValue) = splice(@_, 0, 2)) {
		my($slotName, $slotType, $slotAttribs, $slotImplementor, $slotFilters, $slotAdvisories);
		my $isCode = UNIVERSAL::isa($slotValue, 'CODE');

		if (ref($slotThing) eq 'ARRAY') {
			$slotName = $slotThing->[0];

			my $temp = $slotThing->[1] || '';
			if ($temp eq 'METHOD' || $temp eq 'FIELD' || $temp eq 'PARENT') {
				$slotType = $temp;
				$temp = 2;
			}
			else {
				$slotType = $isCode ? 'METHOD' :
					(substr($slotName, -1) eq '*' ? 'PARENT' : 'FIELD');
				$temp = 1;
			}

			if ($#{$slotThing} >= $temp) {
				if ($#{$slotThing} == $temp) {
					$slotAttribs = defined $defaults->{$slotType}
							? { %{$defaults->{$slotType}}, $slotThing->[$temp] => 1 }
							: { $slotThing->[$temp] => 1 };
				}
				else {
					$slotAttribs = defined $defaults->{$slotType}
							? { %{$defaults->{$slotType}}, @{$slotThing}[$temp..$#{$slotThing}] }
							: { @{$slotThing}[$temp..$#{$slotThing}] };
				}
			}
			elsif (defined $defaults->{$slotType}) {
				$slotAttribs = { %{$defaults->{$slotType}} };
			}

			if ($slotType eq 'METHOD') {
				Carp::croak("it is not permitted to use '!' notation in conjunction with slot attributes")
					if substr($slotName, -1) eq '!';

				Carp::croak("method slots have to have CODE refs as values")
					if !$isCode;
			}
			elsif ($slotType eq 'PARENT') {
				Carp::croak("it is not permitted to use '**' notation in conjunction with slot attributes")
					if substr($slotName, -2, 1) eq '*';
			}
		}
		else {
			$slotName = $slotThing;
			$slotType = $isCode ? 'METHOD' :
				(substr($slotName, -1) eq '*' ? 'PARENT' : 'FIELD');

			if (defined $defaults->{$slotType}) {
				$slotAttribs = { %{$defaults->{$slotType}} };
			}

			# Slots that end in '!' mean that the method is superable
			if ($slotType eq 'METHOD' && substr($slotName, -1) eq '!') {
				$slotName = substr($slotName, 0, -1);
				$slotAttribs->{superable} = 1;
			}

			# Temporary support for &
			if ($slotType eq 'FIELD' && substr($slotName, -1) eq '&') {
				$slotName = substr($slotName, 0, -1);
				$slotAttribs->{constant} = 1;
			}

			# Slots that end in '**' mean to push the slot
			# to the front of the parents list.
			if ($slotType eq 'PARENT' && substr($slotName, -2) eq '**') {
				$slotName = substr($slotName, 0, -1);    # xyz** => xyz*
				$slotAttribs->{promote} = 1;
			}
		}

		if ($slotType eq 'METHOD' && exists($Class::Prototyped::overloadable_symbols{$slotName})) {
			$slotAttribs->{overload} = 1;
		}
		else {
			Carp::croak("can't use slot attribute overload for slots that aren't overloadable")
				if ($slotAttribs->{overload} && !exists($Class::Prototyped::overloadable_symbols{$slotName}));
		}

		Carp::croak("slots should end in * if and only if the type is parent")
			if ( (substr($slotName, -1) eq '*') != ($slotType eq 'PARENT') && !$slotAttribs->{overload} );

		if ($slotName eq '*') {
			$slotName = (ref($slotValue) || $slotValue) . $slotName;
		}

		if(scalar(keys(%{$slotAttribs}))) {
			my $attributes = $Class::Prototyped::Mirror::attributes->{$slotType};

			foreach my $attrib (keys %{$slotAttribs}) {
				Carp::croak("$slotType slots cannot have the '$attrib' attribute.")
					unless exists $attributes->{$attrib};

				my $atype = $attributes->{$attrib}->{type};
				if ($atype eq 'filter') {
					push(@{$slotFilters}, $attrib);
				}
				elsif ($atype eq 'advisory') {
					push(@{$slotAdvisories}, $attrib);
				}
				elsif ($atype eq 'implementor') {
					Carp::croak("slots cannot have more than one implementor.")
						if defined($slotImplementor);
					$slotImplementor = $attributes->{$attrib}->{code} if $slotAttribs->{$attrib};
				}
				else {
					Carp::croak("unknown attribute type '$atype' for '$attrib'.");
				}
			}

			if (defined $slotFilters) {
				@{$slotFilters} = map { $attributes->{$_}->{code} } sort {
						$attributes->{$a}->{rank} <=> $attributes->{$b}->{rank} || $a cmp $b
					} @{$slotFilters};
			}

			if (defined $slotAdvisories) {
				@{$slotAdvisories} = grep {defined} map { $attributes->{$_}->{code} } sort @{ $slotAdvisories };
			}
		}

		Carp::croak("the slot self* is inviolable") if $slotName eq 'self*';

		Carp::croak("Can only use operator names for method slots\nslot: $slotName")
			if ( exists($Class::Prototyped::overloadable_symbols{$slotName}) &&
						$slotType ne 'METHOD' );

		if ($slotType eq 'PARENT') {
			Carp::croak("parent slots cannot be code blocks") if ($isCode);

			unless (UNIVERSAL::isa($slotValue, 'Class::Prototyped')
				|| (ref(\$slotValue) eq 'SCALAR' && defined $slotValue))
			{
				Carp::croak("attempt to add parent that isn't a "
						. "Class::Prototyped or package name\n"
						. "package: $package slot: $slotName parent: $slotValue");
			}

			if (UNIVERSAL::isa($slotValue, $package)) {
				Carp::croak("attempt at recursive inheritance\n"
						. "parent $slotValue is a package $package");
			}
		}
		elsif ($slotType eq 'METHOD') {
			Carp::croak("cannot replace DESTROY method for unnamed objects")
				if ($slotName eq 'DESTROY' && substr($package, 0, PREFIX_LENGTH) eq PREFIX);
		}

		push(@retvals, [$slotName, $slotValue, $slotType, $slotAttribs, $slotImplementor, $slotFilters, $slotAdvisories]);
	}
	return \@retvals;
}

sub addParsedSlots {
	my $mirror = shift;

	my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
		$mirror->_everything();

	while (@{$_[0]}) {
		my($slotName, $slotValue, $slotType, $slotAttribs, $slotImplementor, $slotFilters, $slotAdvisories) = @{ shift @{$_[0]} };

		&deleteSlots($mirror, $slotName) if exists($slots->{$slotName});

		$slots->{$slotName} = $slotValue;    #everything goes into the slots!!!!!

		if ($slotType eq 'PARENT') {
			my $parentPackage = ref($slotValue) || $slotValue;

			if (substr($parentPackage, 0, PREFIX_LENGTH) eq PREFIX) {
				$Class::Prototyped::Mirror::parents{$package}->{$slotName} = $slotValue;
			}
			else {
				Carp::carp(
"it is recommended to use ->reflect->include for mixing in named files."
					)
					if $parentPackage =~ /\.p[lm]$/i;

				no strict 'refs';
				if (!ref($slotValue)
					&& !(scalar keys(%{"$parentPackage\::"})))
				{
					$mirror->include($parentPackage);
				}
			}

			my $splice_point = $slotAttribs->{promote} ? 0 : @$parentOrder;
			delete $slotAttribs->{promote};
			splice(@$isa, $splice_point, 0, $parentPackage);
			{
				#Defends against ISA caching problems
				no strict 'refs';
				delete ${"$package\::"}{'::ISA::CACHE::'};
				@$isa = @$isa;
			}
			splice(@$parentOrder, $splice_point, 0, $slotName);
		}
		else {
			my $implementation = defined $slotImplementor
				? $slotImplementor->($mirror, $slotName, $slotValue, $slotAttribs, undef, $slots)
				: ( $slotType eq 'METHOD'
						? $slotValue
						: bless sub {
								@_ > 1 ? $slots->{$slotName} = $_[1] : $slots->{$slotName};
							}, 'Class::Prototyped::FieldAccessor'
					);

			if (defined $slotFilters) {
				foreach my $filter (@{ $slotFilters }) {
					$implementation =	$filter->($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots);
				}
			}

			if (defined $slotAdvisories) {
				foreach my $advisory (@{ $slotAdvisories }) {
					$advisory->($mirror, $slotName, $slotValue, $slotAttribs, $implementation, $slots);
				}
			}

			if ($slotAttribs->{overload}) {
				eval "package $package;
					use overload '$slotName' => \$implementation, fallback => 1;
							bless \$object, \$package;";
				Carp::croak("Eval failed while defining overload\n"
						. "operation: \"$slotName\" error: $@")
					if $@;
			}
			else {
				no strict 'refs';
				local $^W = 0;    # suppress redefining messages.
				*{"$package\::$slotName"} = $implementation;
			}
			push (@$otherOrder, $slotName);
		}
		$attribs->{$slotName} = $slotAttribs;
		$types->{$slotName} = $slotType;
	}

	return $mirror;
}

sub addSlots {
	my $mirror = shift;
	$mirror->addParsedSlots( $mirror->addSlotsParser(@_) );
}

*addSlot = \&addSlots;            # alias addSlot to addSlots

# $obj->reflect->deleteSlots( name [, name [...]] );
sub deleteSlots {
	my $mirror = shift;
	my (@deleteSlots) = @_;

	my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
		$mirror->_everything;

	foreach my $slot (@deleteSlots) {
		$slot = substr($slot, 0, -1) if substr($slot, -2) eq '**';
		$slot = substr($slot, 0, -1) if substr($slot, -1) eq '!';

		next if !exists($slots->{$slot});

		my $value = $slots->{$slot};

		if (substr($slot, -1) eq '*') {    # parent slot
			my $index = 0;
			1 while ($parentOrder->[$index] ne $slot
				and $index++ < @$parentOrder);

			if ($index < @$parentOrder) {
				splice(@$parentOrder, $index, 1);
				splice(@$isa,         $index, 1);
				{
					#Defends against ISA caching problems
					no strict 'refs';
					delete ${"$package\::"}{'::ISA::CACHE::'};
					@$isa=@$isa;
				}
			}
			else {    # not found

				if (!$Class::Prototyped::Mirror::ending) {
					Carp::cluck "couldn't find $slot in $package\n";
					$DB::single = 1;
				}
			}

			if (defined($value)) {
				my $parentPackage = ref($value);
				if (substr($parentPackage, 0, PREFIX_LENGTH) eq PREFIX) {
					delete
						($Class::Prototyped::Mirror::parents{$package}->{$slot}
						);
				}
			}
			else {

				if (!$Class::Prototyped::Mirror::ending) {
					Carp::cluck "slot undef for $slot in $package\n";
					$DB::single = 1;
				}
			}
		}
		else {

			if (exists($Class::Prototyped::overloadable_symbols{$slot})) {
				Carp::croak(
					"Perl segfaults when the last overload is removed. Boom!\n")
					if (1 == grep {
						exists($Class::Prototyped::overloadable_symbols{$_});
					} keys(%$slots));

				eval "package $package;
					no overload '$slot';
							bless {}, \$package;"
					;    # dummy bless so that overloading works.
				Carp::croak("Eval failed while removing overload\n"
						. "operation: \"$slot\" error: $@")
					if $@;
			}
			else {     # we have a method by that name; delete it
				no strict 'refs';
				my $name = "$package\::$slot";

				# save the glob...
				local *old = *{$name};

				# and restore everything else
				local *new;
				foreach my $type (qw(HASH IO FORMAT SCALAR ARRAY)) {
					my $elem = *old{$type};
					next if !defined($elem);
					*new = $elem;
				}
				*{$name} = *new;
			}
			@$otherOrder = grep { $_ ne $slot } @$otherOrder;
		}
		delete $slots->{$slot};    # and delete the data/sub ref
		delete $types->{$slot};
		delete $attribs->{$slot};
	}

	return $mirror;
}

*deleteSlot = \&deleteSlots;       # alias deleteSlot to deleteSlots

sub super_slow {
	return shift->super_fast(@_)
		if ((caller(1))[0] eq 'Class::Prototyped::Mirror::SUPER');
	return shift->super_fast(@_)
		if ((caller(2))[0] eq 'Class::Prototyped::Mirror::SUPER');
	Carp::croak(
		"attempt to call super on a method that was defined without !\n"
			. "method: " . $_[1]);
}

*super = \&super_slow unless defined(*super{CODE});

sub super_fast {
	my $mirror  = shift;
	my $message = shift;

	$message or Carp::croak("you have to pass the method name to super");

	my $object = ${ $mirror };

	my (@isa);
	{
		no strict 'refs';
		@isa = @{ $Class::Prototyped::Mirror::SUPER::package . '::ISA' };
	}
	my $method;

	foreach my $parentPackage (@isa) {
		$method = UNIVERSAL::can($parentPackage, $message);
		last if $method;
	}
	$method
		or Carp::croak("could not find super in parents\nmessage: $message");
	$method->($object, @_);
}

sub slotNames {
	my $mirror = shift;
	my $type   = shift;

	my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
		$mirror->_everything;

	my @slotNames = (@$parentOrder, @$otherOrder);
	if ($type) {
		@slotNames = grep { $types->{$_} eq $type } @slotNames;
	}
	return wantarray ? @slotNames : \@slotNames;
}

sub slotType {
	my $mirror   = shift;
	my $slotName = shift;

	my $types = $mirror->_types;
	Carp::croak(
		"attempt to determine slotType for unknown slot\nslot: $slotName")
		unless exists $types->{$slotName};
	return $types->{$slotName};
}

# may return dups
sub allSlotNames {
	my $mirror = shift;
	my $type   = shift;

	my @slotNames;
	foreach my $parent ($mirror->withAllParents()) {
		my $mirror = Class::Prototyped::Mirror->new($parent);
		push (@slotNames, $mirror->slotNames($type));
	}
	return wantarray ? @slotNames : \@slotNames;
}

sub parents {
	my $mirror = shift;

	my $object = $mirror->object;
	my $slots  = $mirror->_slots;
	return map { $slots->{$_} } $mirror->slotNames('PARENT');
}

sub allParents {
	my $mirror = shift;
	my $retval = shift || [];
	my $seen   = shift || {};

	foreach my $parent ($mirror->parents) {
		next if $seen->{$parent}++;
		push @$retval, $parent;
		my $mirror = Class::Prototyped::Mirror->new($parent);
		$mirror->allParents($retval, $seen);
	}
	return wantarray ? @$retval : $retval;
}

sub withAllParents {
	my $mirror = shift;

	my $object = $mirror->object;
	my $retval = [$object];
	my $seen   = { $object => 1 };
	$mirror->allParents($retval, $seen);
}

# getSlot returns both the slotName and the slot in array context
# so that it can append !'s to superable methods, so that getSlots does the
# right thing, so that clone does the right thing.
# However, in scalar context, it just returns the value.

sub getSlot {
	my $mirror   = shift;
	my $slot = shift;
	my $format = shift;

	my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
		$mirror->_everything;

	my $value = ($slot ne 'self*') ? $slots->{$slot} : $mirror->object;

	return $value unless wantarray;

	$slot = [$slot, $types->{$slot}, %{$attribs->{$slot} || {}}];

	if (!defined $format || $format eq 'default') {
		return ($slot, $value);
	}
	elsif ($format eq 'simple') {
		return ($slot->[0], $value);
	}
	elsif ($format eq 'rotated') {
		return ($slot->[0], {
				attribs => { @{$slot}[2..$#{$slot}] },
				type => $slot->[1],
				value => $value
			}
		);
	}
}

sub getSlots {
	my $mirror = shift;
	my $type   = shift;
	my $format = shift;

	my @retval;
	if (defined $type || defined $format) {
		@retval = map { $mirror->getSlot($_, $format) } $mirror->slotNames($type);
	}
	else {
		my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
			$mirror->_everything;
		@retval = map {
			([$_, $types->{$_}, %{$attribs->{$_} || {}}] => $slots->{$_})
		} (@$parentOrder, @$otherOrder);
	}

	return wantarray ? @retval : \@retval;
}

sub promoteParents {
	my $mirror = shift;
	my (@newOrder) = @_;

	my($package, $isa, $parentOrder, $otherOrder, $slots, $types, $attribs, undef) =
		$mirror->_everything;

	my %seen;
	foreach my $slot (@newOrder) {
		$seen{$slot}++;
		if ($seen{$slot} > 1 || !exists($slots->{$slot})) {
			Carp::croak("promoteParents called with bad order list\nlist: @_");
		}
		else {
			@{$parentOrder} = grep { $_ ne $slot } @{$parentOrder};
		}
	}

	@{$parentOrder} = (@newOrder, @{$parentOrder});

	@$isa =
		((map { ref($slots->{$_}) ? ref($slots->{$_}) : $slots->{$_} }
				@{$parentOrder}), 'Class::Prototype');

	# this is required to re-cache @ISA
	no strict 'refs';
	delete ${"$package\::"}{'::ISA::CACHE::'};
	@$isa=@$isa;
}

sub wrap {
	my $mirror        = shift;
	my $class         = $mirror->class || 'Class::Prototyped';
	my $wrapped       = $class->new;
	my $wrappedMirror = $wrapped->reflect;

	# add all the slots from the original object
	$wrappedMirror->addSlots($mirror->getSlots);

	# delete all my original slots
	# so that the wrapped gets called
	$mirror->deleteSlots($mirror->slotNames);
	$mirror->addSlots(@_, [qw(wrapped* promote)] => $wrapped);
	$mirror;
}

sub unwrap {
	my $mirror  = shift;
	my $wrapped = $mirror->getSlot('wrapped*')
		or Carp::croak "unwrapping without a wrapped\n";
	my $wrappedMirror = $wrapped->reflect;
	$mirror->deleteSlots($mirror->slotNames);
	$mirror->addSlots($wrappedMirror->getSlots);

	#  $wrappedMirror->deleteSlots( $wrappedMirror->slotNames );
	$mirror;
}

sub delegate {
	my $mirror = shift;

	while (my ($name, $value) = splice(@_, 0, 2)) {
		my @names = (UNIVERSAL::isa($name, 'ARRAY') ? @$name : $name);
		my @conflicts;

		foreach my $slotName (@names) {
			push (@conflicts, grep { $_ eq $slotName } $mirror->slotNames);
		}
		Carp::croak(
			"delegate would cause conflict with existing slots\n" . "pattern: "
				. join ('|',  @names) . " , conflicting slots: "
				. join (', ', @conflicts))
			if @conflicts;

		my $delegateMethod;
		if (UNIVERSAL::isa($value, 'ARRAY')) {
			$delegateMethod = $value->[1];
			$value          = $value->[0];
		}
		my $delegate = $mirror->getSlot($value) || $value;
		Carp::croak("Can't delegate to a subroutine\nslot: $name")
			if (UNIVERSAL::isa($delegate, 'CODE'));

		foreach my $slotName (@names) {
			my $method = defined($delegateMethod) ? $delegateMethod : $slotName;
			$mirror->addSlot(
				$slotName => sub {
					shift;    # discard original recipient
					$delegate->$method(@_);
					}
			);
		}
	}
}

sub findImplementation {
	my $mirror   = shift;
	my $slotName = shift;

	my $object = $mirror->object;
	UNIVERSAL::can($object, $slotName) or return;

	my $slots = $mirror->_slots;
	exists $slots->{$slotName} and return wantarray ? 'self*' : $object;

	foreach my $parentName ($mirror->slotNames('PARENT')) {
		my $mirror =
			Class::Prototyped::Mirror->new(
			scalar($mirror->getSlot($parentName)));
		if (wantarray) {
			my (@retval) = $mirror->findImplementation($slotName);
			scalar(@retval) and return ($parentName, @retval);
		}
		else {
			my $retval = $mirror->findImplementation($slotName);
			$retval and return $retval;
		}
	}
	Carp::croak("fatal error in findImplementation");
}

# load the given file or package in the receiver's namespace
# Note that no import is done.
# Croaks on an eval error
#
#   $mirror->include('Package');
#   $mirror->include('File.pl');
#
#   $mirror->include('File.pl', 'thisObject');
#   makes thisObject() return the object into which the include
#   is happening (as long as you don't change packages in the
#   included code)
sub include {
	my $mirror       = shift;
	my $name         = shift;
	my $accessorName = shift;

	$name = "'$name'" if $name =~ /\.p[lm]$/i;

	my $object  = $mirror->object;
	my $package = $mirror->package;
	my $text    = "package $package;\n";
	$text .= "*$package\::$accessorName = sub { \$object };\n"
		if defined($accessorName);

	#  $text .= "sub $accessorName { \$object };\n" if defined($accessorName);
	$text .= "require $name;\n";
	my $retval = eval $text;
	Carp::croak("include failed\npackage: $package include: $name error: $@")
		if $@;

	if (substr($name, -1) eq "'") {
		$mirror->_vivified_methods(0);
		$mirror->_autovivify_methods;
	}

	$mirror->deleteSlots($accessorName) if defined($accessorName);
}

1;
__END__