# This file was generated by Mouse::Maker 0.12 from Mouse 0.87.
#
# ANY CHANGES MADE HERE WILL BE LOST!
use strict;
use warnings;
# tell Perl we already have all of the TB2::Mouse files loaded:
BEGIN {
$INC{'TB2/Mouse.pm'} = __FILE__;
$INC{'TB2/Mouse/Role.pm'} = __FILE__;
$INC{'TB2/Mouse/Util.pm'} = __FILE__;
$INC{'TB2/Mouse/Exporter.pm'} = __FILE__;
$INC{'TB2/Mouse/PurePerl.pm'} = __FILE__;
$INC{'TB2/Mouse/Object.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Class.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Method.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/TypeConstraint.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Attribute.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Role.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Module.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Method/Delegation.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Method/Destructor.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Method/Accessor.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Method/Constructor.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Role/Method.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Role/Composite.pm'} = __FILE__;
$INC{'TB2/Mouse/Meta/Role/Application.pm'} = __FILE__;
$INC{'TB2/Mouse/Util/TypeConstraints.pm'} = __FILE__;
$INC{'TB2/Mouse/Util/MetaRole.pm'} = __FILE__;
}
# and now their contents
# Contents of Mouse::PurePerl
package TB2::Mouse::PurePerl;
# The pure Perl backend for Mousse
package TB2::Mouse::Util;
use strict;
use warnings;
use warnings FATAL => 'redefine'; # to avoid to load TB2::Mouse::PurePerl twice
use Scalar::Util ();
use B ();
require TB2::Mouse::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){
TB2::Mouse::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){
TB2::Mouse::Util::install_subroutines(scalar caller, $name => $predicate);
return;
}
return $predicate;
}
package TB2::Mouse::Util::TypeConstraints;
sub Any { 1 }
sub Item { 1 }
sub Bool { !$_[0] || $_[0] eq '1' }
sub Undef { !defined($_[0]) }
sub Defined { defined($_[0]) }
sub Value { defined($_[0]) && !ref($_[0]) }
sub Num { Scalar::Util::looks_like_number($_[0]) }
sub Str {
# We need to use a copy here to flatten MAGICs, for instance as in
# Str( substr($_, 0, 42) ).
my($value) = @_;
return defined($value) && ref(\$value) eq 'SCALAR';
}
sub Int {
# We need to use a copy here to save the original internal SV flags.
my($value) = @_;
return defined($value) && $value =~ /\A -? [0-9]+ \z/xms;
}
sub Ref { ref($_[0]) }
sub ScalarRef {
my($value) = @_;
return ref($value) eq 'SCALAR' || ref($value) eq 'REF';
}
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 {
my($value) = @_;
return Scalar::Util::openhandle($value)
|| (Scalar::Util::blessed($value) && $value->isa("IO::Handle"))
}
sub Object { Scalar::Util::blessed($_[0]) && ref($_[0]) ne 'Regexp' }
sub ClassName { TB2::Mouse::Util::is_class_loaded($_[0]) }
sub RoleName { (TB2::Mouse::Util::class_of($_[0]) || return 0)->isa('TB2::Mouse::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 TB2::Mouse::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.
TB2::Mouse::Util::install_subroutines($self->name,
$name => $code,
);
return;
}
my $generate_class_accessor = sub {
my($name) = @_;
return sub {
my $self = shift;
if(@_) {
return $self->{$name} = shift;
}
foreach my $class($self->linearized_isa) {
my $meta = TB2::Mouse::Util::get_metaclass_by_name($class)
or next;
if(exists $meta->{$name}) {
return $meta->{$name};
}
}
return undef;
};
};
package TB2::Mouse::Meta::Class;
use TB2::Mouse::Meta::Method::Constructor;
use TB2::Mouse::Meta::Method::Destructor;
sub method_metaclass { $_[0]->{method_metaclass} || 'TB2::Mouse::Meta::Method' }
sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'TB2::Mouse::Meta::Attribute' }
sub constructor_class { $_[0]->{constructor_class} || 'TB2::Mouse::Meta::Method::Constructor' }
sub destructor_class { $_[0]->{destructor_class} || 'TB2::Mouse::Meta::Method::Destructor' }
sub is_anon_class{
return exists $_[0]->{anon_serial_id};
}
sub roles { $_[0]->{roles} }
sub linearized_isa { @{ TB2::Mouse::Util::get_linear_isa($_[0]->{package}) } }
sub new_object {
my $meta = shift;
my %args = (@_ == 1 ? %{$_[0]} : @_);
my $object = bless {}, $meta->name;
$meta->_initialize_object($object, \%args, 0);
# BUILDALL
if( $object->can('BUILD') ) {
for my $class (reverse $meta->linearized_isa) {
my $build = TB2::Mouse::Util::get_code_ref($class, 'BUILD')
|| next;
$object->$build(\%args);
}
}
return $object;
}
sub clone_object {
my $class = shift;
my $object = shift;
my $args = $object->TB2::Mouse::Object::BUILDARGS(@_);
(Scalar::Util::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) = @_;
# The initializer, which is used everywhere, must be clear
# when an attribute is added. See TB2::Mouse::Meta::Class::add_attribute.
my $initializer = $self->{_mouse_cache}{_initialize_object} ||=
TB2::Mouse::Util::load_class($self->constructor_class)
->_generate_initialize_object($self);
goto &{$initializer};
}
sub get_all_attributes {
my($self) = @_;
return @{ $self->{_mouse_cache}{all_attributes}
||= $self->_calculate_all_attributes };
}
sub is_immutable { $_[0]->{is_immutable} }
sub strict_constructor;
*strict_constructor = $generate_class_accessor->('strict_constructor');
sub _invalidate_metaclass_cache {
my($self) = @_;
delete $self->{_mouse_cache};
return;
}
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, TB2::Mouse::Util::english_list(@unknowns),
);
}
package TB2::Mouse::Meta::Role;
sub method_metaclass{ $_[0]->{method_metaclass} || 'TB2::Mouse::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} ||= [] }
}
sub add_metaclass_accessor { # for meta roles (a.k.a. traits)
my($meta, $name) = @_;
$meta->add_method($name => $generate_class_accessor->($name));
return;
}
package TB2::Mouse::Meta::Attribute;
require TB2::Mouse::Meta::Method::Accessor;
sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'TB2::Mouse::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 TB2::Mouse 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 TB2::Mouse::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} = TB2::Mouse::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->{does}) };
};
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} = TB2::Mouse::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 a lazy attribute ($name) without specifying a default value for it");
}
return;
}
package TB2::Mouse::Meta::TypeConstraint;
use overload
'""' => '_as_string',
'0+' => '_identity',
'|' => '_unite',
fallback => 1;
sub name { $_[0]->{name} }
sub parent { $_[0]->{parent} }
sub message { $_[0]->{message} }
sub _identity { Scalar::Util::refaddr($_[0]) } # overload 0+
sub type_parameter { $_[0]->{type_parameter} }
sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
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} = \&TB2::Mouse::Util::TypeConstraints::Any;
}
else{
$self->{compiled_type_constraint} = sub{
my(@args) = @_;
for ($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 TB2::Mouse::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;
my $args = $class->BUILDARGS(@_);
return $class->meta->new_object($args);
}
sub DESTROY {
my $self = shift;
return unless $self->can('DEMOLISH'); # short circuit
my $e = do{
local $?;
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 (@{ TB2::Mouse::Util::get_linear_isa(ref $self) }) {
my $demolish = TB2::Mouse::Util::get_code_ref($class, 'DEMOLISH')
|| next;
$self->$demolish($TB2::Mouse::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 = TB2::Mouse::Util::get_code_ref($class, 'BUILD')
|| next;
$self->$build(@_);
}
return;
}
sub DEMOLISHALL;
*DEMOLISHALL = \&DESTROY;
# Contents of Mouse::Exporter
package TB2::Mouse::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 TB2::Mouse::Util depends on TB2::Mouse::Exporter,
# which depends on TB2::Mouse::Util::import()
require TB2::Mouse::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);
TB2::Mouse::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) = TB2::Mouse::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 TB2::Mouse::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 {
TB2::Mouse::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($_)
? $_
: TB2::Mouse::Util::resolve_metaclass_alias($type => $_, trait => 1)
} @traits;
require TB2::Mouse::Util::MetaRole;
TB2::Mouse::Util::MetaRole::apply_metaroles(
for => $into,
TB2::Mouse::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"})
);
}
TB2::Mouse::Util::install_subroutines($into, @export_table);
}
else{
TB2::Mouse::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 TB2::Mouse::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 TB2::Mouse::Util;
use TB2::Mouse::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 TB2::Mouse::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 TB2::Mouse::PurePerl
TB2::Mouse::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 throw_error dump
)],
groups => {
default => [], # export no functions by default
# The ':meta' group is 'use metaclass' for Mousse
meta => [qw(does meta dump throw_error)],
},
);
our $VERSION = '1.005000_005';
my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});
# Because TB2::Mouse::Util is loaded first in all the TB2::Mouse sub-modules,
# XSLoader must be placed here, not in TB2/Mouse.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//; # .../TB2/Mouse/Util.pm -> .../TB2/Mouse.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('TB2::Mouse', $VERSION);
TB2::Mouse::Util->import({ into => 'TB2::Mouse::Meta::Method::Constructor::XS' }, ':meta');
TB2::Mouse::Util->import({ into => 'TB2::Mouse::Meta::Method::Destructor::XS' }, ':meta');
TB2::Mouse::Util->import({ into => 'TB2::Mouse::Meta::Method::Accessor::XS' }, ':meta');
return 1;
} || 0;
warn $@ if $@ && $ENV{MOUSE_XS};
}
if(!$xs){
require 'TB2/Mouse/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 TB2::Mouse::Meta::Module depends on TB2::Mouse::Util
require TB2::Mouse::Meta::Module; # for the entities of metaclass cache utilities
# aliases
{
*class_of = \&TB2::Mouse::Meta::Module::_class_of;
*get_metaclass_by_name = \&TB2::Mouse::Meta::Module::_get_metaclass_by_name;
*get_all_metaclass_instances = \&TB2::Mouse::Meta::Module::_get_all_metaclass_instances;
*get_all_metaclass_names = \&TB2::Mouse::Meta::Module::_get_all_metaclass_names;
*TB2::Mouse::load_class = \&load_class;
*TB2::Mouse::is_class_loaded = \&is_class_loaded;
# is-a predicates
#generate_isa_predicate_for('TB2::Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
#generate_isa_predicate_for('TB2::Mouse::Meta::Class' => 'is_a_metaclass');
#generate_isa_predicate_for('TB2::Mouse::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 || 'TB2::Mouse::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 TB2::Mouse::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 '::',
'TB2::Mouse::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])
? $_[0] # instance
: TB2::Mouse::Meta::Class->initialize($_[0]); # class or role name
my @roles;
# Basis of Data::OptList
my $max = scalar(@_);
for (my $i = 1; $i < $max ; $i++) {
my $role = $_[$i];
my $role_name;
if(ref $role) {
$role_name = $role->name;
}
else {
$role_name = $role;
load_class($role_name);
$role = get_metaclass_by_name($role_name);
}
if ($i + 1 < $max && ref($_[$i + 1]) eq 'HASH') {
push @roles, [ $role => $_[++$i] ];
} else {
push @roles, [ $role => undef ];
}
is_a_metarole($role)
|| $consumer->meta->throw_error("You can only consume roles, $role_name is not a TB2::Mouse role");
}
if ( scalar @roles == 1 ) {
my ( $role, $params ) = @{ $roles[0] };
$role->apply( $consumer, defined $params ? $params : () );
}
else {
TB2::Mouse::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("TB2::Mouse does not currently support $feature");
}
# general meta() method
sub meta :method{
return TB2::Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
}
# general throw_error() method
# $o->throw_error($msg, depth => $leve, longmess => $croak_or_confess)
sub throw_error :method {
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}) {
Carp::croak($message);
}
else{
Carp::confess($message);
}
}
# 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);
$dd->Sortkeys(1);
$dd->Quotekeys(0);
return $dd->Dump();
}
# general does() method
sub does :method {
goto &does_role;
}
# Contents of Mouse::Meta::TypeConstraint
package TB2::Mouse::Meta::TypeConstraint;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
sub new {
my $class = shift;
my %args = @_ == 1 ? %{$_[0]} : @_;
$args{name} = '__ANON__' if !defined $args{name};
my $type_parameter;
if(defined $args{parent}) { # subtyping
%args = (%{$args{parent}}, %args);
# a child type must not inherit 'compiled_type_constraint'
# and 'hand_optimized_type_constraint' from the parent
delete $args{compiled_type_constraint}; # don't inherit it
delete $args{hand_optimized_type_constraint}; # don't inherit it
$type_parameter = $args{type_parameter};
if(defined(my $parent_tp = $args{parent}{type_parameter})) {
if($parent_tp != $type_parameter) {
$type_parameter->is_a_type_of($parent_tp)
or $class->throw_error(
"$type_parameter is not a subtype of $parent_tp",
);
}
else {
$type_parameter = undef;
}
}
}
my $check;
if($check = delete $args{optimized}) { # likely to be builtins
$args{hand_optimized_type_constraint} = $check;
$args{compiled_type_constraint} = $check;
}
elsif(defined $type_parameter) { # parameterizing
my $generator = $args{constraint_generator}
|| $class->throw_error(
"The $args{name} constraint cannot be used,"
. " because $type_parameter doesn't subtype"
. " from a parameterizable type");
my $parameterized_check = $generator->($type_parameter);
if(defined(my $my_check = $args{constraint})) {
$check = sub {
return $parameterized_check->($_) && $my_check->($_);
};
}
else {
$check = $parameterized_check;
}
$args{constraint} = $check;
}
else { # common cases
$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 !$args{hand_optimized_type_constraint};
if($args{type_constraints}) { # union types
foreach my $type(@{$self->{type_constraints}}){
if($type->has_coercion){
# set undef for has_coercion()
$self->{_compiled_type_coercion} = undef;
last;
}
}
}
return $self;
}
sub create_child_type {
my $self = shift;
return ref($self)->new(@_, 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 { # ($self, @pairs)
my $self = shift;
if(exists $self->{type_constraints}){ # union type
$self->throw_error(
"Cannot add additional type coercions to Union types '$self'");
}
my $coercion_map = ($self->{coercion_map} ||= []);
my %has = map{ $_->[0]->name => undef } @{$coercion_map};
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 = TB2::Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
or $self->throw_error(
"Could not find the type constraint ($from) to coerce from");
push @{$coercion_map}, [ $type => $action ];
}
$self->{_compiled_type_coercion} = undef;
return;
}
sub _compiled_type_coercion {
my($self) = @_;
my $coercion = $self->{_compiled_type_coercion};
return $coercion if defined $coercion;
if(!$self->{type_constraints}) {
my @coercions;
foreach my $pair(@{$self->{coercion_map}}) {
push @coercions,
[ $pair->[0]->_compiled_type_constraint, $pair->[1] ];
}
$coercion = sub {
my($thing) = @_;
foreach my $pair (@coercions) {
#my ($constraint, $converter) = @$pair;
if ($pair->[0]->($thing)) {
return $pair->[1]->($thing) for $thing;
}
}
return $thing;
};
}
else { # for union type
my @coercions;
foreach my $type(@{$self->{type_constraints}}){
if($type->has_coercion){
push @coercions, $type;
}
}
if(@coercions){
$coercion = sub {
my($thing) = @_;
foreach my $type(@coercions){
my $value = $type->coerce($thing);
return $value if $self->check($value);
}
return $thing;
};
}
}
return( $self->{_compiled_type_coercion} = $coercion );
}
sub coerce {
my $self = shift;
return $_[0] if $self->check(@_);
my $coercion = $self->_compiled_type_coercion
or $self->throw_error("Cannot coerce without a type coercion");
return $coercion->(@_);
}
sub get_message {
my ($self, $value) = @_;
if ( my $msg = $self->message ) {
return $msg->($value) for $value;
}
else {
if(not defined $value) {
$value = 'undef';
}
elsif( ref($value) && defined(&overload::StrVal) ) {
$value = overload::StrVal($value);
}
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 $p = $self->parent; defined $p; $p = $p->parent) {
return 1 if $p->name eq $other_name;
}
return 0;
}
# See also Moose::Meta::TypeConstraint::Parameterizable
sub parameterize {
my($self, $param, $name) = @_;
if(!ref $param){
require TB2::Mouse::Util::TypeConstraints;
$param = TB2::Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($param);
}
$name ||= sprintf '%s[%s]', $self->name, $param->name;
return TB2::Mouse::Meta::TypeConstraint->new(
name => $name,
parent => $self,
type_parameter => $param,
);
}
sub assert_valid {
my ($self, $value) = @_;
if(!$self->check($value)){
$self->throw_error($self->get_message($value));
}
return 1;
}
# overloading stuff
sub _as_string { $_[0]->name } # overload ""
sub _identity; # overload 0+
sub _unite { # overload infix:<|>
my($lhs, $rhs) = @_;
require TB2::Mouse::Util::TypeConstraints;
return TB2::Mouse::Util::TypeConstraints::_find_or_create_union_type(
$lhs,
TB2::Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($rhs),
);
}
# Contents of Mouse::Util::TypeConstraints
package TB2::Mouse::Util::TypeConstraints;
use TB2::Mouse::Util; # enables strict and warnings
use TB2::Mouse::Meta::TypeConstraint;
use TB2::Mouse::Exporter;
use Carp ();
use Scalar::Util ();
TB2::Mouse::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(TB2::Mouse::Meta::Attribute);
my %TYPE;
# The root type
$TYPE{Any} = TB2::Mouse::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} = TB2::Mouse::Meta::TypeConstraint->new(
name => $name,
parent => $TYPE{$parent},
optimized => $code,
);
}
# parametarizable types
$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 _define_type {
my $is_subtype = 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 = delete $args{as};
if($is_subtype && !$parent){
$parent = delete $args{name};
$name = undef;
}
if(defined $parent) {
$args{parent} = find_or_create_isa_type_constraint($parent);
}
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 TB2::Mouse \b/xms){
$args{package_defined_in} = $this;
}
}
if(defined $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);
}
}
}
$args{constraint} = delete $args{where} if exists $args{where};
$args{optimized} = delete $args{optimized_as} if exists $args{optimized_as};
my $constraint = TB2::Mouse::Meta::TypeConstraint->new(%args);
if(defined $name){
return $TYPE{$name} = $constraint;
}
else{
return $constraint;
}
}
sub type {
return _define_type 0, @_;
}
sub subtype {
return _define_type 1, @_;
}
sub coerce { # coerce $type, from $from, via { ... }, ...
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 subtype $name => (
as => 'Object',
optimized_as => TB2::Mouse::Util::generate_isa_predicate_for($class),
class => $class,
);
}
sub role_type {
my($name, $options) = @_;
my $role = $options->{role} || $name;
# RoleType
return subtype $name => (
as => 'Object',
optimized_as => sub {
return Scalar::Util::blessed($_[0])
&& TB2::Mouse::Util::does_role($_[0], $role);
},
role => $role,
);
}
sub duck_type {
my($name, @methods);
if(ref($_[0]) ne 'ARRAY'){
$name = shift;
}
@methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
# DuckType
return _define_type 1, $name => (
as => 'Object',
optimized_as => TB2::Mouse::Util::generate_can_predicate_for(\@methods),
message => sub {
my($object) = @_;
my @missing = grep { !$object->can($_) } @methods;
return ref($object)
. ' is missing methods '
. TB2::Mouse::Util::quoted_english_list(@missing);
},
methods => \@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 _define_type 1, $name => (
as => 'Str',
optimized_as => sub{
return 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 = TB2::Mouse::Util::get_metaclass_by_name($spec);
if(!defined $meta){
return $create ? class_type($spec) : undef;
}
if(TB2::Mouse::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 } @_; # all things must be defined
my @types = sort
map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
my $name = join '|', @types;
# UnionType
$TYPE{$name} ||= TB2::Mouse::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 TB2::Mouse::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 TB2::Mouse::Util::is_a_type_constraint($constraint);
return $TYPE{$constraint->name} = $constraint;
}
sub find_or_parse_type_constraint {
my($spec) = @_;
return $spec if TB2::Mouse::Util::is_a_type_constraint($spec) or not defined $spec;
$spec =~ tr/ \t\r\n//d;
my $tc = $TYPE{$spec};
if(defined $tc) {
return $tc;
}
my %context = (
spec => $spec,
orig => $spec,
);
$tc = _parse_type(\%context);
if($context{spec}){
Carp::croak("Syntax error: extra elements '$context{spec}' in '$context{orig}'");
}
return $TYPE{$spec} = $tc;
}
sub find_or_create_does_type_constraint{
# XXX: Moose does not register a new role_type, but TB2::Mouse does.
my $tc = find_or_parse_type_constraint(@_);
return defined($tc) ? $tc : role_type(@_);
}
sub find_or_create_isa_type_constraint {
# XXX: Moose does not register a new class_type, but TB2::Mouse does.
my $tc = find_or_parse_type_constraint(@_);
return defined($tc) ? $tc : class_type(@_);
}
# Contents of Mouse
package TB2::Mouse::TOP;
use 5.006_002;
use TB2::Mouse::Exporter; # enables strict and warnings
our $VERSION = '0.87';
use Carp qw(confess);
use Scalar::Util qw(blessed);
use TB2::Mouse::Util ();
use TB2::Mouse::Meta::Module;
use TB2::Mouse::Meta::Class;
use TB2::Mouse::Meta::Role;
use TB2::Mouse::Meta::Attribute;
use TB2::Mouse::Object;
use TB2::Mouse::Util::TypeConstraints ();
TB2::Mouse::Exporter->setup_import_methods(
as_is => [qw(
extends with
has
before after around
override super
augment inner
),
\&Scalar::Util::blessed,
\&Carp::confess,
],
);
sub extends {
TB2::Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_);
return;
}
sub with {
TB2::Mouse::Util::apply_all_roles(scalar(caller), @_);
return;
}
sub has {
my $meta = TB2::Mouse::Meta::Class->initialize(scalar caller);
my $name = shift;
$meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
if @_ % 2; # odd number of arguments
for my $n(ref($name) ? @{$name} : $name){
$meta->add_attribute($n => @_);
}
return;
}
sub before {
my $meta = TB2::Mouse::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 = TB2::Mouse::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 = TB2::Mouse::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) = @_;
TB2::Mouse::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) = @_;
TB2::Mouse::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} || 'TB2::Mouse::Object';
my $metaclass = $args{metaclass} || 'TB2::Mouse::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 TB2::Mouse class
TB2::Mouse::Util::TypeConstraints::class_type($class)
unless TB2::Mouse::Util::TypeConstraints::find_type_constraint($class);
return $meta;
}
# Contents of Mouse::Meta::Attribute
package TB2::Mouse::Meta::Attribute;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
use Carp ();
use TB2::Mouse::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',
'__METACLASS__',
# Moose defines, but TB2::Mouse doesn't
#'definition_context',
#'initializer',
# special case for AttributeHelpers
'provides',
'curries',
);
our @CARP_NOT = qw(TB2::Mouse::Meta::Class);
sub new {
my $class = shift;
my $name = shift;
my $args = $class->TB2::Mouse::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': "
. TB2::Mouse::Util::english_list(@bad));
}
my $self = bless $args, $class;
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 get_read_method { $_[0]->reader || $_[0]->accessor }
sub get_write_method { $_[0]->writer || $_[0]->accessor }
sub get_read_method_ref{
my($self) = @_;
return $self->{_mouse_cache_read_method_ref}
||= $self->_get_accessor_method_ref('get_read_method', '_generate_reader');
}
sub get_write_method_ref{
my($self) = @_;
return $self->{_mouse_cache_write_method_ref}
||= $self->_get_accessor_method_ref('get_write_method', '_generate_writer');
}
sub interpolate_class{
my($class, $args) = @_;
if(my $metaclass = delete $args->{metaclass}){
$class = TB2::Mouse::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 = TB2::Mouse::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 = TB2::Mouse::Meta::Class->create_anon_class(
superclasses => [ $class ],
roles => \@traits,
cache => 1,
)->name;
}
}
return( $class, @traits );
}
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->TB2::Mouse::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 _mouse_cache_/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_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 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->{_mouse_cache_predicate_ref}
||= $self->_get_accessor_method_ref('predicate', '_generate_predicate');
return $accessor_ref->($object);
}
sub clear_value {
my($self, $object) = @_;
my $accessor_ref = $self->{_mouse_cache_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();
while(my($handle, $method_to_call) = each %handles){
next if TB2::Mouse::Object->can($handle);
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
'TB2::Mouse::Meta::Method::Delegation'
}
sub _canonicalize_handles {
my($self) = @_;
my $handles = $self->{handles};
my $handle_type = ref $handles;
if ($handle_type eq 'HASH') {
return %$handles;
}
elsif ($handle_type eq 'ARRAY') {
return map { $_ => $_ } @$handles;
}
elsif ($handle_type eq 'Regexp') {
my $meta = $self->_find_delegate_metaclass();
return map { $_ => $_ }
grep { /$handles/ }
TB2::Mouse::Util::is_a_metarole($meta)
? $meta->get_method_list
: $meta->get_all_method_names;
}
elsif ($handle_type eq 'CODE') {
return $handles->( $self, $self->_find_delegate_metaclass() );
}
else {
$self->throw_error("Unable to canonicalize the 'handles' option with $handles");
}
}
sub _find_delegate_metaclass {
my($self) = @_;
my $meta;
if($self->{isa}) {
$meta = TB2::Mouse::Meta::Class->initialize("$self->{isa}");
}
elsif($self->{does}) {
$meta = TB2::Mouse::Util::get_metaclass_by_name("$self->{does}");
}
defined($meta) or $self->throw_error(
"Cannot find delegate metaclass for attribute " . $self->name);
return $meta;
}
sub _make_delegation_method {
my($self, $handle, $method_to_call) = @_;
return TB2::Mouse::Util::load_class($self->delegation_metaclass)
->_generate_delegation($self, $handle, $method_to_call);
}
# Contents of Mouse::Meta::Class
package TB2::Mouse::Meta::Class;
use TB2::Mouse::Util qw/:meta/; # enables strict and warnings
no warnings 'once';
use Scalar::Util ();
use TB2::Mouse::Meta::Module;
our @ISA = qw(TB2::Mouse::Meta::Module);
our @CARP_NOT = qw(TB2::Mouse); # 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(@_){
TB2::Mouse::Util::load_class($super);
my $meta = TB2::Mouse::Util::get_metaclass_by_name($super);
next if $self->verify_superclass($super, $meta);
$self->_reconcile_with_superclass_meta($meta);
}
return @{ $self->{superclasses} } = @_;
}
return @{ $self->{superclasses} };
}
sub verify_superclass {
my($self, $super, $super_meta) = @_;
if(defined $super_meta) {
if(TB2::Mouse::Util::is_a_metarole($super_meta)){
$self->throw_error("You cannot inherit from a TB2::Mouse Role ($super)");
}
}
else {
# The metaclass of $super is not initialized.
# i.e. it might be TB2::Mouse::Object, a mixin package (e.g. Exporter),
# or a foreign class including Moose classes.
# See also TB2::Mouse::Foreign::Meta::Role::Class.
my $mm = $super->can('meta');
if(!($mm && $mm == \&TB2::Mouse::Util::meta)) {
if($super->can('new') or $super->can('DESTROY')) {
$self->inherit_from_foreign_class($super);
}
}
return 1; # always ok
}
return $self->isa(ref $super_meta); # checks metaclass compatibility
}
sub inherit_from_foreign_class {
my($class, $super) = @_;
Carp::carp("You inherit from non-TB2::Mouse class ($super),"
. " but it is unlikely to work correctly."
. " Please consider using TB2::MouseX::Foreign");
return;
}
my @MetaClassTypes = (
'attribute', # TB2::Mouse::Meta::Attribute
'method', # TB2::Mouse::Meta::Method
'constructor', # TB2::Mouse::Meta::Method::Constructor
'destructor', # TB2::Mouse::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 TB2::Mouse::Util::MetaRole;
$_[0] = TB2::Mouse::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 { TB2::Mouse::Meta::Class->initialize($_)->get_method_list() }
$self->linearized_isa;
}
sub find_attribute_by_name {
my($self, $name) = @_;
defined($name)
or $self->throw_error('You must define an attribute name to find');
foreach my $attr($self->get_all_attributes) {
return $attr if $attr->name eq $name;
}
return undef;
}
sub add_attribute {
my $self = shift;
my($attr, $name);
if(Scalar::Util::blessed($_[0])){
$attr = $_[0];
$attr->isa('TB2::Mouse::Meta::Attribute')
|| $self->throw_error("Your attribute must be an instance of TB2::Mouse::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);
}
}
Scalar::Util::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}{$name} = $attr;
$self->_invalidate_metaclass_cache();
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 _calculate_all_attributes {
my($self) = @_;
my %seen;
my @all_attrs;
foreach my $class($self->linearized_isa) {
my $meta = TB2::Mouse::Util::get_metaclass_by_name($class) or next;
my @attrs = grep { !$seen{$_->name}++ } values %{$meta->{attributes}};
@attrs = sort {
$b->{insertion_order} <=> $a->{insertion_order}
} @attrs;
push @all_attrs, @attrs;
}
return [reverse @all_attrs];
}
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} =>
TB2::Mouse::Util::load_class($self->constructor_class)
->_generate_constructor($self, \%args));
}
if ($args{inline_destructor}) {
$self->add_method(DESTROY =>
TB2::Mouse::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 $TB2::Mouse::TOP::SUPER_PACKAGE = $package;
local $TB2::Mouse::TOP::SUPER_BODY = $super_body;
local @TB2::Mouse::TOP::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 $TB2::Mouse::TOP::INNER_BODY{$super_package} = $code;
local $TB2::Mouse::TOP::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 = TB2::Mouse::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 TB2::Mouse::Meta::Method;
use TB2::Mouse::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;
unshift @_, 'body' if @_ % 2 != 0;
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 TB2::Mouse::Meta::Method::Accessor;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0;
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 of $name") 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";
warn $accessor if _MOUSE_DEBUG;
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 TB2::Mouse::Meta::Method::Constructor;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0;
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 $buildall = $class->_generate_BUILDALL($metaclass);
my $buildargs = $class->_generate_BUILDARGS($metaclass);
my $initializer = $metaclass->{_mouse_cache}{_initialize_object} ||=
$class->_generate_initialize_object($metaclass);
my $source = sprintf(<<'EOT', __FILE__, $metaclass->name, $buildargs, $buildall);
#line 1 "%s"
package %s;
sub {
my $class = shift;
return $class->TB2::Mouse::Object::new(@_)
if $class ne __PACKAGE__;
# BUILDARGS
%s;
my $instance = bless {}, $class;
$metaclass->$initializer($instance, $args, 0);
# BUILDALL
%s;
return $instance;
}
EOT
warn $source if _MOUSE_DEBUG;
my $body;
my $e = do{
local $@;
$body = eval $source;
$@;
};
die $e if $e;
return $body;
}
sub _generate_initialize_object {
my ($method_class, $metaclass) = @_;
my @attrs = $metaclass->get_all_attributes;
my @checks = map { $_ && $_->_compiled_type_constraint }
map { $_->type_constraint } @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)\n";
$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";
}
# build cde for an attribute
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";
$code .= $post_process;
}
}
elsif ($attr->is_required) {
$code .= "\$meta->throw_error('Attribute ($key) is required')";
$code .= " unless \$is_cloning;\n";
}
$code .= "}\n" if defined $init_arg;
push @res, $code;
}
if($strict){
push @res, q{if($used < keys %{$args})}
. q{{ $meta->_report_unknown_args(\@attrs, $args) }};
}
if($metaclass->is_anon_class){
push @res, q{$instance->{__METACLASS__} = $meta;};
}
if($has_triggers){
unshift @res, q{my @triggers;};
push @res, q{$_->[0]->($instance, $_->[1]) for @triggers;};
}
my $source = sprintf <<'EOT', __FILE__, $metaclass->name, join "\n", @res;
#line 1 "%s"
package %s;
sub {
my($meta, $instance, $args, $is_cloning) = @_;
%s;
return $instance;
}
EOT
warn $source if _MOUSE_DEBUG;
my $body;
my $e = do {
local $@;
$body = eval $source;
$@;
};
die $e if $e;
return $body;
}
sub _generate_BUILDARGS {
my(undef, $metaclass) = @_;
my $class = $metaclass->name;
if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&TB2::Mouse::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 (TB2::Mouse::Util::get_code_ref($class, 'BUILD')) {
unshift @code, qq{${class}::BUILD(\$instance, \$args);};
}
}
return join "\n", @code;
}
# Contents of Mouse::Meta::Method::Delegation
package TB2::Mouse::Meta::Method::Delegation;
use TB2::Mouse::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->{_mouse_cache_method_delegation_can_be_optimized};
if(!defined $can_be_optimized){
my $tc = $attr->type_constraint;
$attr->{_mouse_cache_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 TB2::Mouse::Meta::Method::Destructor;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
use constant _MOUSE_DEBUG => $ENV{MOUSE_DEBUG} ? 1 : 0;
sub _generate_destructor{
my (undef, $metaclass) = @_;
my $demolishall = '';
for my $class ($metaclass->linearized_isa) {
if (TB2::Mouse::Util::get_code_ref($class, 'DEMOLISH')) {
$demolishall .= ' ' . $class
. '::DEMOLISH($self, $TB2::Mouse::Util::in_global_destruction);'
. "\n",
}
}
if($demolishall) {
$demolishall = sprintf <<'EOT', $demolishall;
my $e = do{
local $?;
local $@;
eval{
%s;
};
$@;
};
no warnings 'misc';
die $e if $e; # rethrow
EOT
}
my $name = $metaclass->name;
my $source = sprintf(<<'EOT', __FILE__, $name, $demolishall);
#line 1 "%s"
package %s;
sub {
my($self) = @_;
return $self->TB2::Mouse::Object::DESTROY()
if ref($self) ne __PACKAGE__;
# DEMOLISHALL
%s;
return;
}
EOT
warn $source if _MOUSE_DEBUG;
my $code;
my $e = do{
local $@;
$code = eval $source;
$@;
};
die $e if $e;
return $code;
}
# Contents of Mouse::Meta::Module
package TB2::Mouse::Meta::Module;
use TB2::Mouse::Util qw/:meta/; # enables strict and warnings
no warnings 'once';
use Carp ();
use Scalar::Util ();
my %METAS;
if(TB2::Mouse::Util::MOUSE_XS){
# register meta storage for performance
TB2::Mouse::Util::__register_metaclass_storage(\%METAS, 0);
# ensure thread safety
*CLONE = sub { TB2::Mouse::Util::__register_metaclass_storage(\%METAS, 1) };
}
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");
if(exists $METAS{$package_name}) {
unshift @args, %{ $METAS{$package_name} };
}
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.
# The public versions are aliased into TB2::Mouse::Util::*.
#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: not completely compatible with Moose
my %foreign = map{ $_ => undef } qw(
TB2::Mouse TB2::Mouse::Role TB2::Mouse::Util TB2::Mouse::Util::TypeConstraints
Carp Scalar::Util List::Util
);
sub _get_method_body {
my($self, $method_name) = @_;
my $code = TB2::Mouse::Util::get_code_ref($self->{package}, $method_name);
return $code && !exists $foreign{ TB2::Mouse::Util::get_code_package($code) }
? $code
: undef;
}
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} )
|| defined( $self->_get_method_body($method_name) );
}
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}
||= $self->_get_method_body($method_name);
}
sub get_method {
my($self, $method_name) = @_;
if(my $code = $self->get_method_body($method_name)){
return TB2::Mouse::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 { # TB2::Mouse specific, used for method modifiers
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(TB2::Mouse::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 TB2::Mouse::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 and !$options{in_application_to_instance}){
TB2::Mouse::Util::apply_all_roles($package_name, @{$roles});
}
if($cache_key){
$IMMORTALS{$cache_key} = $meta;
}
return $meta;
}
sub DESTROY{
my($self) = @_;
return if $TB2::Mouse::Util::in_global_destruction;
my $serial_id = $self->{anon_serial_id};
return if !$serial_id;
# XXX: cleaning stash with threads causes panic/SEGV on legacy perls.
if(exists $INC{'threads.pm'}) {
# (caller)[2] indicates the caller's line number,
# which is zero when the current thread is joining (destroying).
return if( (caller)[2] == 0);
}
# clean up mortal anonymous class stuff
# @ISA is a magical variable, so we must 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;
}
# Contents of Mouse::Meta::Role
package TB2::Mouse::Meta::Role;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
use TB2::Mouse::Meta::Module;
our @ISA = qw(TB2::Mouse::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 apply {
my $self = shift;
my $consumer = shift;
require 'TB2/Mouse/Meta/Role/Application.pm';
return TB2::Mouse::Meta::Role::Application->new(@_)->apply($self, $consumer);
}
sub combine {
my($self, @role_specs) = @_;
require 'TB2/Mouse/Meta/Role/Composite.pm';
return TB2::Mouse::Meta::Role::Composite->new(roles => \@role_specs);
}
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::Application
package TB2::Mouse::Meta::Role::Application;
use TB2::Mouse::Util qw(:meta);
sub new {
my $class = shift;
my $args = $class->TB2::Mouse::Object::BUILDARGS(@_);
if(exists $args->{exclude} or exists $args->{alias}) {
warnings::warnif(deprecated =>
'The alias and excludes options for role application have been'
. ' renamed -alias and -exclude');
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;
}
}
my $self = bless $args, $class;
if($class ne __PACKAGE__){
$self->meta->_initialize_object($self, $args);
}
return $self;
}
sub apply {
my($self, $role, $consumer, @extra) = @_;
my $instance;
if(TB2::Mouse::Util::is_a_metaclass($consumer)) { # Application::ToClass
$self->{_to} = 'class';
}
elsif(TB2::Mouse::Util::is_a_metarole($consumer)) { # Application::ToRole
$self->{_to} = 'role';
}
else { # Appplication::ToInstance
$self->{_to} = 'instance';
$instance = $consumer;
$consumer = (TB2::Mouse::Util::class_of($instance) || 'TB2::Mouse::Meta::Class')
->create_anon_class(
superclasses => [ref $instance],
roles => [$role],
cache => 1,
in_application_to_instance => 1, # suppress to apply roles
);
}
#$self->check_role_exclusions($role, $consumer, @extra);
$self->check_required_methods($role, $consumer, @extra);
#$self->check_required_attributes($role, $consumer, @extra);
$self->apply_attributes($role, $consumer, @extra);
$self->apply_methods($role, $consumer, @extra);
#$self->apply_override_method_modifiers($role, $consumer, @extra);
#$self->apply_before_method_modifiers($role, $consumer, @extra);
#$self->apply_around_method_modifiers($role, $consumer, @extra);
#$self->apply_after_method_modifiers($role, $consumer, @extra);
$self->apply_modifiers($role, $consumer, @extra);
$self->_append_roles($role, $consumer);
if(defined $instance){ # Application::ToInstance
# rebless instance
bless $instance, $consumer->name;
$consumer->_initialize_object($instance, $instance, 1);
}
return;
}
sub check_required_methods {
my($self, $role, $consumer) = @_;
if($self->{_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 $self->{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
TB2::Mouse::Util::quoted_english_list(@missing),
$consumer_class_name);
}
}
return;
}
sub apply_methods {
my($self, $role, $consumer) = @_;
my $alias = $self->{-alias};
my $excludes = $self->{-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($self, $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($self, $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 }) {
# skip if the modifier is already applied
next if $consumer->{"_applied_$modifier_type"}{$method_name, $code}++;
$consumer->$add_modifier($method_name => $code);
}
}
}
return;
}
sub _append_roles {
my($self, $role, $metaclass_or_role) = @_;
my $roles = $metaclass_or_role->{roles};
foreach my $r($role, @{$role->get_roles}){
if(!$metaclass_or_role->does_role($r)){
push @{$roles}, $r;
}
}
return;
}
# Contents of Mouse::Meta::Role::Composite
package TB2::Mouse::Meta::Role::Composite;
use TB2::Mouse::Util; # enables strict and warnings
use TB2::Mouse::Meta::Role;
use TB2::Mouse::Meta::Role::Application;
our @ISA = qw(TB2::Mouse::Meta::Role);
# FIXME: TB2::Mouse::Meta::Role::Composite does things in different way from Moose's
# Moose: creates a new class for the consumer, and applies roles to it.
# TB2::Mouse: creates a coposite role and apply roles to the role,
# and then applies it to the consumer.
sub new {
my $class = shift;
my $args = $class->TB2::Mouse::Object::BUILDARGS(@_);
my $roles = delete $args->{roles};
my $self = $class->create_anon_role(%{$args});
foreach my $role_spec(@{$roles}) {
my($role, $args) = ref($role_spec) eq 'ARRAY'
? @{$role_spec}
: ($role_spec, {});
$role->apply($self, %{$args});
}
return $self;
}
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;
}
sub apply {
my $self = shift;
my $consumer = shift;
TB2::Mouse::Meta::Role::Application::RoleSummation->new(@_)->apply($self, $consumer);
return;
}
package TB2::Mouse::Meta::Role::Application::RoleSummation;
our @ISA = qw(TB2::Mouse::Meta::Role::Application);
sub apply_methods {
my($self, $role, $consumer, @extra) = @_;
if(exists $role->{conflicting_methods}){
my $consumer_class_name = $consumer->name;
my @conflicting = grep{ !$consumer_class_name->can($_) }
keys %{ $role->{conflicting_methods} };
if(@conflicting) {
my $method_name_conflict = (@conflicting == 1
? 'a method name conflict'
: 'method name conflicts');
my %seen;
my $roles = TB2::Mouse::Util::quoted_english_list(
grep{ !$seen{$_}++ } # uniq
map { $_->name }
map { @{$_} }
@{ $role->{composed_roles_by_method} }{@conflicting}
);
$self->throw_error(sprintf
q{Due to %s in roles %s,}
. q{ the method%s %s must be implemented or excluded by '%s'},
$method_name_conflict,
$roles,
(@conflicting > 1 ? 's' : ''),
TB2::Mouse::Util::quoted_english_list(@conflicting),
$consumer_class_name);
}
}
$self->SUPER::apply_methods($role, $consumer, @extra);
return;
}
package TB2::Mouse::Meta::Role::Composite;
# Contents of Mouse::Meta::Role::Method
package TB2::Mouse::Meta::Role::Method;
use TB2::Mouse::Util; # enables strict and warnings
use TB2::Mouse::Meta::Method;
our @ISA = qw(TB2::Mouse::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 TB2::Mouse::Object;
use TB2::Mouse::Util qw(does dump meta); # enables strict and warnings
# all the stuff are defined in XS or PP
# Contents of Mouse::Role
package TB2::Mouse::Role;
use TB2::Mouse::Exporter; # enables strict and warnings
our $VERSION = '0.87';
use Carp qw(confess);
use Scalar::Util qw(blessed);
use TB2::Mouse ();
TB2::Mouse::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 {
TB2::Mouse::Util::apply_all_roles(scalar(caller), @_);
return;
}
sub has {
my $meta = TB2::Mouse::Meta::Role->initialize(scalar caller);
my $name = shift;
$meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})
if @_ % 2; # odd number of arguments
for my $n(ref($name) ? @{$name} : $name){
$meta->add_attribute($n => @_);
}
return;
}
sub before {
my $meta = TB2::Mouse::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 = TB2::Mouse::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 = TB2::Mouse::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 $TB2::Mouse::TOP::SUPER_BODY;
$TB2::Mouse::TOP::SUPER_BODY->(@TB2::Mouse::TOP::SUPER_ARGS);
}
sub override {
# my($name, $code) = @_;
TB2::Mouse::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 = TB2::Mouse::Meta::Role->initialize(scalar caller);
$meta->throw_error("Must specify at least one method") unless @_;
$meta->add_required_methods(@_);
return;
}
sub excludes {
TB2::Mouse::Util::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} || 'TB2::Mouse::Meta::Role';
my $meta = $metaclass->initialize($class);
$meta->add_method(meta => sub{
$metaclass->initialize(ref($_[0]) || $_[0]);
});
# make a role type for each TB2::Mouse role
TB2::Mouse::Util::TypeConstraints::role_type($class)
unless TB2::Mouse::Util::TypeConstraints::find_type_constraint($class);
return $meta;
}
# Contents of Mouse::Util::MetaRole
package TB2::Mouse::Util::MetaRole;
use TB2::Mouse::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}
: TB2::Mouse::Util::get_metaclass_by_name( $args{for} );
if(!$for){
Carp::confess("You must pass an initialized class, but '$args{for}' has no metaclass");
}
if ( TB2::Mouse::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}
: TB2::Mouse::Util::get_metaclass_by_name( $args->{for} );
my $top_key;
if( TB2::Mouse::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 = TB2::Mouse::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 = TB2::Mouse::Meta::Class->initialize($existing_class);
return $existing_class
if !grep { !ref($_) && !$meta->does_role($_) } @{$roles};
}
return TB2::Mouse::Meta::Class->create_anon_class(
superclasses => $superclasses ? $superclasses : [$existing_class],
roles => $roles,
cache => 1,
)->name();
}
;
package TB2::Mouse;
our $VERSION = '0.12';
TB2::Mouse::Exporter->setup_import_methods(also => 'TB2::Mouse::TOP');
1;