File Coverage

blib/lib/Scalar/Random/PP/OO.pm

Criterion	Covered	Total	%
statement	691	2189	31.5
branch	140	902	15.5
condition	40	398	10.0
subroutine	150	430	34.8
pod	0	230	0.0
total	1021	4149	24.6

# This file was generated by Scalar::Random::PP::OO::Maker 0.07 from Mouse 0.70.
#
# ANY CHANGES MADE HERE WILL BE LOST!
use strict;
use warnings;

# tell Perl we already have all of the Scalar::Random::PP::OO files loaded:
BEGIN {
	$INC{'Scalar/Random/PP/OO.pm'}                             = __FILE__;
	$INC{'Scalar/Random/PP/OO/Exporter.pm'}                    = __FILE__;
	$INC{'Scalar/Random/PP/OO/Object.pm'}                      = __FILE__;
	$INC{'Scalar/Random/PP/OO/PurePerl.pm'}                    = __FILE__;
	$INC{'Scalar/Random/PP/OO/Role.pm'}                        = __FILE__;
	$INC{'Scalar/Random/PP/OO/Util.pm'}                        = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Attribute.pm'}              = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Class.pm'}                  = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Method.pm'}                 = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Module.pm'}                 = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Role.pm'}                   = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/TypeConstraint.pm'}         = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Method/Accessor.pm'}        = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Method/Constructor.pm'}     = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Method/Delegation.pm'}      = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Method/Destructor.pm'}      = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Role/Composite.pm'}         = __FILE__;
	$INC{'Scalar/Random/PP/OO/Meta/Role/Method.pm'}            = __FILE__;
	$INC{'Scalar/Random/PP/OO/Util/MetaRole.pm'}               = __FILE__;
	$INC{'Scalar/Random/PP/OO/Util/TypeConstraints.pm'}        = __FILE__;
}

# and now their contents

# Contents of Mouse::PurePerl
package Scalar::Random::PP::OO::PurePerl;
# The pure Perl backend for Mousse
package Scalar::Random::PP::OO::Util;
use strict;
use warnings;
use warnings FATAL => 'redefine'; # to avoid to load Scalar::Random::PP::OO::PurePerl twice

use B ();

require Scalar::Random::PP::OO::Util;


# taken from Class/MOP.pm
sub is_valid_class_name {
	my $class = shift;

	return 0 if ref($class);
	return 0 unless defined($class);

	return 1 if $class =~ /\A \w+ (?: :: \w+ )* \z/xms;

	return 0;
}

sub is_class_loaded {
	my $class = shift;

	return 0 if ref($class) || !defined($class) || !length($class);

	# walk the symbol table tree to avoid autovififying
	# \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::

	my $pack = \%::;
	foreach my $part (split('::', $class)) {
		$part .= '::';
		return 0 if !exists $pack->{$part};

		my $entry = \$pack->{$part};
		return 0 if ref($entry) ne 'GLOB';
		$pack = *{$entry}{HASH};
	}

	return 0 if !%{$pack};

	# check for $VERSION or @ISA
	return 1 if exists $pack->{VERSION}
			 && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
	return 1 if exists $pack->{ISA}
			 && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;

	# check for any method
	foreach my $name( keys %{$pack} ) {
		my $entry = \$pack->{$name};
		return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
	}

	# fail
	return 0;
}


# taken from Sub::Identify
sub get_code_info {
	my ($coderef) = @_;
	ref($coderef) or return;

	my $cv = B::svref_2object($coderef);
	$cv->isa('B::CV') or return;

	my $gv = $cv->GV;
	$gv->isa('B::GV') or return;

	return ($gv->STASH->NAME, $gv->NAME);
}

sub get_code_package{
	my($coderef) = @_;

	my $cv = B::svref_2object($coderef);
	$cv->isa('B::CV') or return '';

	my $gv = $cv->GV;
	$gv->isa('B::GV') or return '';

	return $gv->STASH->NAME;
}

sub get_code_ref{
	my($package, $name) = @_;
	no strict 'refs';
	no warnings 'once';
	use warnings FATAL => 'uninitialized';
	return *{$package . '::' . $name}{CODE};
}

sub generate_isa_predicate_for {
	my($for_class, $name) = @_;

	my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) };

	if(defined $name){
		Scalar::Random::PP::OO::Util::install_subroutines(scalar caller, $name => $predicate);
		return;
	}

	return $predicate;
}

sub generate_can_predicate_for {
	my($methods_ref, $name) = @_;

	my @methods = @{$methods_ref};

	my $predicate = sub{
		my($instance) = @_;
		if(Scalar::Util::blessed($instance)){
			foreach my $method(@methods){
				if(!$instance->can($method)){
					return 0;
				}
			}
			return 1;
		}
		return 0;
	};

	if(defined $name){
		Scalar::Random::PP::OO::Util::install_subroutines(scalar caller, $name => $predicate);
		return;
	}

	return $predicate;
}

package Scalar::Random::PP::OO::Util::TypeConstraints;

use Scalar::Util qw(blessed looks_like_number openhandle);

sub Any        { 1 }
sub Item       { 1 }

sub Bool       { $_[0] ? $_[0] eq '1' : 1 }
sub Undef      { !defined($_[0]) }
sub Defined    {  defined($_[0])  }
sub Value      {  defined($_[0]) && !ref($_[0]) }
sub Num        {  looks_like_number($_[0]) }
sub Int        {
	my($value) = @_;
	looks_like_number($value) && $value =~ /\A [+-]? [0-9]+  \z/xms;
}
sub Str        {
	my($value) = @_;
	return defined($value) && ref(\$value) eq 'SCALAR';
}

sub Ref        { ref($_[0]) }
sub ScalarRef  {
	my($value) = @_;
	return ref($value) eq 'SCALAR'
}
sub ArrayRef   { ref($_[0]) eq 'ARRAY'  }
sub HashRef    { ref($_[0]) eq 'HASH'   }
sub CodeRef    { ref($_[0]) eq 'CODE'   }
sub RegexpRef  { ref($_[0]) eq 'Regexp' }
sub GlobRef    { ref($_[0]) eq 'GLOB'   }

sub FileHandle {
	return openhandle($_[0])  || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
}

sub Object     { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }

sub ClassName  { Scalar::Random::PP::OO::Util::is_class_loaded($_[0]) }
sub RoleName   { (Scalar::Random::PP::OO::Util::class_of($_[0]) || return 0)->isa('Scalar::Random::PP::OO::Meta::Role') }

sub _parameterize_ArrayRef_for {
	my($type_parameter) = @_;
	my $check = $type_parameter->_compiled_type_constraint;

	return sub {
		foreach my $value (@{$_}) {
			return undef unless $check->($value);
		}
		return 1;
	}
}

sub _parameterize_HashRef_for {
	my($type_parameter) = @_;
	my $check = $type_parameter->_compiled_type_constraint;

	return sub {
		foreach my $value(values %{$_}){
			return undef unless $check->($value);
		}
		return 1;
	};
}

# 'Maybe' type accepts 'Any', so it requires parameters
sub _parameterize_Maybe_for {
	my($type_parameter) = @_;
	my $check = $type_parameter->_compiled_type_constraint;

	return sub{
		return !defined($_) || $check->($_);
	};
}

package Scalar::Random::PP::OO::Meta::Module;

sub name          { $_[0]->{package} }

sub _method_map   { $_[0]->{methods} }
sub _attribute_map{ $_[0]->{attributes} }

sub namespace{
	my $name = $_[0]->{package};
	no strict 'refs';
	return \%{ $name . '::' };
}

sub add_method {
	my($self, $name, $code) = @_;

	if(!defined $name){
		$self->throw_error('You must pass a defined name');
	}
	if(!defined $code){
		$self->throw_error('You must pass a defined code');
	}

	if(ref($code) ne 'CODE'){
		$code = \&{$code}; # coerce
	}

	$self->{methods}->{$name} = $code; # Moose stores meta object here.

	Scalar::Random::PP::OO::Util::install_subroutines($self->name,
		$name => $code,
	);
	return;
}

package Scalar::Random::PP::OO::Meta::Class;

use Scalar::Random::PP::OO::Meta::Method::Constructor;
use Scalar::Random::PP::OO::Meta::Method::Destructor;

sub method_metaclass    { $_[0]->{method_metaclass}    || 'Scalar::Random::PP::OO::Meta::Method'    }
sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Scalar::Random::PP::OO::Meta::Attribute' }

sub constructor_class { $_[0]->{constructor_class} || 'Scalar::Random::PP::OO::Meta::Method::Constructor' }
sub destructor_class  { $_[0]->{destructor_class}  || 'Scalar::Random::PP::OO::Meta::Method::Destructor'  }

sub is_anon_class{
	return exists $_[0]->{anon_serial_id};
}

sub roles { $_[0]->{roles} }

sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } }

sub get_all_attributes {
	my($self) = @_;
	my %attrs = map { %{ $self->initialize($_)->{attributes} } } reverse $self->linearized_isa;
	return values %attrs;
}

sub new_object {
	my $meta = shift;
	my %args = (@_ == 1 ? %{$_[0]} : @_);

	my $object = bless {}, $meta->name;

	$meta->_initialize_object($object, \%args);
	# BUILDALL
	if( $object->can('BUILD') ) {
		for my $class (reverse $meta->linearized_isa) {
			my $build = Scalar::Random::PP::OO::Util::get_code_ref($class, 'BUILD')
				|| next;

			$object->$build(\%args);
		}
	}
	return $object;
}

sub clone_object {
	my $class  = shift;
	my $object = shift;
	my $args   = $object->Scalar::Random::PP::OO::Object::BUILDARGS(@_);

	(blessed($object) && $object->isa($class->name))
		|| $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");

	my $cloned = bless { %$object }, ref $object;
	$class->_initialize_object($cloned, $args, 1);

	return $cloned;
}

sub _initialize_object{
	my($self, $object, $args, $is_cloning) = @_;

	my @triggers_queue;

	my $used = 0;

	foreach my $attribute ($self->get_all_attributes) {
		my $init_arg = $attribute->init_arg;
		my $slot     = $attribute->name;

		if (defined($init_arg) && exists($args->{$init_arg})) {
			$object->{$slot} = $attribute->_coerce_and_verify($args->{$init_arg}, $object);

			weaken($object->{$slot})
				if ref($object->{$slot}) && $attribute->is_weak_ref;

			if ($attribute->has_trigger) {
				push @triggers_queue, [ $attribute->trigger, $object->{$slot} ];
			}
			$used++;
		}
		else { # no init arg
			if ($attribute->has_default || $attribute->has_builder) {
				if (!$attribute->is_lazy && !exists $object->{$slot}) {
					my $default = $attribute->default;
					my $builder = $attribute->builder;
					my $value =   $builder                ? $object->$builder()
								: ref($default) eq 'CODE' ? $object->$default()
								:                           $default;

					$object->{$slot} = $attribute->_coerce_and_verify($value, $object);

					weaken($object->{$slot})
						if ref($object->{$slot}) && $attribute->is_weak_ref;
				}
			}
			elsif(!$is_cloning && $attribute->is_required) {
				$self->throw_error("Attribute (".$attribute->name.") is required");
			}
		}
	}

	if($used < keys %{$args} && $self->strict_constructor) {
		$self->_report_unknown_args([ $self->get_all_attributes ], $args);
	}

	if(@triggers_queue){
		foreach my $trigger_and_value(@triggers_queue){
			my($trigger, $value) = @{$trigger_and_value};
			$trigger->($object, $value);
		}
	}

	if($self->is_anon_class){
		$object->{__METACLASS__} = $self;
	}

	return;
}

sub is_immutable {  $_[0]->{is_immutable} }

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

	foreach my $class($self->linearized_isa) {
		my $meta = Scalar::Random::PP::OO::Util::get_metaclass_by_name($class)
			or next;

		if(exists $meta->{strict_constructor}) {
			return $meta->{strict_constructor};
		}
	}

	return 0; # false
}

sub _report_unknown_args {
	my($metaclass, $attrs, $args) = @_;

	my @unknowns;
	my %init_args;
	foreach my $attr(@{$attrs}){
		my $init_arg = $attr->init_arg;
		if(defined $init_arg){
			$init_args{$init_arg}++;
		}
	}

	while(my $key = each %{$args}){
		if(!exists $init_args{$key}){
			push @unknowns, $key;
		}
	}

	$metaclass->throw_error( sprintf
		"Unknown attribute passed to the constructor of %s: %s",
		$metaclass->name, Scalar::Random::PP::OO::Util::english_list(@unknowns),
	);
}

package Scalar::Random::PP::OO::Meta::Role;

sub method_metaclass{ $_[0]->{method_metaclass} || 'Scalar::Random::PP::OO::Meta::Role::Method' }

sub is_anon_role{
	return exists $_[0]->{anon_serial_id};
}

sub get_roles { $_[0]->{roles} }

sub add_before_method_modifier {
	my ($self, $method_name, $method) = @_;

	push @{ $self->{before_method_modifiers}{$method_name} ||= [] }, $method;
	return;
}
sub add_around_method_modifier {
	my ($self, $method_name, $method) = @_;

	push @{ $self->{around_method_modifiers}{$method_name} ||= [] }, $method;
	return;
}
sub add_after_method_modifier {
	my ($self, $method_name, $method) = @_;

	push @{ $self->{after_method_modifiers}{$method_name} ||= [] }, $method;
	return;
}

sub get_before_method_modifiers {
	my ($self, $method_name) = @_;
	return @{ $self->{before_method_modifiers}{$method_name} ||= [] }
}
sub get_around_method_modifiers {
	my ($self, $method_name) = @_;
	return @{ $self->{around_method_modifiers}{$method_name} ||= [] }
}
sub get_after_method_modifiers {
	my ($self, $method_name) = @_;
	return @{ $self->{after_method_modifiers}{$method_name} ||= [] }
}

package Scalar::Random::PP::OO::Meta::Attribute;

require Scalar::Random::PP::OO::Meta::Method::Accessor;

sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Scalar::Random::PP::OO::Meta::Method::Accessor' }

# readers

sub name                 { $_[0]->{name}                   }
sub associated_class     { $_[0]->{associated_class}       }

sub accessor             { $_[0]->{accessor}               }
sub reader               { $_[0]->{reader}                 }
sub writer               { $_[0]->{writer}                 }
sub predicate            { $_[0]->{predicate}              }
sub clearer              { $_[0]->{clearer}                }
sub handles              { $_[0]->{handles}                }

sub _is_metadata         { $_[0]->{is}                     }
sub is_required          { $_[0]->{required}               }
sub default              { $_[0]->{default}                }
sub is_lazy              { $_[0]->{lazy}                   }
sub is_lazy_build        { $_[0]->{lazy_build}             }
sub is_weak_ref          { $_[0]->{weak_ref}               }
sub init_arg             { $_[0]->{init_arg}               }
sub type_constraint      { $_[0]->{type_constraint}        }

sub trigger              { $_[0]->{trigger}                }
sub builder              { $_[0]->{builder}                }
sub should_auto_deref    { $_[0]->{auto_deref}             }
sub should_coerce        { $_[0]->{coerce}                 }

sub documentation        { $_[0]->{documentation}          }
sub insertion_order      { $_[0]->{insertion_order}        }

# predicates

sub has_accessor         { exists $_[0]->{accessor}        }
sub has_reader           { exists $_[0]->{reader}          }
sub has_writer           { exists $_[0]->{writer}          }
sub has_predicate        { exists $_[0]->{predicate}       }
sub has_clearer          { exists $_[0]->{clearer}         }
sub has_handles          { exists $_[0]->{handles}         }

sub has_default          { exists $_[0]->{default}         }
sub has_type_constraint  { exists $_[0]->{type_constraint} }
sub has_trigger          { exists $_[0]->{trigger}         }
sub has_builder          { exists $_[0]->{builder}         }

sub has_documentation    { exists $_[0]->{documentation}   }

sub _process_options{
	my($class, $name, $args) = @_;

	# taken from Class::MOP::Attribute::new

	defined($name)
		or $class->throw_error('You must provide a name for the attribute');

	if(!exists $args->{init_arg}){
		$args->{init_arg} = $name;
	}

	# 'required' requires eigher 'init_arg', 'builder', or 'default'
	my $can_be_required = defined( $args->{init_arg} );

	if(exists $args->{builder}){
		# XXX:
		# Moose refuses a CODE ref builder, but Scalar::Random::PP::OO doesn't for backward compatibility
		# This feature will be changed in a future. (gfx)
		$class->throw_error('builder must be a defined scalar value which is a method name')
			#if ref $args->{builder} || !defined $args->{builder};
			if !defined $args->{builder};

		$can_be_required++;
	}
	elsif(exists $args->{default}){
		if(ref $args->{default} && ref($args->{default}) ne 'CODE'){
			$class->throw_error("References are not allowed as default values, you must "
							  . "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])");
		}
		$can_be_required++;
	}

	if( $args->{required} && !$can_be_required ) {
		$class->throw_error("You cannot have a required attribute ($name) without a default, builder, or an init_arg");
	}

	# taken from Scalar::Random::PP::OO::Meta::Attribute->new and ->_process_args

	if(exists $args->{is}){
		my $is = $args->{is};

		if($is eq 'ro'){
			$args->{reader} ||= $name;
		}
		elsif($is eq 'rw'){
			if(exists $args->{writer}){
				$args->{reader} ||= $name;
			 }
			 else{
				$args->{accessor} ||= $name;
			 }
		}
		elsif($is eq 'bare'){
			# do nothing, but don't complain (later) about missing methods
		}
		else{
			$is = 'undef' if !defined $is;
			$class->throw_error("I do not understand this option (is => $is) on attribute ($name)");
		}
	}

	my $tc;
	if(exists $args->{isa}){
		$tc = $args->{type_constraint} = Scalar::Random::PP::OO::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
	}

	if(exists $args->{does}){
		if(defined $tc){ # both isa and does supplied
			my $does_ok = do{
				local $@;
				eval{ "$tc"->does($args) };
			};
			if(!$does_ok){
				$class->throw_error("Cannot have both an isa option and a does option because '$tc' does not do '$args->{does}' on attribute ($name)");
			}
		}
		else {
			$tc = $args->{type_constraint} = Scalar::Random::PP::OO::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
		}
	}

	if($args->{coerce}){
		defined($tc)
			|| $class->throw_error("You cannot have coercion without specifying a type constraint on attribute ($name)");

		$args->{weak_ref}
			&& $class->throw_error("You cannot have a weak reference to a coerced value on attribute ($name)");
	}

	if ($args->{lazy_build}) {
		exists($args->{default})
			&& $class->throw_error("You can not use lazy_build and default for the same attribute ($name)");

		$args->{lazy}      = 1;
		$args->{builder} ||= "_build_${name}";
		if ($name =~ /^_/) {
			$args->{clearer}   ||= "_clear${name}";
			$args->{predicate} ||= "_has${name}";
		}
		else {
			$args->{clearer}   ||= "clear_${name}";
			$args->{predicate} ||= "has_${name}";
		}
	}

	if ($args->{auto_deref}) {
		defined($tc)
			|| $class->throw_error("You cannot auto-dereference without specifying a type constraint on attribute ($name)");

		( $tc->is_a_type_of('ArrayRef') || $tc->is_a_type_of('HashRef') )
			|| $class->throw_error("You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)");
	}

	if (exists $args->{trigger}) {
		('CODE' eq ref $args->{trigger})
			|| $class->throw_error("Trigger must be a CODE ref on attribute ($name)");
	}

	if ($args->{lazy}) {
		(exists $args->{default} || defined $args->{builder})
			|| $class->throw_error("You cannot have lazy attribute ($name) without specifying a default value for it");
	}

	return;
}


package Scalar::Random::PP::OO::Meta::TypeConstraint;

sub name    { $_[0]->{name}    }
sub parent  { $_[0]->{parent}  }
sub message { $_[0]->{message} }

sub type_parameter           { $_[0]->{type_parameter} }
sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
sub _compiled_type_coercion  { $_[0]->{_compiled_type_coercion}  }

sub __is_parameterized { exists $_[0]->{type_parameter} }
sub has_coercion {       exists $_[0]->{_compiled_type_coercion} }


sub compile_type_constraint{
	my($self) = @_;

	# add parents first
	my @checks;
	for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){
		 if($parent->{hand_optimized_type_constraint}){
			unshift @checks, $parent->{hand_optimized_type_constraint};
			last; # a hand optimized constraint must include all the parents
		}
		elsif($parent->{constraint}){
			unshift @checks, $parent->{constraint};
		}
	}

	# then add child
	if($self->{constraint}){
		push @checks, $self->{constraint};
	}

	if($self->{type_constraints}){ # Union
		my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} };
		push @checks, sub{
			foreach my $c(@types){
				return 1 if $c->($_[0]);
			}
			return 0;
		};
	}

	if(@checks == 0){
		$self->{compiled_type_constraint} = \&Scalar::Random::PP::OO::Util::TypeConstraints::Any;
	}
	else{
		$self->{compiled_type_constraint} =  sub{
			my(@args) = @_;
			local $_ = $args[0];
			foreach my $c(@checks){
				return undef if !$c->(@args);
			}
			return 1;
		};
	}
	return;
}

sub check {
	my $self = shift;
	return $self->_compiled_type_constraint->(@_);
}


package Scalar::Random::PP::OO::Object;

sub BUILDARGS {
	my $class = shift;

	if (scalar @_ == 1) {
		(ref($_[0]) eq 'HASH')
			|| $class->meta->throw_error("Single parameters to new() must be a HASH ref");

		return {%{$_[0]}};
	}
	else {
		return {@_};
	}
}

sub new {
	my $class = shift;

	$class->meta->throw_error('Cannot call new() on an instance') if ref $class;

	my $args = $class->BUILDARGS(@_);

	my $meta = Scalar::Random::PP::OO::Meta::Class->initialize($class);
	return $meta->new_object($args);
}

sub DESTROY {
	my $self = shift;

	return unless $self->can('DEMOLISH'); # short circuit

	local $?;

	my $e = do{
		local $@;
		eval{
			# DEMOLISHALL

			# We cannot count on being able to retrieve a previously made
			# metaclass, _or_ being able to make a new one during global
			# destruction. However, we should still be able to use mro at
			# that time (at least tests suggest so ;)

			foreach my $class (@{ Scalar::Random::PP::OO::Util::get_linear_isa(ref $self) }) {
				my $demolish = Scalar::Random::PP::OO::Util::get_code_ref($class, 'DEMOLISH')
					|| next;

				$self->$demolish($Scalar::Random::PP::OO::Util::in_global_destruction);
			}
		};
		$@;
	};

	no warnings 'misc';
	die $e if $e; # rethrow
}

sub BUILDALL {
	my $self = shift;

	# short circuit
	return unless $self->can('BUILD');

	for my $class (reverse $self->meta->linearized_isa) {
		my $build = Scalar::Random::PP::OO::Util::get_code_ref($class, 'BUILD')
			|| next;

		$self->$build(@_);
	}
	return;
}

sub DEMOLISHALL;
*DEMOLISHALL = \&DESTROY;

# Contents of Mouse::Exporter
package Scalar::Random::PP::OO::Exporter;
use strict;
use warnings;

use Carp ();

my %SPEC;

my $strict_bits;
BEGIN{ $strict_bits = strict::bits(qw(subs refs vars)); }

my $warnings_extra_bits;
BEGIN{ $warnings_extra_bits = warnings::bits(FATAL => 'recursion') }

# it must be "require", because Scalar::Random::PP::OO::Util depends on Scalar::Random::PP::OO::Exporter,
# which depends on Scalar::Random::PP::OO::Util::import()
require Scalar::Random::PP::OO::Util;

sub import{
	# strict->import;
	$^H              |= $strict_bits;
	# warnings->import('all', FATAL => 'recursion');
	${^WARNING_BITS} |= $warnings::Bits{all};
	${^WARNING_BITS} |= $warnings_extra_bits;
	return;
}


sub setup_import_methods{
	my($class, %args) = @_;

	my $exporting_package = $args{exporting_package} ||= caller();

	my($import, $unimport) = $class->build_import_methods(%args);

	Scalar::Random::PP::OO::Util::install_subroutines($exporting_package,
		import   => $import,
		unimport => $unimport,

		export_to_level => sub {
			my($package, $level, undef, @args) = @_; # the third argument is redundant
			$package->import({ into_level => $level + 1 }, @args);
		},
		export => sub {
			my($package, $into, @args) = @_;
			$package->import({ into => $into }, @args);
		},
	);
	return;
}

sub build_import_methods{
	my($self, %args) = @_;

	my $exporting_package = $args{exporting_package} ||= caller();

	$SPEC{$exporting_package} = \%args;

	# canonicalize args
	my @export_from;
	if($args{also}){
		my %seen;
		my @stack = ($exporting_package);

		while(my $current = shift @stack){
			push @export_from, $current;

			my $also = $SPEC{$current}{also} or next;
			push @stack, grep{ !$seen{$_}++ } ref($also) ? @{ $also } : $also;
		}
	}
	else{
		@export_from = ($exporting_package);
	}

	my %exports;
	my @removables;
	my @all;

	my @init_meta_methods;

	foreach my $package(@export_from){
		my $spec = $SPEC{$package} or next;

		if(my $as_is = $spec->{as_is}){
			foreach my $thingy (@{$as_is}){
				my($code_package, $code_name, $code);

				if(ref($thingy)){
					$code = $thingy;
					($code_package, $code_name) = Scalar::Random::PP::OO::Util::get_code_info($code);
				}
				else{
					$code_package = $package;
					$code_name    = $thingy;
					no strict 'refs';
					$code         = \&{ $code_package . '::' . $code_name };
			   }

				push @all, $code_name;
				$exports{$code_name} = $code;
				if($code_package eq $package){
					push @removables, $code_name;
				}
			}
		}

		if(my $init_meta = $package->can('init_meta')){
			if(!grep{ $_ == $init_meta } @init_meta_methods){
				push @init_meta_methods, $init_meta;
			}
		}
	}
	$args{EXPORTS}    = \%exports;
	$args{REMOVABLES} = \@removables;

	$args{groups}{all}     ||= \@all;

	if(my $default_list = $args{groups}{default}){
		my %default;
		foreach my $keyword(@{$default_list}){
			$default{$keyword} = $exports{$keyword}
				|| Carp::confess(qq{The $exporting_package package does not export "$keyword"});
		}
		$args{DEFAULT} = \%default;
	}
	else{
		$args{groups}{default} ||= \@all;
		$args{DEFAULT}           = $args{EXPORTS};
	}

	if(@init_meta_methods){
		$args{INIT_META} = \@init_meta_methods;
	}

	return (\&do_import, \&do_unimport);
}


# the entity of general import()
sub do_import {
	my($package, @args) = @_;

	my $spec = $SPEC{$package}
		|| Carp::confess("The package $package package does not use Scalar::Random::PP::OO::Exporter");

	my $into = _get_caller_package(ref($args[0]) ? shift @args : undef);

	my @exports;
	my @traits;

	while(@args){
		my $arg = shift @args;
		if($arg =~ s/^-//){
			if($arg eq 'traits'){
				push @traits, ref($args[0]) ? @{shift(@args)} : shift(@args);
			}
			else {
				Scalar::Random::PP::OO::Util::not_supported("-$arg");
			}
		}
		elsif($arg =~ s/^://){
			my $group = $spec->{groups}{$arg}
				|| Carp::confess(qq{The $package package does not export the group "$arg"});
			push @exports, @{$group};
		}
		else{
			push @exports, $arg;
		}
	}

	# strict->import;
	$^H              |= $strict_bits;
	# warnings->import('all', FATAL => 'recursion');
	${^WARNING_BITS} |= $warnings::Bits{all};
	${^WARNING_BITS} |= $warnings_extra_bits;

	if($spec->{INIT_META}){
		my $meta;
		foreach my $init_meta(@{$spec->{INIT_META}}){
			$meta = $package->$init_meta(for_class => $into);
		}

		if(@traits){
			my $type = (split /::/, ref $meta)[-1]; # e.g. "Class" for "My::Meta::Class"
			@traits =
				map{
					ref($_) ? $_
							: Scalar::Random::PP::OO::Util::resolve_metaclass_alias($type => $_, trait => 1)
				} @traits;

			require Scalar::Random::PP::OO::Util::MetaRole;
			Scalar::Random::PP::OO::Util::MetaRole::apply_metaroles(
				for       => $into,
				Scalar::Random::PP::OO::Util::is_a_metarole($into->meta)
					? (role_metaroles  => { role  => \@traits })
					: (class_metaroles => { class => \@traits }),
			);
		}
	}
	elsif(@traits){
		Carp::confess("Cannot provide traits when $package does not have an init_meta() method");
	}

	if(@exports){
		my @export_table;
		foreach my $keyword(@exports){
			push @export_table,
				$keyword => ($spec->{EXPORTS}{$keyword}
					|| Carp::confess(qq{The $package package does not export "$keyword"})
				);
		}
		Scalar::Random::PP::OO::Util::install_subroutines($into, @export_table);
	}
	else{
		Scalar::Random::PP::OO::Util::install_subroutines($into, %{$spec->{DEFAULT}});
	}
	return;
}

# the entity of general unimport()
sub do_unimport {
	my($package, $arg) = @_;

	my $spec = $SPEC{$package}
		|| Carp::confess("The package $package does not use Scalar::Random::PP::OO::Exporter");

	my $from = _get_caller_package($arg);

	my $stash = do{
		no strict 'refs';
		\%{$from . '::'}
	};

	for my $keyword (@{ $spec->{REMOVABLES} }) {
		next if !exists $stash->{$keyword};
		my $gv = \$stash->{$keyword};
		if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us
			delete $stash->{$keyword};
		}
	}
	return;
}

sub _get_caller_package {
	my($arg) = @_;

	# We need one extra level because it's called by import so there's a layer
	# of indirection
	if(ref $arg){
		return defined($arg->{into})       ? $arg->{into}
			 : defined($arg->{into_level}) ? scalar caller(1 + $arg->{into_level})
			 :                               scalar caller(1);
	}
	else{
		return scalar caller(1);
	}
}

#sub _spec{ %SPEC }

# Contents of Mouse::Util
package Scalar::Random::PP::OO::Util;
use Scalar::Random::PP::OO::Exporter; # enables strict and warnings
no warnings 'once';

# must be here because it will be refered by other modules loaded
sub get_linear_isa($;$); ## no critic

# must be here because it will called in Scalar::Random::PP::OO::Exporter
sub install_subroutines {
	my $into = shift;

	while(my($name, $code) = splice @_, 0, 2){
		no strict 'refs';
		no warnings 'once', 'redefine';
		use warnings FATAL => 'uninitialized';
		*{$into . '::' . $name} = \&{$code};
	}
	return;
}

BEGIN{
	# This is used in Scalar::Random::PP::OO::PurePerl
	Scalar::Random::PP::OO::Exporter->setup_import_methods(
		as_is => [qw(
			find_meta
			does_role
			resolve_metaclass_alias
			apply_all_roles
			english_list

			load_class
			is_class_loaded

			get_linear_isa
			get_code_info

			get_code_package
			get_code_ref

			not_supported

			does meta dump
		)],
		groups => {
			default => [], # export no functions by default

			# The ':meta' group is 'use metaclass' for Mousse
			meta    => [qw(does meta dump)],
		},
	);

	our $VERSION = '0.70';

	my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});

	# Because Scalar::Random::PP::OO::Util is loaded first in all the Scalar::Random::PP::OO sub-modules,
	# XSLoader must be placed here, not in Scalar/Random/PP/OO.pm.
	if($xs){
		# XXX: XSLoader tries to get the object path from caller's file name
		#      $hack_mouse_file fools its mechanism
		(my $hack_mouse_file = __FILE__) =~ s/.Util//; # .../Scalar/Random/PP/OO/Util.pm -> .../Scalar/Random/PP/OO.pm
		$xs = eval sprintf("#line %d %s\n", __LINE__, $hack_mouse_file) . q{
			local $^W = 0; # workaround 'redefine' warning to &install_subroutines
			require XSLoader;
			XSLoader::load('Scalar::Random::PP::OO', $VERSION);
			Scalar::Random::PP::OO::Util->import({ into => 'Scalar::Random::PP::OO::Meta::Method::Constructor::XS' }, ':meta');
			Scalar::Random::PP::OO::Util->import({ into => 'Scalar::Random::PP::OO::Meta::Method::Destructor::XS'  }, ':meta');
			Scalar::Random::PP::OO::Util->import({ into => 'Scalar::Random::PP::OO::Meta::Method::Accessor::XS'    }, ':meta');
			return 1;
		} || 0;
		#warn $@ if $@;
	}

	if(!$xs){
		require 'Scalar/Random/PP/OO/PurePerl.pm'; # we don't want to create its namespace
	}

	*MOUSE_XS = sub(){ $xs };
}

use Carp         ();
use Scalar::Util ();

# aliases as public APIs
# it must be 'require', not 'use', because Scalar::Random::PP::OO::Meta::Module depends on Scalar::Random::PP::OO::Util
require Scalar::Random::PP::OO::Meta::Module; # for the entities of metaclass cache utilities

# aliases
{
	*class_of                    = \&Scalar::Random::PP::OO::Meta::Module::_class_of;
	*get_metaclass_by_name       = \&Scalar::Random::PP::OO::Meta::Module::_get_metaclass_by_name;
	*get_all_metaclass_instances = \&Scalar::Random::PP::OO::Meta::Module::_get_all_metaclass_instances;
	*get_all_metaclass_names     = \&Scalar::Random::PP::OO::Meta::Module::_get_all_metaclass_names;

	*Scalar::Random::PP::OO::load_class           = \&load_class;
	*Scalar::Random::PP::OO::is_class_loaded      = \&is_class_loaded;

	# is-a predicates
	#generate_isa_predicate_for('Scalar::Random::PP::OO::Meta::TypeConstraint' => 'is_a_type_constraint');
	#generate_isa_predicate_for('Scalar::Random::PP::OO::Meta::Class'          => 'is_a_metaclass');
	#generate_isa_predicate_for('Scalar::Random::PP::OO::Meta::Role'           => 'is_a_metarole');

	# duck type predicates
	generate_can_predicate_for(['_compiled_type_constraint']  => 'is_a_type_constraint');
	generate_can_predicate_for(['create_anon_class']          => 'is_a_metaclass');
	generate_can_predicate_for(['create_anon_role']           => 'is_a_metarole');
}

our $in_global_destruction = 0;
END{ $in_global_destruction = 1 }

# Moose::Util compatible utilities

sub find_meta{
	return class_of( $_[0] );
}

sub does_role{
	my ($class_or_obj, $role_name) = @_;

	my $meta = class_of($class_or_obj);

	(defined $role_name)
		|| ($meta || 'Scalar::Random::PP::OO::Meta::Class')->throw_error("You must supply a role name to does()");

	return defined($meta) && $meta->does_role($role_name);
}

BEGIN {
	my $get_linear_isa;
	if ($] >= 5.009_005) {
		require mro;
		$get_linear_isa = \&mro::get_linear_isa;
	} else {
		# this code is based on MRO::Compat::__get_linear_isa
		my $_get_linear_isa_dfs; # this recurses so it isn't pretty
		$_get_linear_isa_dfs = sub {
			my($classname) = @_;

			my @lin = ($classname);
			my %stored;

			no strict 'refs';
			foreach my $parent (@{"$classname\::ISA"}) {
				foreach  my $p(@{ $_get_linear_isa_dfs->($parent) }) {
					next if exists $stored{$p};
					push(@lin, $p);
					$stored{$p} = 1;
				}
			}
			return \@lin;
		};

		{
			package # hide from PAUSE
				Class::C3;
			our %MRO; # avoid 'once' warnings
		}

		# MRO::Compat::__get_linear_isa has no prototype, so
		# we define a prototyped version for compatibility with core's
		# See also MRO::Compat::__get_linear_isa.
		$get_linear_isa = sub ($;$){
			my($classname, $type) = @_;

			if(!defined $type){
				$type = exists $Class::C3::MRO{$classname} ? 'c3' : 'dfs';
			}
			if($type eq 'c3'){
				require Class::C3;
				return [Class::C3::calculateMRO($classname)];
			}
			else{
				return $_get_linear_isa_dfs->($classname);
			}
		};
	}

	*get_linear_isa = $get_linear_isa;
}


# taken from Scalar::Random::PP::OO::Util (0.90)
{
	my %cache;

	sub resolve_metaclass_alias {
		my ( $type, $metaclass_name, %options ) = @_;

		my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );

		return $cache{$cache_key}{$metaclass_name} ||= do{

			my $possible_full_name = join '::',
				'Scalar::Random::PP::OO::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
			;

			my $loaded_class = load_first_existing_class(
				$possible_full_name,
				$metaclass_name
			);

			$loaded_class->can('register_implementation')
				? $loaded_class->register_implementation
				: $loaded_class;
		};
	}
}

# Utilities from Class::MOP

sub get_code_info;
sub get_code_package;

sub is_valid_class_name;

# taken from Class/MOP.pm
sub load_first_existing_class {
	my @classes = @_
	  or return;

	my %exceptions;
	for my $class (@classes) {
		my $e = _try_load_one_class($class);

		if ($e) {
			$exceptions{$class} = $e;
		}
		else {
			return $class;
		}
	}

	# not found
	Carp::confess join(
		"\n",
		map {
			sprintf( "Could not load class (%s) because : %s",
				$_, $exceptions{$_} )
		  } @classes
	);
}

# taken from Class/MOP.pm
sub _try_load_one_class {
	my $class = shift;

	unless ( is_valid_class_name($class) ) {
		my $display = defined($class) ? $class : 'undef';
		Carp::confess "Invalid class name ($display)";
	}

	return '' if is_class_loaded($class);

	$class  =~ s{::}{/}g;
	$class .= '.pm';

	return do {
		local $@;
		eval { require $class };
		$@;
	};
}


sub load_class {
	my $class = shift;
	my $e = _try_load_one_class($class);
	Carp::confess "Could not load class ($class) because : $e" if $e;

	return $class;
}

sub is_class_loaded;

sub apply_all_roles {
	my $consumer = Scalar::Util::blessed($_[0])
		?                                shift   # instance
		: Scalar::Random::PP::OO::Meta::Class->initialize(shift); # class or role name

	my @roles;

	# Basis of Data::OptList
	my $max = scalar(@_);
	for (my $i = 0; $i < $max ; $i++) {
		if ($i + 1 < $max && ref($_[$i + 1])) {
			push @roles, [ $_[$i] => $_[++$i] ];
		} else {
			push @roles, [ $_[$i] => undef ];
		}
		my $role_name = $roles[-1][0];
		load_class($role_name);

		is_a_metarole( get_metaclass_by_name($role_name) )
			|| $consumer->meta->throw_error("You can only consume roles, $role_name is not a Scalar::Random::PP::OO role");
	}

	if ( scalar @roles == 1 ) {
		my ( $role_name, $params ) = @{ $roles[0] };
		get_metaclass_by_name($role_name)->apply( $consumer, defined $params ? $params : () );
	}
	else {
		Scalar::Random::PP::OO::Meta::Role->combine(@roles)->apply($consumer);
	}
	return;
}

# taken from Moose::Util 0.90
sub english_list {
	return $_[0] if @_ == 1;

	my @items = sort @_;

	return "$items[0] and $items[1]" if @items == 2;

	my $tail = pop @items;

	return join q{, }, @items, "and $tail";
}

sub quoted_english_list {
	return english_list(map { qq{'$_'} } @_);
}

# common utilities

sub not_supported{
	my($feature) = @_;

	$feature ||= ( caller(1) )[3]; # subroutine name

	local $Carp::CarpLevel = $Carp::CarpLevel + 1;
	Carp::confess("Scalar::Random::PP::OO does not currently support $feature");
}

# general meta() method
sub meta :method{
	return Scalar::Random::PP::OO::Meta::Class->initialize(ref($_[0]) || $_[0]);
}

# general dump() method
sub dump :method {
	my($self, $maxdepth) = @_;

	require 'Data/Dumper.pm'; # we don't want to create its namespace
	my $dd = Data::Dumper->new([$self]);
	$dd->Maxdepth(defined($maxdepth) ? $maxdepth : 3);
	$dd->Indent(1);
	return $dd->Dump();
}

# general does() method
sub does :method {
	goto &does_role;
}

# Contents of Mouse::Meta::TypeConstraint
package Scalar::Random::PP::OO::Meta::TypeConstraint;
use Scalar::Random::PP::OO::Util qw(:meta); # enables strict and warnings
use Scalar::Util ();

use overload
	'bool'   => sub (){ 1 },           # always true
	'""'     => sub { $_[0]->name },   # stringify to tc name
	'0+'     => sub { Scalar::Util::refaddr($_[0]) },
	'|'      => sub {                  # or-combination
		require Scalar::Random::PP::OO::Util::TypeConstraints;
		return Scalar::Random::PP::OO::Util::TypeConstraints::find_or_parse_type_constraint(
			"$_[0] | $_[1]",
		);
	},

	fallback => 1;

sub new {
	my $class = shift;
	my %args  = @_ == 1 ? %{$_[0]} : @_;

	$args{name} = '__ANON__' if !defined $args{name};

	my $check = delete $args{optimized};

	if($check){
		$args{hand_optimized_type_constraint} = $check;
		$args{compiled_type_constraint}       = $check;
	}

	$check = $args{constraint};

	if(defined($check) && ref($check) ne 'CODE'){
		$class->throw_error("Constraint for $args{name} is not a CODE reference");
	}

	my $self = bless \%args, $class;
	$self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};

	$self->_compile_union_type_coercion() if $self->{type_constraints};
	return $self;
}

sub create_child_type{
	my $self = shift;
	return ref($self)->new(
		# a child inherits its parent's attributes
		%{$self},

		# but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
		compiled_type_constraint       => undef,
		hand_optimized_type_constraint => undef,

		# and is given child-specific args, of course.
		@_,

		# and its parent
		parent => $self,
   );
}

sub name;
sub parent;
sub message;
sub has_coercion;

sub check;

sub type_parameter;
sub __is_parameterized;

sub _compiled_type_constraint;
sub _compiled_type_coercion;

sub compile_type_constraint;


sub _add_type_coercions{
	my $self = shift;

	my $coercions = ($self->{coercion_map} ||= []);
	my %has       = map{ $_->[0] => undef } @{$coercions};

	for(my $i = 0; $i < @_; $i++){
		my $from   = $_[  $i];
		my $action = $_[++$i];

		if(exists $has{$from}){
			$self->throw_error("A coercion action already exists for '$from'");
		}

		my $type = Scalar::Random::PP::OO::Util::TypeConstraints::find_or_parse_type_constraint($from)
			or $self->throw_error("Could not find the type constraint ($from) to coerce from");

		push @{$coercions}, [ $type => $action ];
	}

	# compile
	if(exists $self->{type_constraints}){ # union type
		$self->throw_error("Cannot add additional type coercions to Union types");
	}
	else{
		$self->_compile_type_coercion();
	}
	return;
}

sub _compile_type_coercion {
	my($self) = @_;

	my @coercions = @{$self->{coercion_map}};

	$self->{_compiled_type_coercion} = sub {
	   my($thing) = @_;
	   foreach my $pair (@coercions) {
			#my ($constraint, $converter) = @$pair;
			if ($pair->[0]->check($thing)) {
			  local $_ = $thing;
			  return $pair->[1]->($thing);
			}
	   }
	   return $thing;
	};
	return;
}

sub _compile_union_type_coercion {
	my($self) = @_;

	my @coercions;
	foreach my $type(@{$self->{type_constraints}}){
		if($type->has_coercion){
			push @coercions, $type;
		}
	}
	if(@coercions){
		$self->{_compiled_type_coercion} = sub {
			my($thing) = @_;
			foreach my $type(@coercions){
				my $value = $type->coerce($thing);
				return $value if $self->check($value);
			}
			return $thing;
		};
	}
	return;
}

sub coerce {
	my $self = shift;

	my $coercion = $self->_compiled_type_coercion;
	if(!$coercion){
		$self->throw_error("Cannot coerce without a type coercion");
	}

	return $_[0] if $self->check(@_);

	return  $coercion->(@_);
}

sub get_message {
	my ($self, $value) = @_;
	if ( my $msg = $self->message ) {
		local $_ = $value;
		return $msg->($value);
	}
	else {
		$value = ( defined $value ? overload::StrVal($value) : 'undef' );
		return "Validation failed for '$self' with value $value";
	}
}

sub is_a_type_of{
	my($self, $other) = @_;

	# ->is_a_type_of('__ANON__') is always false
	return 0 if !ref($other) && $other eq '__ANON__';

	(my $other_name = $other) =~ s/\s+//g;

	return 1 if $self->name eq $other_name;

	if(exists $self->{type_constraints}){ # union
		foreach my $type(@{$self->{type_constraints}}){
			return 1 if $type->name eq $other_name;
		}
	}

	for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
		return 1 if $parent->name eq $other_name;
	}

	return 0;
}

# See also Moose::Meta::TypeConstraint::Parameterizable
sub parameterize{
	my($self, $param, $name) = @_;

	if(!ref $param){
		require Scalar::Random::PP::OO::Util::TypeConstraints;
		$param = Scalar::Random::PP::OO::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
	}

	$name ||= sprintf '%s[%s]', $self->name, $param->name;

	my $generator = $self->{constraint_generator}
		|| $self->throw_error("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");

	return Scalar::Random::PP::OO::Meta::TypeConstraint->new(
		name           => $name,
		parent         => $self,
		type_parameter => $param,
		constraint     => $generator->($param), # must be 'constraint', not 'optimized'
	);
}

sub assert_valid {
	my ($self, $value) = @_;

	if(!$self->check($value)){
		$self->throw_error($self->get_message($value));
	}
	return 1;
}

sub throw_error {
	require Scalar::Random::PP::OO::Meta::Module;
	goto &Scalar::Random::PP::OO::Meta::Module::throw_error;
}

# Contents of Mouse::Util::TypeConstraints
package Scalar::Random::PP::OO::Util::TypeConstraints;
use Scalar::Random::PP::OO::Util qw(does_role not_supported); # enables strict and warnings

use Carp         ();
use Scalar::Util ();

use Scalar::Random::PP::OO::Meta::TypeConstraint;
use Scalar::Random::PP::OO::Exporter;

Scalar::Random::PP::OO::Exporter->setup_import_methods(
	as_is => [qw(
		as where message optimize_as
		from via

		type subtype class_type role_type duck_type
		enum
		coerce

		find_type_constraint
		register_type_constraint
	)],
);

our @CARP_NOT = qw(Scalar::Random::PP::OO::Meta::Attribute);

my %TYPE;

# The root type
$TYPE{Any} = Scalar::Random::PP::OO::Meta::TypeConstraint->new(
	name => 'Any',
);

my @builtins = (
	# $name    => $parent,   $code,

	# the base type
	Item       => 'Any',     undef,

	# the maybe[] type
	Maybe      => 'Item',    undef,

	# value types
	Undef      => 'Item',    \&Undef,
	Defined    => 'Item',    \&Defined,
	Bool       => 'Item',    \&Bool,
	Value      => 'Defined', \&Value,
	Str        => 'Value',   \&Str,
	Num        => 'Str',     \&Num,
	Int        => 'Num',     \&Int,

	# ref types
	Ref        => 'Defined', \&Ref,
	ScalarRef  => 'Ref',     \&ScalarRef,
	ArrayRef   => 'Ref',     \&ArrayRef,
	HashRef    => 'Ref',     \&HashRef,
	CodeRef    => 'Ref',     \&CodeRef,
	RegexpRef  => 'Ref',     \&RegexpRef,
	GlobRef    => 'Ref',     \&GlobRef,

	# object types
	FileHandle => 'GlobRef', \&FileHandle,
	Object     => 'Ref',     \&Object,

	# special string types
	ClassName  => 'Str',       \&ClassName,
	RoleName   => 'ClassName', \&RoleName,
);


while (my ($name, $parent, $code) = splice @builtins, 0, 3) {
	$TYPE{$name} = Scalar::Random::PP::OO::Meta::TypeConstraint->new(
		name      => $name,
		parent    => $TYPE{$parent},
		optimized => $code,
	);
}

# make it parametarizable

$TYPE{Maybe}   {constraint_generator} = \&_parameterize_Maybe_for;
$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for;
$TYPE{HashRef} {constraint_generator} = \&_parameterize_HashRef_for;

# sugars

sub as          ($) { (as          => $_[0]) } ## no critic
sub where       (&) { (where       => $_[0]) } ## no critic
sub message     (&) { (message     => $_[0]) } ## no critic
sub optimize_as (&) { (optimize_as => $_[0]) } ## no critic

sub from    { @_ }
sub via (&) { $_[0] } ## no critic

# type utilities

sub optimized_constraints { # DEPRECATED
	Carp::cluck('optimized_constraints() has been deprecated');
	return \%TYPE;
}

undef @builtins;        # free the allocated memory
@builtins = keys %TYPE; # reuse it
sub list_all_builtin_type_constraints { @builtins }

sub list_all_type_constraints         { keys %TYPE }

sub _create_type{
	my $mode = shift;

	my $name;
	my %args;

	if(@_ == 1 && ref $_[0]){   # @_ : { name => $name, where => ... }
		%args = %{$_[0]};
	}
	elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
		$name = $_[0];
		%args = %{$_[1]};
	}
	elsif(@_ % 2){               # @_ : $name => ( where => ... )
		($name, %args) = @_;
	}
	else{                        # @_ : (name => $name, where => ...)
		%args = @_;
	}

	if(!defined $name){
		$name = $args{name};
	}

	$args{name} = $name;
	my $parent;
	if($mode eq 'subtype'){
		$parent = delete $args{as};
		if(!$parent){
			$parent = delete $args{name};
			$name   = undef;
		}
	}

	if(defined $name){
		# set 'package_defined_in' only if it is not a core package
		my $this = $args{package_defined_in};
		if(!$this){
			$this = caller(1);
			if($this !~ /\A Scalar::Random::PP::OO \b/xms){
				$args{package_defined_in} = $this;
			}
		}

		if($TYPE{$name}){
			my $that = $TYPE{$name}->{package_defined_in} || __PACKAGE__;
			if($this ne $that) {
				my $note = '';
				if($that eq __PACKAGE__) {
					$note = sprintf " ('%s' is %s type constraint)",
						$name,
						scalar(grep { $name eq $_ } list_all_builtin_type_constraints())
							? 'a builtin'
							: 'an implicitly created';
				}
				Carp::croak("The type constraint '$name' has already been created in $that"
						  . " and cannot be created again in $this" . $note);
			}
		}
	}
	else{
		$args{name} = '__ANON__';
	}

	$args{constraint} = delete $args{where}        if exists $args{where};
	$args{optimized}  = delete $args{optimized_as} if exists $args{optimized_as};

	my $constraint;
	if($mode eq 'subtype'){
		$constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args);
	}
	else{
		$constraint = Scalar::Random::PP::OO::Meta::TypeConstraint->new(%args);
	}

	if(defined $name){
		return $TYPE{$name} = $constraint;
	}
	else{
		return $constraint;
	}
}

sub type {
	return _create_type('type', @_);
}

sub subtype {
	return _create_type('subtype', @_);
}

sub coerce {
	my $type_name = shift;

	my $type = find_type_constraint($type_name)
		or Carp::croak("Cannot find type '$type_name', perhaps you forgot to load it.");

	$type->_add_type_coercions(@_);
	return;
}

sub class_type {
	my($name, $options) = @_;
	my $class = $options->{class} || $name;

	# ClassType
	return _create_type 'subtype', $name => (
		as           => 'Object',
		optimized_as => Scalar::Random::PP::OO::Util::generate_isa_predicate_for($class),
	);
}

sub role_type {
	my($name, $options) = @_;
	my $role = $options->{role} || $name;

	# RoleType
	return _create_type 'subtype', $name => (
		as           => 'Object',
		optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) },
	);
}

sub duck_type {
	my($name, @methods);

	if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
		$name = shift;
	}

	@methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;

	# DuckType
	return _create_type 'subtype', $name => (
		as           => 'Object',
		optimized_as => Scalar::Random::PP::OO::Util::generate_can_predicate_for(\@methods),
	);
}

sub enum {
	my($name, %valid);

	if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
		$name = shift;
	}

	%valid = map{ $_ => undef } (@_ == 1 && ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_);

	# EnumType
	return _create_type 'subtype', $name => (
		as            => 'Str',
		optimized_as  => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
	);
}

sub _find_or_create_regular_type{
	my($spec, $create)  = @_;

	return $TYPE{$spec} if exists $TYPE{$spec};

	my $meta = Scalar::Random::PP::OO::Util::get_metaclass_by_name($spec);

	if(!defined $meta){
		return $create ? class_type($spec) : undef;
	}

	if(Scalar::Random::PP::OO::Util::is_a_metarole($meta)){
		return role_type($spec);
	}
	else{
		return class_type($spec);
	}
}

sub _find_or_create_parameterized_type{
	my($base, $param) = @_;

	my $name = sprintf '%s[%s]', $base->name, $param->name;

	$TYPE{$name} ||= $base->parameterize($param, $name);
}

sub _find_or_create_union_type{
	return if grep{ not defined } @_;
	my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;

	my $name = join '|', @types;

	# UnionType
	$TYPE{$name} ||= Scalar::Random::PP::OO::Meta::TypeConstraint->new(
		name              => $name,
		type_constraints  => \@types,
	);
}

# The type parser

# param : '[' type ']' | NOTHING
sub _parse_param {
	my($c) = @_;

	if($c->{spec} =~ s/^\[//){
		my $type = _parse_type($c, 1);

		if($c->{spec} =~ s/^\]//){
			return $type;
		}
		Carp::croak("Syntax error in type: missing right square bracket in '$c->{orig}'");
	}

	return undef;
}

# name : [\w.:]+
sub _parse_name {
	my($c, $create) = @_;

	if($c->{spec} =~ s/\A ([\w.:]+) //xms){
		return _find_or_create_regular_type($1, $create);
	}
	Carp::croak("Syntax error in type: expect type name near '$c->{spec}' in '$c->{orig}'");
}

# single_type : name param
sub _parse_single_type {
	my($c, $create) = @_;

	my $type  = _parse_name($c, $create);
	my $param = _parse_param($c);

	if(defined $type){
		if(defined $param){
			return _find_or_create_parameterized_type($type, $param);
		}
		else {
			return $type;
		}
	}
	elsif(defined $param){
		Carp::croak("Undefined type with parameter [$param] in '$c->{orig}'");
	}
	else{
		return undef;
	}
}

# type : single_type  ('|' single_type)*
sub _parse_type {
	my($c, $create) = @_;

	my $type = _parse_single_type($c, $create);
	if($c->{spec}){ # can be an union type
		my @types;
		while($c->{spec} =~ s/^\|//){
			push @types, _parse_single_type($c, $create);
		}
		if(@types){
			return _find_or_create_union_type($type, @types);
		}
	}
	return $type;
}


sub find_type_constraint {
	my($spec) = @_;
	return $spec if Scalar::Random::PP::OO::Util::is_a_type_constraint($spec) or not defined $spec;

	$spec =~ s/\s+//g;
	return $TYPE{$spec};
}

sub register_type_constraint {
	my($constraint) = @_;
	Carp::croak("No type supplied / type is not a valid type constraint")
		unless Scalar::Random::PP::OO::Util::is_a_type_constraint($constraint);
	my $name = $constraint->name;
	Carp::croak("can't register an unnamed type constraint")
		unless defined $name;
	return $TYPE{$name} = $constraint;
}

sub find_or_parse_type_constraint {
	my($spec) = @_;
	return $spec if Scalar::Random::PP::OO::Util::is_a_type_constraint($spec) or not defined $spec;

	$spec =~ s/\s+//g;
	return $TYPE{$spec} || do{
		my $context = {
			spec => $spec,
			orig => $spec,
		};
		my $type = _parse_type($context);

		if($context->{spec}){
			Carp::croak("Syntax error: extra elements '$context->{spec}' in '$context->{orig}'");
		}
		$type;
	};
}

sub find_or_create_does_type_constraint{
	# XXX: Moose does not register a new role_type, but Scalar::Random::PP::OO does.
	return find_or_parse_type_constraint(@_) || role_type(@_);
}

sub find_or_create_isa_type_constraint {
	# XXX: Moose does not register a new class_type, but Scalar::Random::PP::OO does.
	return find_or_parse_type_constraint(@_) || class_type(@_);
}

# Contents of Mouse
package Scalar::Random::PP::OO::TOP;
use 5.006_002;

use Scalar::Random::PP::OO::Exporter; # enables strict and warnings

our $VERSION = '0.70';

use Carp         qw(confess);
use Scalar::Util qw(blessed);

use Scalar::Random::PP::OO::Util ();

use Scalar::Random::PP::OO::Meta::Module;
use Scalar::Random::PP::OO::Meta::Class;
use Scalar::Random::PP::OO::Meta::Role;
use Scalar::Random::PP::OO::Meta::Attribute;
use Scalar::Random::PP::OO::Object;
use Scalar::Random::PP::OO::Util::TypeConstraints ();

Scalar::Random::PP::OO::Exporter->setup_import_methods(
	as_is => [qw(
		extends with
		has
		before after around
		override super
		augment  inner
	),
		\&Scalar::Util::blessed,
		\&Carp::confess,
   ],
);


sub extends {
	Scalar::Random::PP::OO::Meta::Class->initialize(scalar caller)->superclasses(@_);
	return;
}

sub with {
	Scalar::Random::PP::OO::Util::apply_all_roles(scalar(caller), @_);
	return;
}

sub has {
	my $meta = Scalar::Random::PP::OO::Meta::Class->initialize(scalar caller);
	my $name = shift;

	$meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
		if @_ % 2; # odd number of arguments

	if(ref $name){ # has [qw(foo bar)] => (...)
		for (@{$name}){
			$meta->add_attribute($_ => @_);
		}
	}
	else{ # has foo => (...)
		$meta->add_attribute($name => @_);
	}
	return;
}

sub before {
	my $meta = Scalar::Random::PP::OO::Meta::Class->initialize(scalar caller);
	my $code = pop;
	for my $name($meta->_collect_methods(@_)) {
		$meta->add_before_method_modifier($name => $code);
	}
	return;
}

sub after {
	my $meta = Scalar::Random::PP::OO::Meta::Class->initialize(scalar caller);
	my $code = pop;
	for my $name($meta->_collect_methods(@_)) {
		$meta->add_after_method_modifier($name => $code);
	}
	return;
}

sub around {
	my $meta = Scalar::Random::PP::OO::Meta::Class->initialize(scalar caller);
	my $code = pop;
	for my $name($meta->_collect_methods(@_)) {
		$meta->add_around_method_modifier($name => $code);
	}
	return;
}

our $SUPER_PACKAGE;
our $SUPER_BODY;
our @SUPER_ARGS;

sub super {
	# This check avoids a recursion loop - see
	# t/100_bugs/020_super_recursion.t
	return if  defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
	return if !defined $SUPER_BODY;
	$SUPER_BODY->(@SUPER_ARGS);
}

sub override {
	# my($name, $method) = @_;
	Scalar::Random::PP::OO::Meta::Class->initialize(scalar caller)->add_override_method_modifier(@_);
}

our %INNER_BODY;
our %INNER_ARGS;

sub inner {
	my $pkg = caller();
	if ( my $body = $INNER_BODY{$pkg} ) {
		my $args = $INNER_ARGS{$pkg};
		local $INNER_ARGS{$pkg};
		local $INNER_BODY{$pkg};
		return $body->(@{$args});
	}
	else {
		return;
	}
}

sub augment {
	#my($name, $method) = @_;
	Scalar::Random::PP::OO::Meta::Class->initialize(scalar caller)->add_augment_method_modifier(@_);
	return;
}

sub init_meta {
	shift;
	my %args = @_;

	my $class = $args{for_class}
					or confess("Cannot call init_meta without specifying a for_class");

	my $base_class = $args{base_class} || 'Scalar::Random::PP::OO::Object';
	my $metaclass  = $args{metaclass}  || 'Scalar::Random::PP::OO::Meta::Class';

	my $meta = $metaclass->initialize($class);

	$meta->add_method(meta => sub{
		return $metaclass->initialize(ref($_[0]) || $_[0]);
	});

	$meta->superclasses($base_class)
		unless $meta->superclasses;

	# make a class type for each Scalar::Random::PP::OO class
	Scalar::Random::PP::OO::Util::TypeConstraints::class_type($class)
		unless Scalar::Random::PP::OO::Util::TypeConstraints::find_type_constraint($class);

	return $meta;
}

# Contents of Mouse::Meta::Attribute
package Scalar::Random::PP::OO::Meta::Attribute;
use Scalar::Random::PP::OO::Util qw(:meta); # enables strict and warnings

use Carp ();

use Scalar::Random::PP::OO::Meta::TypeConstraint;

my %valid_options = map { $_ => undef } (
  'accessor',
  'auto_deref',
  'builder',
  'clearer',
  'coerce',
  'default',
  'documentation',
  'does',
  'handles',
  'init_arg',
  'insertion_order',
  'is',
  'isa',
  'lazy',
  'lazy_build',
  'name',
  'predicate',
  'reader',
  'required',
  'traits',
  'trigger',
  'type_constraint',
  'weak_ref',
  'writer',

  # internally used
  'associated_class',
  'associated_methods',

  # Moose defines, but Scalar::Random::PP::OO doesn't
  #'definition_context',
  #'initializer',

  # special case for AttributeHelpers
  'provides',
  'curries',
);

our @CARP_NOT = qw(Scalar::Random::PP::OO::Meta::Class);

sub new {
	my $class = shift;
	my $name  = shift;

	my $args  = $class->Scalar::Random::PP::OO::Object::BUILDARGS(@_);

	$class->_process_options($name, $args);

	$args->{name} = $name;

	# check options
	# (1) known by core
	my @bad = grep{ !exists $valid_options{$_} } keys %{$args};

	# (2) known by subclasses
	if(@bad && $class ne __PACKAGE__){
		my %valid_attrs = (
			map { $_ => undef }
			grep { defined }
			map { $_->init_arg() }
			$class->meta->get_all_attributes()
		);
		@bad = grep{ !exists $valid_attrs{$_} } @bad;
	}

	# (3) bad options found
	if(@bad){
		Carp::carp(
			"Found unknown argument(s) passed to '$name' attribute constructor in '$class': "
			. Scalar::Random::PP::OO::Util::english_list(@bad));
	}

	my $self = bless $args, $class;

	# extra attributes
	if($class ne __PACKAGE__){
		$class->meta->_initialize_object($self, $args);
	}

	return $self;
}

sub has_read_method      { $_[0]->has_reader || $_[0]->has_accessor }
sub has_write_method     { $_[0]->has_writer || $_[0]->has_accessor }

sub interpolate_class{
	my($class, $args) = @_;

	if(my $metaclass = delete $args->{metaclass}){
		$class = Scalar::Random::PP::OO::Util::resolve_metaclass_alias( Attribute => $metaclass );
	}

	my @traits;
	if(my $traits_ref = delete $args->{traits}){

		for (my $i = 0; $i < @{$traits_ref}; $i++) {
			my $trait = Scalar::Random::PP::OO::Util::resolve_metaclass_alias(Attribute => $traits_ref->[$i], trait => 1);

			next if $class->does($trait);

			push @traits, $trait;

			# are there options?
			push @traits, $traits_ref->[++$i]
				if ref($traits_ref->[$i+1]);
		}

		if (@traits) {
			$class = Scalar::Random::PP::OO::Meta::Class->create_anon_class(
				superclasses => [ $class ],
				roles        => \@traits,
				cache        => 1,
			)->name;
		}
	}

	return( $class, @traits );
}

sub _coerce_and_verify {
	#my($self, $value, $instance) = @_;
	my($self, $value) = @_;

	my $type_constraint = $self->{type_constraint};
	return $value if !defined $type_constraint;

	if ($self->should_coerce && $type_constraint->has_coercion) {
		$value = $type_constraint->coerce($value);
	}

	$self->verify_against_type_constraint($value);

	return $value;
}

sub verify_against_type_constraint {
	my ($self, $value) = @_;

	my $type_constraint = $self->{type_constraint};
	return 1 if !$type_constraint;
	return 1 if $type_constraint->check($value);

	$self->_throw_type_constraint_error($value, $type_constraint);
}

sub _throw_type_constraint_error {
	my($self, $value, $type) = @_;

	$self->throw_error(
		sprintf q{Attribute (%s) does not pass the type constraint because: %s},
			$self->name,
			$type->get_message($value),
	);
}

sub illegal_options_for_inheritance {
	return qw(reader writer accessor clearer predicate);
}

sub clone_and_inherit_options{
	my $self = shift;
	my $args = $self->Scalar::Random::PP::OO::Object::BUILDARGS(@_);

	foreach my $illegal($self->illegal_options_for_inheritance) {
		if(exists $args->{$illegal} and exists $self->{$illegal}) {
			$self->throw_error("Illegal inherited option: $illegal");
		}
	}

	foreach my $name(keys %{$self}){
		if(!exists $args->{$name}){
			$args->{$name} = $self->{$name}; # inherit from self
		}
	}

	my($attribute_class, @traits) = ref($self)->interpolate_class($args);
	$args->{traits} = \@traits if @traits;

	# remove temporary caches
	foreach my $attr(keys %{$args}){
		if($attr =~ /\A _/xms){
			delete $args->{$attr};
		}
	}

	# remove default if lazy_build => 1
	if($args->{lazy_build}) {
		delete $args->{default};
	}

	return $attribute_class->new($self->name, $args);
}

sub get_read_method {
	return $_[0]->reader || $_[0]->accessor
}
sub get_write_method {
	return $_[0]->writer || $_[0]->accessor
}

sub _get_accessor_method_ref {
	my($self, $type, $generator) = @_;

	my $metaclass = $self->associated_class
		|| $self->throw_error('No asocciated class for ' . $self->name);

	my $accessor = $self->$type();
	if($accessor){
		return $metaclass->get_method_body($accessor);
	}
	else{
		return $self->accessor_metaclass->$generator($self, $metaclass);
	}
}

sub get_read_method_ref{
	my($self) = @_;
	return $self->{_read_method_ref} ||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader');
}

sub get_write_method_ref{
	my($self) = @_;
	return $self->{_write_method_ref} ||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer');
}

sub set_value {
	my($self, $object, $value) = @_;
	return $self->get_write_method_ref()->($object, $value);
}

sub get_value {
	my($self, $object) = @_;
	return $self->get_read_method_ref()->($object);
}

sub has_value {
	my($self, $object) = @_;
	my $accessor_ref = $self->{_predicate_ref}
		||= $self->_get_accessor_method_ref('predicate', '_generate_predicate');

	return $accessor_ref->($object);
}

sub clear_value {
	my($self, $object) = @_;
	my $accessor_ref = $self->{_crealer_ref}
		||= $self->_get_accessor_method_ref('clearer', '_generate_clearer');

	return $accessor_ref->($object);
}


sub associate_method{
	#my($attribute, $method_name) = @_;
	my($attribute) = @_;
	$attribute->{associated_methods}++;
	return;
}

sub install_accessors{
	my($attribute) = @_;

	my $metaclass      = $attribute->associated_class;
	my $accessor_class = $attribute->accessor_metaclass;

	foreach my $type(qw(accessor reader writer predicate clearer)){
		if(exists $attribute->{$type}){
			my $generator = '_generate_' . $type;
			my $code      = $accessor_class->$generator($attribute, $metaclass);
			$metaclass->add_method($attribute->{$type} => $code);
			$attribute->associate_method($attribute->{$type});
		}
	}

	# install delegation
	if(exists $attribute->{handles}){
		my %handles = $attribute->_canonicalize_handles($attribute->{handles});

		while(my($handle, $method_to_call) = each %handles){
			if($metaclass->has_method($handle)) {
				$attribute->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation");
			}

			$metaclass->add_method($handle =>
				$attribute->_make_delegation_method(
					$handle, $method_to_call));

			$attribute->associate_method($handle);
		}
	}

	return;
}

sub delegation_metaclass() { ## no critic
	'Scalar::Random::PP::OO::Meta::Method::Delegation'
}

sub _canonicalize_handles {
	my($self, $handles) = @_;

	if (ref($handles) eq 'HASH') {
		return %$handles;
	}
	elsif (ref($handles) eq 'ARRAY') {
		return map { $_ => $_ } @$handles;
	}
	elsif ( ref($handles) eq 'CODE' ) {
		my $class_or_role = ( $self->{isa} || $self->{does} )
			|| $self->throw_error( "Cannot find delegate metaclass for attribute " . $self->name );
		return $handles->( $self, Scalar::Random::PP::OO::Meta::Class->initialize("$class_or_role"));
	}
	elsif (ref($handles) eq 'Regexp') {
		my $class_or_role = ($self->{isa} || $self->{does})
			|| $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)");

		my $meta = Scalar::Random::PP::OO::Meta::Class->initialize("$class_or_role"); # "" for stringify
		return map  { $_ => $_ }
			   grep { !Scalar::Random::PP::OO::Object->can($_) && $_ =~ $handles }
				   Scalar::Random::PP::OO::Util::is_a_metarole($meta)
						? $meta->get_method_list
						: $meta->get_all_method_names;
	}
	else {
		$self->throw_error("Unable to canonicalize the 'handles' option with $handles");
	}
}

sub _make_delegation_method {
	my($self, $handle, $method_to_call) = @_;
	return Scalar::Random::PP::OO::Util::load_class($self->delegation_metaclass)
		->_generate_delegation($self, $handle, $method_to_call);
}

sub throw_error{
	my $self = shift;

	my $metaclass = (ref $self && $self->associated_class) || 'Scalar::Random::PP::OO::Meta::Class';
	$metaclass->throw_error(@_, depth => 1);
}

# Contents of Mouse::Meta::Class
package Scalar::Random::PP::OO::Meta::Class;
use Scalar::Random::PP::OO::Util qw/:meta get_linear_isa not_supported/; # enables strict and warnings
no warnings 'once';

use Scalar::Util qw/blessed weaken/;

use Scalar::Random::PP::OO::Meta::Module;
our @ISA = qw(Scalar::Random::PP::OO::Meta::Module);

our @CARP_NOT = qw(Scalar::Random::PP::OO); # trust Mousse

sub attribute_metaclass;
sub method_metaclass;

sub constructor_class;
sub destructor_class;


sub _construct_meta {
	my($class, %args) = @_;

	$args{attributes} = {};
	$args{methods}    = {};
	$args{roles}      = [];

	$args{superclasses} = do {
		no strict 'refs';
		\@{ $args{package} . '::ISA' };
	};

	my $self = bless \%args, ref($class) || $class;
	if(ref($self) ne __PACKAGE__){
		$self->meta->_initialize_object($self, \%args);
	}
	return $self;
}

sub create_anon_class{
	my $self = shift;
	return $self->create(undef, @_);
}

sub is_anon_class;

sub roles;

sub calculate_all_roles {
	my $self = shift;
	my %seen;
	return grep { !$seen{ $_->name }++ }
		   map  { $_->calculate_all_roles } @{ $self->roles };
}

sub superclasses {
	my $self = shift;

	if (@_) {
		foreach my $super(@_){
			Scalar::Random::PP::OO::Util::load_class($super);
			my $meta = Scalar::Random::PP::OO::Util::get_metaclass_by_name($super);

			next if not defined $meta;

			if(Scalar::Random::PP::OO::Util::is_a_metarole($meta)){
				$self->throw_error("You cannot inherit from a Scalar::Random::PP::OO Role ($super)");
			}

			next if $self->isa(ref $meta); # _superclass_meta_is_compatible

			$self->_reconcile_with_superclass_meta($meta);
		}
		@{ $self->{superclasses} } = @_;
	}

	return @{ $self->{superclasses} };
}
my @MetaClassTypes = (
	'attribute',   # Scalar::Random::PP::OO::Meta::Attribute
	'method',      # Scalar::Random::PP::OO::Meta::Method
	'constructor', # Scalar::Random::PP::OO::Meta::Method::Constructor
	'destructor',  # Scalar::Random::PP::OO::Meta::Method::Destructor
);

sub _reconcile_with_superclass_meta {
	my($self, $other) = @_;

	# find incompatible traits
	my %metaroles;
	foreach my $metaclass_type(@MetaClassTypes){
		my $accessor = $self->can($metaclass_type . '_metaclass')
			|| $self->can($metaclass_type . '_class');

		my $other_c = $other->$accessor();
		my $self_c  = $self->$accessor();

		if(!$self_c->isa($other_c)){
			$metaroles{$metaclass_type}
				= [ $self_c->meta->_collect_roles($other_c->meta) ];
		}
	}

	$metaroles{class} = [$self->meta->_collect_roles($other->meta)];

	#use Data::Dumper; print Data::Dumper->new([\%metaroles], ['*metaroles'])->Indent(1)->Dump;

	require Scalar::Random::PP::OO::Util::MetaRole;
	$_[0] = Scalar::Random::PP::OO::Util::MetaRole::apply_metaroles(
		for             => $self,
		class_metaroles => \%metaroles,
	);
	return;
}

sub _collect_roles {
	my ($self, $other) = @_;

	# find common ancestor
	my @self_lin_isa  = $self->linearized_isa;
	my @other_lin_isa = $other->linearized_isa;

	my(@self_anon_supers, @other_anon_supers);
	push @self_anon_supers,  shift @self_lin_isa  while $self_lin_isa[0]->meta->is_anon_class;
	push @other_anon_supers, shift @other_lin_isa while $other_lin_isa[0]->meta->is_anon_class;

	my $common_ancestor = $self_lin_isa[0] eq $other_lin_isa[0] && $self_lin_isa[0];

	if(!$common_ancestor){
		$self->throw_error(sprintf '%s cannot have %s as a super class because of their metaclass incompatibility',
			$self->name, $other->name);
	}

	my %seen;
	return sort grep { !$seen{$_}++ } ## no critic
		(map{ $_->name } map{ $_->meta->calculate_all_roles } @self_anon_supers),
		(map{ $_->name } map{ $_->meta->calculate_all_roles } @other_anon_supers),
	;
}


sub find_method_by_name{
	my($self, $method_name) = @_;
	defined($method_name)
		or $self->throw_error('You must define a method name to find');

	foreach my $class( $self->linearized_isa ){
		my $method = $self->initialize($class)->get_method($method_name);
		return $method if defined $method;
	}
	return undef;
}

sub get_all_methods {
	my($self) = @_;
	return map{ $self->find_method_by_name($_) } $self->get_all_method_names;
}

sub get_all_method_names {
	my $self = shift;
	my %uniq;
	return grep { $uniq{$_}++ == 0 }
			map { Scalar::Random::PP::OO::Meta::Class->initialize($_)->get_method_list() }
			$self->linearized_isa;
}

sub find_attribute_by_name{
	my($self, $name) = @_;
	my $attr;
	foreach my $class($self->linearized_isa){
		my $meta = Scalar::Random::PP::OO::Util::get_metaclass_by_name($class) or next;
		$attr = $meta->get_attribute($name) and last;
	}
	return $attr;
}

sub add_attribute {
	my $self = shift;

	my($attr, $name);

	if(blessed $_[0]){
		$attr = $_[0];

		$attr->isa('Scalar::Random::PP::OO::Meta::Attribute')
			|| $self->throw_error("Your attribute must be an instance of Scalar::Random::PP::OO::Meta::Attribute (or a subclass)");

		$name = $attr->name;
	}
	else{
		# _process_attribute
		$name = shift;

		my %args = (@_ == 1) ? %{$_[0]} : @_;

		defined($name)
			or $self->throw_error('You must provide a name for the attribute');

		if ($name =~ s/^\+//) { # inherited attributes
			my $inherited_attr = $self->find_attribute_by_name($name)
				or $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name);

			$attr = $inherited_attr->clone_and_inherit_options(%args);
		}
		else{
			my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args);
			$args{traits} = \@traits if @traits;

			$attr = $attribute_class->new($name, %args);
		}
	}

	weaken( $attr->{associated_class} = $self );

	# install accessors first
	$attr->install_accessors();

	# then register the attribute to the metaclass
	$attr->{insertion_order} = keys %{ $self->{attributes} };
	$self->{attributes}{$attr->name} = $attr;

	if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){
		Carp::carp(qq{Attribute ($name) of class }.$self->name
			.qq{ has no associated methods (did you mean to provide an "is" argument?)});
	}
	return $attr;
}

sub linearized_isa;

sub new_object;
sub clone_object;

sub immutable_options {
	my ( $self, @args ) = @_;

	return (
		inline_constructor => 1,
		inline_destructor  => 1,
		constructor_name   => 'new',
		@args,
	);
}

sub make_immutable {
	my $self = shift;
	my %args = $self->immutable_options(@_);

	$self->{is_immutable}++;

	if ($args{inline_constructor}) {
		$self->add_method($args{constructor_name} =>
			Scalar::Random::PP::OO::Util::load_class($self->constructor_class)
				->_generate_constructor($self, \%args));
	}

	if ($args{inline_destructor}) {
		$self->add_method(DESTROY =>
			Scalar::Random::PP::OO::Util::load_class($self->destructor_class)
				->_generate_destructor($self, \%args));
	}

	# Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
	# at the end of a source file.
	return 1;
}

sub make_mutable {
	my($self) = @_;
	$self->{is_immutable} = 0;
	return;
}

sub is_immutable;
sub is_mutable   { !$_[0]->is_immutable }

sub _install_modifier {
	my( $self, $type, $name, $code ) = @_;
	my $into = $self->name;

	my $original = $into->can($name)
		or $self->throw_error("The method '$name' was not found in the inheritance hierarchy for $into");

	my $modifier_table = $self->{modifiers}{$name};

	if(!$modifier_table){
		my(@before, @after, @around);
		my $cache = $original;
		my $modified = sub {
			if(@before) {
				for my $c (@before) { $c->(@_) }
			}
			unless(@after) {
				return $cache->(@_);
			}

			if(wantarray){ # list context
				my @rval = $cache->(@_);

				for my $c(@after){ $c->(@_) }
				return @rval;
			}
			elsif(defined wantarray){ # scalar context
				my $rval = $cache->(@_);

				for my $c(@after){ $c->(@_) }
				return $rval;
			}
			else{ # void context
				$cache->(@_);

				for my $c(@after){ $c->(@_) }
				return;
			}
		};

		$self->{modifiers}{$name} = $modifier_table = {
			original => $original,

			before   => \@before,
			after    => \@after,
			around   => \@around,

			cache    => \$cache, # cache for around modifiers
		};

		$self->add_method($name => $modified);
	}

	if($type eq 'before'){
		unshift @{$modifier_table->{before}}, $code;
	}
	elsif($type eq 'after'){
		push @{$modifier_table->{after}}, $code;
	}
	else{ # around
		push @{$modifier_table->{around}}, $code;

		my $next = ${ $modifier_table->{cache} };
		${ $modifier_table->{cache} } = sub{ $code->($next, @_) };
	}

	return;
}

sub add_before_method_modifier {
	my ( $self, $name, $code ) = @_;
	$self->_install_modifier( 'before', $name, $code );
}

sub add_around_method_modifier {
	my ( $self, $name, $code ) = @_;
	$self->_install_modifier( 'around', $name, $code );
}

sub add_after_method_modifier {
	my ( $self, $name, $code ) = @_;
	$self->_install_modifier( 'after', $name, $code );
}

sub add_override_method_modifier {
	my ($self, $name, $code) = @_;

	if($self->has_method($name)){
		$self->throw_error("Cannot add an override method if a local method is already present");
	}

	my $package = $self->name;

	my $super_body = $package->can($name)
		or $self->throw_error("You cannot override '$name' because it has no super method");

	$self->add_method($name => sub {
		local $Scalar::Random::PP::OO::SUPER_PACKAGE = $package;
		local $Scalar::Random::PP::OO::SUPER_BODY    = $super_body;
		local @Scalar::Random::PP::OO::SUPER_ARGS    = @_;

		$code->(@_);
	});
	return;
}

sub add_augment_method_modifier {
	my ($self, $name, $code) = @_;
	if($self->has_method($name)){
		$self->throw_error("Cannot add an augment method if a local method is already present");
	}

	my $super = $self->find_method_by_name($name)
		or $self->throw_error("You cannot augment '$name' because it has no super method");

	my $super_package = $super->package_name;
	my $super_body    = $super->body;

	$self->add_method($name => sub{
		local $Scalar::Random::PP::OO::INNER_BODY{$super_package} = $code;
		local $Scalar::Random::PP::OO::INNER_ARGS{$super_package} = [@_];
		$super_body->(@_);
	});
	return;
}

sub does_role {
	my ($self, $role_name) = @_;

	(defined $role_name)
		|| $self->throw_error("You must supply a role name to look for");

	$role_name = $role_name->name if ref $role_name;

	for my $class ($self->linearized_isa) {
		my $meta = Scalar::Random::PP::OO::Util::get_metaclass_by_name($class)
			or next;

		for my $role (@{ $meta->roles }) {

			return 1 if $role->does_role($role_name);
		}
	}

	return 0;
}

# Contents of Mouse::Meta::Method
package Scalar::Random::PP::OO::Meta::Method;
use Scalar::Random::PP::OO::Util qw(:meta); # enables strict and warnings
use Scalar::Util ();

use overload
	'=='  => '_equal',
	'eq'  => '_equal',
	'&{}' => sub{ $_[0]->body },
	fallback => 1,
;

sub wrap{
	my $class = shift;

	return $class->_new(@_);
}

sub _new{
	my($class, %args) = @_;
	my $self = bless \%args, $class;

	if($class ne __PACKAGE__){
		$self->meta->_initialize_object($self, \%args);
	}
	return $self;
}

sub body                 { $_[0]->{body}    }
sub name                 { $_[0]->{name}    }
sub package_name         { $_[0]->{package} }
sub associated_metaclass { $_[0]->{associated_metaclass} }

sub fully_qualified_name {
	my($self) = @_;
	return $self->package_name . '::' . $self->name;
}

# for Moose compat
sub _equal {
	my($l, $r) = @_;

	return Scalar::Util::blessed($r)
			&& $l->body         == $r->body
			&& $l->name         eq $r->name
			&& $l->package_name eq $r->package_name;
}

# Contents of Mouse::Meta::Method::Accessor
package Scalar::Random::PP::OO::Meta::Method::Accessor;
use Scalar::Random::PP::OO::Util qw(:meta); # enables strict and warnings

sub _inline_slot{
	my(undef, $self_var, $attr_name) = @_;
	return sprintf '%s->{q{%s}}', $self_var, $attr_name;
}

sub _generate_accessor_any{
	my($method_class, $type, $attribute, $class) = @_;

	my $name          = $attribute->name;
	my $default       = $attribute->default;
	my $constraint    = $attribute->type_constraint;
	my $builder       = $attribute->builder;
	my $trigger       = $attribute->trigger;
	my $is_weak       = $attribute->is_weak_ref;
	my $should_deref  = $attribute->should_auto_deref;
	my $should_coerce = (defined($constraint) && $constraint->has_coercion && $attribute->should_coerce);

	my $compiled_type_constraint = defined($constraint) ? $constraint->_compiled_type_constraint : undef;

	my $self  = '$_[0]';
	my $slot  = $method_class->_inline_slot($self, $name);;

	my $accessor = sprintf(qq{package %s;\n#line 1 "%s-accessor for %s (%s)"\n}, $class->name, $type, $name, __FILE__)
				 . "sub {\n";

	if ($type eq 'rw' || $type eq 'wo') {
		if($type eq 'rw'){
			$accessor .=
				'if (scalar(@_) >= 2) {' . "\n";
		}
		else{ # writer
			$accessor .=
				'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'.
				'{' . "\n";
		}

		my $value = '$_[1]';

		if (defined $constraint) {
			if ($should_coerce) {
				$accessor .=
					"\n".
					'my $val = $constraint->coerce('.$value.');';
				$value = '$val';
			}
			$accessor .=
				"\n".
				'$compiled_type_constraint->('.$value.') or
					$attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n";
		}

		# if there's nothing left to do for the attribute we can return during
		# this setter
		$accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref;

		$accessor .= "$slot = $value;\n";

		if ($is_weak) {
			$accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
		}

		if ($trigger) {
			$accessor .= '$trigger->('.$self.', '.$value.');' . "\n";
		}

		$accessor .= "}\n";
	}
	elsif($type eq 'ro') {
		$accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n";
	}
	else{
		$class->throw_error("Unknown accessor type '$type'");
	}

	if ($attribute->is_lazy and $type ne 'wo') {
		my $value;

		if (defined $builder){
			$value = "$self->\$builder()";
		}
		elsif (ref($default) eq 'CODE'){
			$value = "$self->\$default()";
		}
		else{
			$value = '$default';
		}

		$accessor .= "els" if $type eq 'rw';
		$accessor .= "if(!exists $slot){\n";
		if($should_coerce){
			$accessor .= "$slot = \$constraint->coerce($value)";
		}
		elsif(defined $constraint){
			$accessor .= "my \$tmp = $value;\n";

			$accessor .= "\$compiled_type_constraint->(\$tmp)";
			$accessor .= " || \$attribute->_throw_type_constraint_error(\$tmp, \$constraint);\n";
			$accessor .= "$slot = \$tmp;\n";
		}
		else{
			$accessor .= "$slot = $value;\n";
		}
		if ($is_weak) {
			$accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
		}
		$accessor .= "}\n";
	}

	if ($should_deref) {
		if ($constraint->is_a_type_of('ArrayRef')) {
			$accessor .= "return \@{ $slot || [] } if wantarray;\n";
		}
		elsif($constraint->is_a_type_of('HashRef')){
			$accessor .= "return \%{ $slot || {} } if wantarray;\n";
		}
		else{
			$class->throw_error("Can not auto de-reference the type constraint " . $constraint->name);
		}
	}

	$accessor .= "return $slot;\n}\n";

	#print $accessor, "\n";
	my $code;
	my $e = do{
		local $@;
		$code = eval $accessor;
		$@;
	};
	die $e if $e;

	return $code;
}

sub _generate_accessor{
	#my($self, $attribute, $metaclass) = @_;
	my $self = shift;
	return $self->_generate_accessor_any(rw => @_);
}

sub _generate_reader {
	#my($self, $attribute, $metaclass) = @_;
	my $self = shift;
	return $self->_generate_accessor_any(ro => @_);
}

sub _generate_writer {
	#my($self, $attribute, $metaclass) = @_;
	my $self = shift;
	return $self->_generate_accessor_any(wo => @_);
}

sub _generate_predicate {
	#my($self, $attribute, $metaclass) = @_;
	my(undef, $attribute) = @_;

	my $slot = $attribute->name;
	return sub{
		return exists $_[0]->{$slot};
	};
}

sub _generate_clearer {
	#my($self, $attribute, $metaclass) = @_;
	my(undef, $attribute) = @_;

	my $slot = $attribute->name;
	return sub{
		delete $_[0]->{$slot};
	};
}

# Contents of Mouse::Meta::Method::Constructor
package Scalar::Random::PP::OO::Meta::Method::Constructor;
use Scalar::Random::PP::OO::Util qw(:meta); # enables strict and warnings

sub _inline_slot{
	my(undef, $self_var, $attr_name) = @_;
	return sprintf '%s->{q{%s}}', $self_var, $attr_name;
}

sub _generate_constructor {
	my ($class, $metaclass, $args) = @_;

	my $associated_metaclass_name = $metaclass->name;

	my @attrs         = $metaclass->get_all_attributes;

	my $buildall      = $class->_generate_BUILDALL($metaclass);
	my $buildargs     = $class->_generate_BUILDARGS($metaclass);
	my $processattrs  = $class->_generate_processattrs($metaclass, \@attrs);

	my @checks = map { $_ && $_->_compiled_type_constraint }
				 map { $_->type_constraint } @attrs;

	my $source = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"...";
		sub \{
			my \$class = shift;
			return \$class->Scalar::Random::PP::OO::Object::new(\@_)
				if \$class ne q{$associated_metaclass_name};
			# BUILDARGS
			$buildargs;
			my \$instance = bless {}, \$class;
			# process attributes
			$processattrs;
			# BUILDALL
			$buildall;
			return \$instance;
		}
...
	#warn $source;
	my $code;
	my $e = do{
		local $@;
		$code = eval $source;
		$@;
	};
	die $e if $e;
	return $code;
}

sub _generate_processattrs {
	my ($method_class, $metaclass, $attrs) = @_;
	my @res;

	my $has_triggers;
	my $strict = $metaclass->strict_constructor;

	if($strict){
		push @res, 'my $used = 0;';
	}

	for my $index (0 .. @$attrs - 1) {
		my $code = '';

		my $attr = $attrs->[$index];
		my $key  = $attr->name;

		my $init_arg        = $attr->init_arg;
		my $type_constraint = $attr->type_constraint;
		my $is_weak_ref     = $attr->is_weak_ref;
		my $need_coercion;

		my $instance_slot  = $method_class->_inline_slot('$instance', $key);
		my $attr_var       = "\$attrs[$index]";
		my $constraint_var;

		if(defined $type_constraint){
			 $constraint_var = "$attr_var\->{type_constraint}";
			 $need_coercion  = ($attr->should_coerce && $type_constraint->has_coercion);
		}

		$code .= "# initialize $key\n";

		my $post_process = '';
		if(defined $type_constraint){
			$post_process .= "\$checks[$index]->($instance_slot)";
			$post_process .= "  or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n";
		}
		if($is_weak_ref){
			$post_process .= "Scalar::Util::weaken($instance_slot) if ref $instance_slot;\n";
		}

		if (defined $init_arg) {
			my $value = "\$args->{q{$init_arg}}";

			$code .= "if (exists $value) {\n";

			if($need_coercion){
				$value = "$constraint_var->coerce($value)";
			}

			$code .= "$instance_slot = $value;\n";
			$code .= $post_process;

			if ($attr->has_trigger) {
				$has_triggers++;
				$code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n";
			}

			if ($strict){
				$code .= '++$used;' . "\n";
			}

			$code .= "\n} else {\n"; # $value exists
		}

		if ($attr->has_default || $attr->has_builder) {
			unless ($attr->is_lazy) {
				my $default = $attr->default;
				my $builder = $attr->builder;

				my $value;
				if (defined($builder)) {
					$value = "\$instance->$builder()";
				}
				elsif (ref($default) eq 'CODE') {
					$value = "$attr_var\->{default}->(\$instance)";
				}
				elsif (defined($default)) {
					$value = "$attr_var\->{default}";
				}
				else {
					$value = 'undef';
				}

				if($need_coercion){
					$value = "$constraint_var->coerce($value)";
				}

				$code .= "$instance_slot = $value;\n";
				if($is_weak_ref){
					$code .= "Scalar::Util::weaken($instance_slot);\n";
				}
			}
		}
		elsif ($attr->is_required) {
			$code .= "Carp::confess('Attribute ($key) is required');";
		}

		$code .= "}\n" if defined $init_arg;

		push @res, $code;
	}

	if($strict){
		push @res, q{if($used < keys %{$args})}
			. q{{ $metaclass->_report_unknown_args(\@attrs, $args) }};
	}

	if($metaclass->is_anon_class){
		push @res, q{$instance->{__METACLASS__} = $metaclass;};
	}

	if($has_triggers){
		unshift @res, q{my @triggers;};
		push    @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
	}

	return join "\n", @res;
}

sub _generate_BUILDARGS {
	my(undef, $metaclass) = @_;

	my $class = $metaclass->name;
	if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Scalar::Random::PP::OO::Object::BUILDARGS ) {
		return 'my $args = $class->BUILDARGS(@_)';
	}

	return <<'...';
		my $args;
		if ( scalar @_ == 1 ) {
			( ref( $_[0] ) eq 'HASH' )
				|| Carp::confess "Single parameters to new() must be a HASH ref";
			$args = +{ %{ $_[0] } };
		}
		else {
			$args = +{@_};
		}
...
}

sub _generate_BUILDALL {
	my (undef, $metaclass) = @_;

	return '' unless $metaclass->name->can('BUILD');

	my @code;
	for my $class ($metaclass->linearized_isa) {
		if (Scalar::Random::PP::OO::Util::get_code_ref($class, 'BUILD')) {
			unshift  @code, qq{${class}::BUILD(\$instance, \$args);};
		}
	}
	return join "\n", @code;
}

# Contents of Mouse::Meta::Method::Delegation
package Scalar::Random::PP::OO::Meta::Method::Delegation;
use Scalar::Random::PP::OO::Util qw(:meta); # enables strict and warnings
use Scalar::Util;

sub _generate_delegation{
	my (undef, $attr, $handle_name, $method_to_call) = @_;

	my @curried_args;
	if(ref($method_to_call) eq 'ARRAY'){
		($method_to_call, @curried_args) = @{$method_to_call};
	}

	# If it has a reader, we must use it to make method modifiers work
	my $reader = $attr->get_read_method() || $attr->get_read_method_ref();

	my $can_be_optimized = $attr->{_method_delegation_can_be_optimized};

	if(!defined $can_be_optimized){
		my $tc = $attr->type_constraint;

		$attr->{_method_delegation_can_be_optimized} =
			(defined($tc) && $tc->is_a_type_of('Object'))
			&& ($attr->is_required || $attr->has_default || $attr->has_builder)
			&& ($attr->is_lazy || !$attr->has_clearer);
	}

	if($can_be_optimized){
		# need not check the attribute value
		return sub {
			return shift()->$reader()->$method_to_call(@curried_args, @_);
		};
	}
	else {
		# need to check the attribute value
		return sub {
			my $instance = shift;
			my $proxy    = $instance->$reader();

			my $error = !defined($proxy)                              ? ' is not defined'
					  : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')}
																	  : undef;
			if ($error) {
				$instance->meta->throw_error(
					"Cannot delegate $handle_name to $method_to_call because "
						. "the value of "
						. $attr->name
						. $error
				 );
			}
			$proxy->$method_to_call(@curried_args, @_);
		};
	}
}


# Contents of Mouse::Meta::Method::Destructor
package Scalar::Random::PP::OO::Meta::Method::Destructor;
use Scalar::Random::PP::OO::Util qw(:meta); # enables strict and warnings

sub _empty_DESTROY{ }

sub _generate_destructor{
	my (undef, $metaclass) = @_;

	if(!$metaclass->name->can('DEMOLISH')){
		return \&_empty_DESTROY;
	}

	my $demolishall = '';
	for my $class ($metaclass->linearized_isa) {
		if (Scalar::Random::PP::OO::Util::get_code_ref($class, 'DEMOLISH')) {
			$demolishall .= sprintf "%s::DEMOLISH(\$self, \$Scalar::Random::PP::OO::Util::in_global_destruction);\n",
				$class,
		}
	}

	my $source = sprintf(<<'END_DESTROY', __LINE__, __FILE__, $demolishall);
#line %d %s
	sub {
		my $self = shift;
		my $e = do{
			local $?;
			local $@;
			eval{
				# demolishall
				%s;
			};
			$@;
		};
		no warnings 'misc';
		die $e if $e; # rethrow
	}
END_DESTROY

	my $code;
	my $e = do{
		local $@;
		$code = eval $source;
		$@;
	};
	die $e if $e;
	return $code;
}

# Contents of Mouse::Meta::Module
package Scalar::Random::PP::OO::Meta::Module;
use Scalar::Random::PP::OO::Util qw/:meta get_code_package get_code_ref not_supported/; # enables strict and warnings
no warnings 'once';

use Carp         ();
use Scalar::Util ();

my %METAS;

if(Scalar::Random::PP::OO::Util::MOUSE_XS){
	# register meta storage for performance
	Scalar::Random::PP::OO::Util::__register_metaclass_storage(\%METAS, 0);

	# ensure thread safety
	*CLONE = sub { Scalar::Random::PP::OO::Util::__register_metaclass_storage(\%METAS, 1) };
}

sub _metaclass_cache { # DEPRECATED
	my($self, $name) = @_;
	Carp::cluck('_metaclass_cache() has been deprecated. Use Scalar::Random::PP::OO::Util::get_metaclass_by_name() instead');
	return $METAS{$name};
}

sub initialize {
	my($class, $package_name, @args) = @_;

	($package_name && !ref($package_name))
		|| $class->throw_error("You must pass a package name and it cannot be blessed");

	return $METAS{$package_name}
		||= $class->_construct_meta(package => $package_name, @args);
}

sub reinitialize {
	my($class, $package_name, @args) = @_;

	$package_name = $package_name->name if ref $package_name;

	($package_name && !ref($package_name))
		|| $class->throw_error("You must pass a package name and it cannot be blessed");

	delete $METAS{$package_name};
	return $class->initialize($package_name, @args);
}

sub _class_of{
	my($class_or_instance) = @_;
	return undef unless defined $class_or_instance;
	return $METAS{ ref($class_or_instance) || $class_or_instance };
}

# Means of accessing all the metaclasses that have
# been initialized thus far
#sub _get_all_metaclasses         {        %METAS         }
sub _get_all_metaclass_instances { values %METAS         }
sub _get_all_metaclass_names     { keys   %METAS         }
sub _get_metaclass_by_name       { $METAS{$_[0]}         }
#sub _store_metaclass_by_name     { $METAS{$_[0]} = $_[1] }
#sub _weaken_metaclass            { weaken($METAS{$_[0]}) }
#sub _does_metaclass_exist        { defined $METAS{$_[0]} }
#sub _remove_metaclass_by_name    { delete $METAS{$_[0]}  }

sub name;

sub namespace;

# add_attribute is an abstract method

sub get_attribute_map { # DEPRECATED
	Carp::cluck('get_attribute_map() has been deprecated. Use get_attribute_list() and get_attribute() instead');
	return $_[0]->{attributes};
}

sub has_attribute     { exists $_[0]->{attributes}->{$_[1]} }
sub get_attribute     {        $_[0]->{attributes}->{$_[1]} }
sub remove_attribute  { delete $_[0]->{attributes}->{$_[1]} }

sub get_attribute_list{ keys   %{$_[0]->{attributes}} }

# XXX: for backward compatibility
my %foreign = map{ $_ => undef } qw(
	Scalar::Random::PP::OO Scalar::Random::PP::OO::Role Scalar::Random::PP::OO::Util Scalar::Random::PP::OO::Util::TypeConstraints
	Carp Scalar::Util List::Util
);
sub _code_is_mine{
#    my($self, $code) = @_;

	return !exists $foreign{ get_code_package($_[1]) };
}

sub add_method;

sub has_method {
	my($self, $method_name) = @_;

	defined($method_name)
		or $self->throw_error('You must define a method name');

	return defined($self->{methods}{$method_name}) || do{
		my $code = get_code_ref($self->{package}, $method_name);
		$code && $self->_code_is_mine($code);
	};
}

sub get_method_body {
	my($self, $method_name) = @_;

	defined($method_name)
		or $self->throw_error('You must define a method name');

	return $self->{methods}{$method_name} ||= do{
		my $code = get_code_ref($self->{package}, $method_name);
		$code && $self->_code_is_mine($code) ? $code : undef;
	};
}

sub get_method{
	my($self, $method_name) = @_;

	if(my $code = $self->get_method_body($method_name)){
		return Scalar::Random::PP::OO::Util::load_class($self->method_metaclass)->wrap(
			body                 => $code,
			name                 => $method_name,
			package              => $self->name,
			associated_metaclass => $self,
		);
	}

	return undef;
}

sub get_method_list {
	my($self) = @_;

	return grep { $self->has_method($_) } keys %{ $self->namespace };
}

sub _collect_methods { # Scalar::Random::PP::OO specific
	my($meta, @args) = @_;

	my @methods;
	foreach my $arg(@args){
		if(my $type = ref $arg){
			if($type eq 'Regexp'){
				push @methods, grep { $_ =~ $arg } $meta->get_all_method_names;
			}
			elsif($type eq 'ARRAY'){
				push @methods, @{$arg};
			}
			else{
				my $subname = ( caller(1) )[3];
				$meta->throw_error(
					sprintf(
						'Methods passed to %s must be provided as a list, ArrayRef or regular expression, not %s',
						$subname,
						$type,
					)
				);
			}
		 }
		 else{
			push @methods, $arg;
		 }
	 }
	 return @methods;
}

my $ANON_SERIAL = 0;  # anonymous class/role id
my %IMMORTALS;        # immortal anonymous classes

sub create {
	my($self, $package_name, %options) = @_;

	my $class = ref($self) || $self;
	$self->throw_error('You must pass a package name') if @_ < 2;

	my $superclasses;
	if(exists $options{superclasses}){
		if(Scalar::Random::PP::OO::Util::is_a_metarole($self)){
			delete $options{superclasses};
		}
		else{
			$superclasses = delete $options{superclasses};
			(ref $superclasses eq 'ARRAY')
				|| $self->throw_error("You must pass an ARRAY ref of superclasses");
		}
	}

	my $attributes = delete $options{attributes};
	if(defined $attributes){
		(ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
			|| $self->throw_error("You must pass an ARRAY ref of attributes");
	}
	my $methods = delete $options{methods};
	if(defined $methods){
		(ref $methods eq 'HASH')
			|| $self->throw_error("You must pass a HASH ref of methods");
	}
	my $roles = delete $options{roles};
	if(defined $roles){
		(ref $roles eq 'ARRAY')
			|| $self->throw_error("You must pass an ARRAY ref of roles");
	}
	my $mortal;
	my $cache_key;

	if(!defined $package_name){ # anonymous
		$mortal = !$options{cache};

		# anonymous but immortal
		if(!$mortal){
				# something like Super::Class|Super::Class::2=Role|Role::1
				$cache_key = join '=' => (
					join('|',      @{$superclasses || []}),
					join('|', sort @{$roles        || []}),
				);
				return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
		}
		$options{anon_serial_id} = ++$ANON_SERIAL;
		$package_name = $class . '::__ANON__::' . $ANON_SERIAL;
	}

	# instantiate a module
	{
		no strict 'refs';
		${ $package_name . '::VERSION'   } = delete $options{version}   if exists $options{version};
		${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
	}

	my $meta = $self->initialize( $package_name, %options);

	Scalar::Util::weaken $METAS{$package_name}
		if $mortal;

	$meta->add_method(meta => sub {
		$self->initialize(ref($_[0]) || $_[0]);
	});

	$meta->superclasses(@{$superclasses})
		if defined $superclasses;

	# NOTE:
	# process attributes first, so that they can
	# install accessors, but locally defined methods
	# can then overwrite them. It is maybe a little odd, but
	# I think this should be the order of things.
	if (defined $attributes) {
		if(ref($attributes) eq 'ARRAY'){
			# array of Scalar::Random::PP::OO::Meta::Attribute
			foreach my $attr (@{$attributes}) {
				$meta->add_attribute($attr);
			}
		}
		else{
			# hash map of name and attribute spec pairs
			while(my($name, $attr) = each %{$attributes}){
				$meta->add_attribute($name => $attr);
			}
		}
	}
	if (defined $methods) {
		while(my($method_name, $method_body) = each %{$methods}){
			$meta->add_method($method_name, $method_body);
		}
	}
	if (defined $roles){
		Scalar::Random::PP::OO::Util::apply_all_roles($package_name, @{$roles});
	}

	if($cache_key){
		$IMMORTALS{$cache_key} = $meta;
	}

	return $meta;
}

sub DESTROY{
	my($self) = @_;

	return if $Scalar::Random::PP::OO::Util::in_global_destruction;

	my $serial_id = $self->{anon_serial_id};

	return if !$serial_id;
	# mortal anonymous class

	# XXX: cleaning stash with threads causes panic/SEGV.
	if(exists $INC{'threads.pm'}) {
		# (caller)[2] indicates the caller's line number,
		# which is zero when the current thread is joining.
		return if( (caller)[2] == 0);
	}

	# @ISA is a magical variable, so we clear it manually.
	@{$self->{superclasses}} = () if exists $self->{superclasses};

	# Then, clear the symbol table hash
	%{$self->namespace} = ();

	my $name = $self->name;
	delete $METAS{$name};

	$name =~ s/ $serial_id \z//xms;
	no strict 'refs';
	delete ${$name}{ $serial_id . '::' };

	return;
}

sub throw_error{
	my($self, $message, %args) = @_;

	local $Carp::CarpLevel  = $Carp::CarpLevel + 1 + ($args{depth} || 0);
	local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though

	if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0
		Carp::croak($message);
	}
	else{
		Carp::confess($message);
	}
}

# Contents of Mouse::Meta::Role
package Scalar::Random::PP::OO::Meta::Role;
use Scalar::Random::PP::OO::Util qw(:meta not_supported); # enables strict and warnings

use Scalar::Random::PP::OO::Meta::Module;
our @ISA = qw(Scalar::Random::PP::OO::Meta::Module);

sub method_metaclass;

sub _construct_meta {
	my $class = shift;

	my %args  = @_;

	$args{methods}          = {};
	$args{attributes}       = {};
	$args{required_methods} = [];
	$args{roles}            = [];

	my $self = bless \%args, ref($class) || $class;
	if($class ne __PACKAGE__){
		$self->meta->_initialize_object($self, \%args);
	}

	return $self;
}

sub create_anon_role{
	my $self = shift;
	return $self->create(undef, @_);
}

sub is_anon_role;

sub get_roles;

sub calculate_all_roles {
	my $self = shift;
	my %seen;
	return grep { !$seen{ $_->name }++ }
		   ($self, map  { $_->calculate_all_roles } @{ $self->get_roles });
}

sub get_required_method_list{
	return @{ $_[0]->{required_methods} };
}

sub add_required_methods {
	my($self, @methods) = @_;
	my %required = map{ $_ => 1 } @{$self->{required_methods}};
	push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods;
	return;
}

sub requires_method {
	my($self, $name) = @_;
	return scalar( grep{ $_ eq $name } @{ $self->{required_methods} } ) != 0;
}

sub add_attribute {
	my $self = shift;
	my $name = shift;

	$self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
	return;
}

sub _check_required_methods{
	my($role, $consumer, $args) = @_;

	if($args->{_to} eq 'role'){
		$consumer->add_required_methods($role->get_required_method_list);
	}
	else{ # to class or instance
		my $consumer_class_name = $consumer->name;

		my @missing;
		foreach my $method_name(@{$role->{required_methods}}){
			next if exists $args->{aliased_methods}{$method_name};
			next if exists $role->{methods}{$method_name};
			next if $consumer_class_name->can($method_name);

			push @missing, $method_name;
		}
		if(@missing){
			$role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
				$role->name,
				(@missing == 1 ? '' : 's'), # method or methods
				Scalar::Random::PP::OO::Util::quoted_english_list(@missing),
				$consumer_class_name);
		}
	}

	return;
}

sub _apply_methods{
	my($role, $consumer, $args) = @_;

	my $alias    = $args->{-alias};
	my $excludes = $args->{-excludes};

	foreach my $method_name($role->get_method_list){
		next if $method_name eq 'meta';

		my $code = $role->get_method_body($method_name);

		if(!exists $excludes->{$method_name}){
			if(!$consumer->has_method($method_name)){
				# The third argument $role is used in Role::Composite
				$consumer->add_method($method_name => $code, $role);
			}
		}

		if(exists $alias->{$method_name}){
			my $dstname = $alias->{$method_name};

			my $dstcode = $consumer->get_method_body($dstname);

			if(defined($dstcode) && $dstcode != $code){
				$role->throw_error("Cannot create a method alias if a local method of the same name exists");
			}
			else{
				$consumer->add_method($dstname => $code, $role);
			}
		}
	}

	return;
}

sub _apply_attributes{
	#my($role, $consumer, $args) = @_;
	my($role, $consumer) = @_;

	for my $attr_name ($role->get_attribute_list) {
		next if $consumer->has_attribute($attr_name);

		$consumer->add_attribute($attr_name => $role->get_attribute($attr_name));
	}
	return;
}

sub _apply_modifiers{
	#my($role, $consumer, $args) = @_;
	my($role, $consumer) = @_;


	if(my $modifiers = $role->{override_method_modifiers}){
		foreach my $method_name (keys %{$modifiers}){
			$consumer->add_override_method_modifier($method_name => $modifiers->{$method_name});
		}
	}

	for my $modifier_type (qw/before around after/) {
		my $table = $role->{"${modifier_type}_method_modifiers"}
			or next;

		my $add_modifier = "add_${modifier_type}_method_modifier";

		while(my($method_name, $modifiers) = each %{$table}){
			foreach my $code(@{ $modifiers }){
				next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers
				$consumer->$add_modifier($method_name => $code);
			}
		}
	}
	return;
}

sub _append_roles{
	#my($role, $consumer, $args) = @_;
	my($role, $consumer) = @_;

	my $roles = $consumer->{roles};

	foreach my $r($role, @{$role->get_roles}){
		if(!$consumer->does_role($r)){
			push @{$roles}, $r;
		}
	}
	return;
}

# Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
sub apply {
	my $self     = shift;
	my $consumer = shift;

	my %args = (@_ == 1) ? %{ $_[0] } : @_;

	my $instance;

	if(Scalar::Random::PP::OO::Util::is_a_metaclass($consumer)){  # Application::ToClass
		$args{_to} = 'class';
	}
	elsif(Scalar::Random::PP::OO::Util::is_a_metarole($consumer)){ # Application::ToRole
		$args{_to} = 'role';
	}
	else{                                       # Appplication::ToInstance
		$args{_to} = 'instance';
		$instance  = $consumer;

		$consumer = (Scalar::Random::PP::OO::Util::class_of($instance) || 'Scalar::Random::PP::OO::Meta::Class')->create_anon_class(
			superclasses => [ref $instance],
			cache        => 1,
		);
	}

	if($args{alias} && !exists $args{-alias}){
		$args{-alias} = $args{alias};
	}
	if($args{excludes} && !exists $args{-excludes}){
		$args{-excludes} = $args{excludes};
	}

	$args{aliased_methods} = {};
	if(my $alias = $args{-alias}){
		@{$args{aliased_methods}}{ values %{$alias} } = ();
	}

	if(my $excludes = $args{-excludes}){
		$args{-excludes} = {}; # replace with a hash ref
		if(ref $excludes){
			%{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
		}
		else{
			$args{-excludes}{$excludes} = undef;
		}
	}

	$self->_check_required_methods($consumer, \%args);
	$self->_apply_attributes($consumer, \%args);
	$self->_apply_methods($consumer, \%args);
	$self->_apply_modifiers($consumer, \%args);
	$self->_append_roles($consumer, \%args);


	if(defined $instance){ # Application::ToInstance
		# rebless instance
		bless $instance, $consumer->name;
		$consumer->_initialize_object($instance, $instance, 1);
	}

	return;
}


sub combine {
	my($self, @role_specs) = @_;

	require 'Scalar/Random/PP/OO/Meta/Role/Composite.pm'; # we don't want to create its namespace

	my $composite = Scalar::Random::PP::OO::Meta::Role::Composite->create_anon_role();

	foreach my $role_spec (@role_specs) {
		my($role_name, $args) = @{$role_spec};
		$role_name->meta->apply($composite, %{$args});
	}
	return $composite;
}

sub add_before_method_modifier;
sub add_around_method_modifier;
sub add_after_method_modifier;

sub get_before_method_modifiers;
sub get_around_method_modifiers;
sub get_after_method_modifiers;

sub add_override_method_modifier{
	my($self, $method_name, $method) = @_;

	if($self->has_method($method_name)){
		# This error happens in the override keyword or during role composition,
		# so I added a message, "A local method of ...", only for compatibility (gfx)
		$self->throw_error("Cannot add an override of method '$method_name' "
				   . "because there is a local version of '$method_name'"
				   . "(A local method of the same name as been found)");
	}

	$self->{override_method_modifiers}->{$method_name} = $method;
}

sub get_override_method_modifier {
	my ($self, $method_name) = @_;
	return $self->{override_method_modifiers}->{$method_name};
}

sub does_role {
	my ($self, $role_name) = @_;

	(defined $role_name)
		|| $self->throw_error("You must supply a role name to look for");

	$role_name = $role_name->name if ref $role_name;

	# if we are it,.. then return true
	return 1 if $role_name eq $self->name;
	# otherwise.. check our children
	for my $role (@{ $self->get_roles }) {
		return 1 if $role->does_role($role_name);
	}
	return 0;
}

# Contents of Mouse::Meta::Role::Composite
package Scalar::Random::PP::OO::Meta::Role::Composite;
use Scalar::Random::PP::OO::Util; # enables strict and warnings
use Scalar::Random::PP::OO::Meta::Role;
our @ISA = qw(Scalar::Random::PP::OO::Meta::Role);

sub get_method_list{
	my($self) = @_;
	return keys %{ $self->{methods} };
}

sub add_method {
	my($self, $method_name, $code, $role) = @_;

	if( ($self->{methods}{$method_name} || 0) == $code){
		# This role already has the same method.
		return;
	}

	if($method_name eq 'meta'){
		$self->SUPER::add_method($method_name => $code);
	}
	else{
		# no need to add a subroutine to the stash
		my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
		push @{$roles}, $role;
		if(@{$roles} > 1){
			$self->{conflicting_methods}{$method_name}++;
		}
		$self->{methods}{$method_name} = $code;
	}
	return;
}

sub get_method_body {
	my($self, $method_name) = @_;
	return $self->{methods}{$method_name};
}

sub has_method {
	# my($self, $method_name) = @_;
	return 0; # to fool _apply_methods() in combine()
}

sub has_attribute{
	# my($self, $method_name) = @_;
	return 0; # to fool _appply_attributes() in combine()
}

sub has_override_method_modifier{
	# my($self, $method_name) = @_;
	return 0; # to fool _apply_modifiers() in combine()
}

sub add_attribute{
	my $self      = shift;
	my $attr_name = shift;
	my $spec      = (@_ == 1 ? $_[0] : {@_});

	my $existing = $self->{attributes}{$attr_name};
	if($existing && $existing != $spec){
		$self->throw_error("We have encountered an attribute conflict with '$attr_name' "
						 . "during composition. This is fatal error and cannot be disambiguated.");
	}
	$self->SUPER::add_attribute($attr_name, $spec);
	return;
}

sub add_override_method_modifier{
	my($self, $method_name, $code) = @_;

	my $existing = $self->{override_method_modifiers}{$method_name};
	if($existing && $existing != $code){
		$self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
						  . "composition (Two 'override' methods of the same name encountered). "
						  . "This is fatal error.")
	}
	$self->SUPER::add_override_method_modifier($method_name, $code);
	return;
}

# components of apply()

sub _apply_methods{
	my($self, $consumer, $args) = @_;

	if(exists $self->{conflicting_methods}){
		my $consumer_class_name = $consumer->name;

		my @conflicting = grep{ !$consumer_class_name->can($_) } keys %{ $self->{conflicting_methods} };

		if(@conflicting == 1){
			my $method_name = $conflicting[0];
			my $roles       = Scalar::Random::PP::OO::Util::quoted_english_list(map{ $_->name } @{ $self->{composed_roles_by_method}{$method_name} });
			$self->throw_error(
			   sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
				   $roles, $method_name, $consumer_class_name
			);
		}
		elsif(@conflicting > 1){
			my %seen;
			my $roles = Scalar::Random::PP::OO::Util::quoted_english_list(
				grep{ !$seen{$_}++ } # uniq
				map { $_->name }
				map { @{$_} } @{ $self->{composed_roles_by_method} }{@conflicting}
			);

			$self->throw_error(
			   sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
				   $roles,
				   Scalar::Random::PP::OO::Util::quoted_english_list(@conflicting),
				   $consumer_class_name
			);
		}
	}

	$self->SUPER::_apply_methods($consumer, $args);
	return;
}
# Contents of Mouse::Meta::Role::Method
package Scalar::Random::PP::OO::Meta::Role::Method;
use Scalar::Random::PP::OO::Util; # enables strict and warnings

use Scalar::Random::PP::OO::Meta::Method;
our @ISA = qw(Scalar::Random::PP::OO::Meta::Method);

sub _new{
	my($class, %args) = @_;
	my $self = bless \%args, $class;

	if($class ne __PACKAGE__){
		$self->meta->_initialize_object($self, \%args);
	}
	return $self;
}

# Contents of Mouse::Object
package Scalar::Random::PP::OO::Object;
use Scalar::Random::PP::OO::Util qw(does dump meta); # enables strict and warnings

sub new;
sub BUILDARGS;
sub BUILDALL;

sub DESTROY;
sub DEMOLISHALL;

# Contents of Mouse::Role
package Scalar::Random::PP::OO::Role;
use Scalar::Random::PP::OO::Exporter; # enables strict and warnings

our $VERSION = '0.70';

use Carp         qw(confess);
use Scalar::Util qw(blessed);

use Scalar::Random::PP::OO::Util  qw(not_supported);
use Scalar::Random::PP::OO::Meta::Role;
use Scalar::Random::PP::OO ();

Scalar::Random::PP::OO::Exporter->setup_import_methods(
	as_is => [qw(
		extends with
		has
		before after around
		override super
		augment  inner

		requires excludes
	),
		\&Scalar::Util::blessed,
		\&Carp::confess,
	],
);


sub extends  {
	Carp::croak "Roles do not support 'extends'";
}

sub with     {
	my $meta = Scalar::Random::PP::OO::Meta::Role->initialize(scalar caller);
	Scalar::Random::PP::OO::Util::apply_all_roles($meta->name, @_);
	return;
}

sub has {
	my $meta = Scalar::Random::PP::OO::Meta::Role->initialize(scalar caller);
	my $name = shift;

	$meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
		if @_ % 2; # odd number of arguments

	if(ref $name){ # has [qw(foo bar)] => (...)
		for (@{$name}){
			$meta->add_attribute($_ => @_);
		}
	}
	else{ # has foo => (...)
		$meta->add_attribute($name => @_);
	}
	return;
}

sub before {
	my $meta = Scalar::Random::PP::OO::Meta::Role->initialize(scalar caller);
	my $code = pop;
	for my $name($meta->_collect_methods(@_)) {
		$meta->add_before_method_modifier($name => $code);
	}
	return;
}

sub after {
	my $meta = Scalar::Random::PP::OO::Meta::Role->initialize(scalar caller);
	my $code = pop;
	for my $name($meta->_collect_methods(@_)) {
		$meta->add_after_method_modifier($name => $code);
	}
	return;
}

sub around {
	my $meta = Scalar::Random::PP::OO::Meta::Role->initialize(scalar caller);
	my $code = pop;
	for my $name($meta->_collect_methods(@_)) {
		$meta->add_around_method_modifier($name => $code);
	}
	return;
}


sub super {
	return if !defined $Scalar::Random::PP::OO::SUPER_BODY;
	$Scalar::Random::PP::OO::SUPER_BODY->(@Scalar::Random::PP::OO::SUPER_ARGS);
}

sub override {
	# my($name, $code) = @_;
	Scalar::Random::PP::OO::Meta::Role->initialize(scalar caller)->add_override_method_modifier(@_);
	return;
}

# We keep the same errors messages as Moose::Role emits, here.
sub inner {
	Carp::croak "Roles cannot support 'inner'";
}

sub augment {
	Carp::croak "Roles cannot support 'augment'";
}

sub requires {
	my $meta = Scalar::Random::PP::OO::Meta::Role->initialize(scalar caller);
	$meta->throw_error("Must specify at least one method") unless @_;
	$meta->add_required_methods(@_);
	return;
}

sub excludes {
	not_supported;
}

sub init_meta{
	shift;
	my %args = @_;

	my $class = $args{for_class}
		or Carp::confess("Cannot call init_meta without specifying a for_class");

	my $metaclass  = $args{metaclass}  || 'Scalar::Random::PP::OO::Meta::Role';

	my $meta = $metaclass->initialize($class);

	$meta->add_method(meta => sub{
		$metaclass->initialize(ref($_[0]) || $_[0]);
	});

	# make a role type for each Scalar::Random::PP::OO role
	Scalar::Random::PP::OO::Util::TypeConstraints::role_type($class)
		unless Scalar::Random::PP::OO::Util::TypeConstraints::find_type_constraint($class);

	return $meta;
}

# Contents of Mouse::Util::MetaRole
package Scalar::Random::PP::OO::Util::MetaRole;
use Scalar::Random::PP::OO::Util; # enables strict and warnings
use Scalar::Util ();

sub apply_metaclass_roles {
	my %args = @_;
	_fixup_old_style_args(\%args);

	return apply_metaroles(%args);
}

sub apply_metaroles {
	my %args = @_;

	my $for = Scalar::Util::blessed($args{for})
		?                                     $args{for}
		: Scalar::Random::PP::OO::Util::get_metaclass_by_name( $args{for} );

	if(!$for){
		Carp::confess("You must pass an initialized class, but '$args{for}' has no metaclass");
	}

	if ( Scalar::Random::PP::OO::Util::is_a_metarole($for) ) {
		return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
	}
	else {
		return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
	}
}

sub _make_new_metaclass {
	my($for, $roles, $primary) = @_;

	return $for unless keys %{$roles};

	my $new_metaclass = exists($roles->{$primary})
		? _make_new_class( ref $for, $roles->{$primary} ) # new class with traits
		:                  ref $for;

	my %classes;

	for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
		my $metaclass;
		my $attr = $for->can($metaclass = ($key . '_metaclass'))
				|| $for->can($metaclass = ($key . '_class'))
				|| $for->throw_error("Unknown metaclass '$key'");

		$classes{ $metaclass }
			= _make_new_class( $for->$attr(), $roles->{$key} );
	}

	return $new_metaclass->reinitialize( $for, %classes );
}


sub _fixup_old_style_args {
	my $args = shift;

	return if $args->{class_metaroles} || $args->{roles_metaroles};

	$args->{for} = delete $args->{for_class}
		if exists $args->{for_class};

	my @old_keys = qw(
		attribute_metaclass_roles
		method_metaclass_roles
		wrapped_method_metaclass_roles
		instance_metaclass_roles
		constructor_class_roles
		destructor_class_roles
		error_class_roles

		application_to_class_class_roles
		application_to_role_class_roles
		application_to_instance_class_roles
		application_role_summation_class_roles
	);

	my $for = Scalar::Util::blessed($args->{for})
		?                                     $args->{for}
		: Scalar::Random::PP::OO::Util::get_metaclass_by_name( $args->{for} );

	my $top_key;
	if( Scalar::Random::PP::OO::Util::is_a_metaclass($for) ){
		$top_key = 'class_metaroles';

		$args->{class_metaroles}{class} = delete $args->{metaclass_roles}
			if exists $args->{metaclass_roles};
	}
	else {
		$top_key = 'role_metaroles';

		$args->{role_metaroles}{role} = delete $args->{metaclass_roles}
			if exists $args->{metaclass_roles};
	}

	for my $old_key (@old_keys) {
		my ($new_key) = $old_key =~ /^(.+)_(?:class|metaclass)_roles$/;

		$args->{$top_key}{$new_key} = delete $args->{$old_key}
			if exists $args->{$old_key};
	}

	return;
}


sub apply_base_class_roles {
	my %options = @_;

	my $for = $options{for_class};

	my $meta = Scalar::Random::PP::OO::Util::class_of($for);

	my $new_base = _make_new_class(
		$for,
		$options{roles},
		[ $meta->superclasses() ],
	);

	$meta->superclasses($new_base)
		if $new_base ne $meta->name();
	return;
}

sub _make_new_class {
	my($existing_class, $roles, $superclasses) = @_;

	if(!$superclasses){
		return $existing_class if !$roles;

		my $meta = Scalar::Random::PP::OO::Meta::Class->initialize($existing_class);

		return $existing_class
			if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
	}

	return Scalar::Random::PP::OO::Meta::Class->create_anon_class(
		superclasses => $superclasses ? $superclasses : [$existing_class],
		roles        => $roles,
		cache        => 1,
	)->name();
}

;

package Scalar::Random::PP::OO;

our $VERSION = '0.07';

Scalar::Random::PP::OO::Exporter->setup_import_methods(also => 'Scalar::Random::PP::OO::TOP');

1;