view release on metacpan or  search on metacpan

lib/Mousse.pm  view on Meta::CPAN

		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 (@{ Mousse::Util::get_linear_isa(ref $self) }) {
				my $demolish = Mousse::Util::get_code_ref($class, 'DEMOLISH')
					|| next;

				$self->$demolish($Mousse::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 = Mousse::Util::get_code_ref($class, 'BUILD')
			|| next;

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

sub DEMOLISHALL;
*DEMOLISHALL = \&DESTROY;

# Contents of Mouse::Exporter
package Mousse::Exporter;
use strict;
use warnings;
use Carp ();

my %SPEC;

my $strict_bits;
my $warnings_extra_bits;
BEGIN{
	$strict_bits         = strict::bits(qw(subs refs vars));
	$warnings_extra_bits = warnings::bits(FATAL => 'recursion');
}

# it must be "require", because Mousse::Util depends on Mousse::Exporter,
# which depends on Mousse::Util::import()
require Mousse::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);

	Mousse::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;

lib/Mousse.pm  view on Meta::CPAN

			}
		}
	}
	$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 Mousse::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 {
				Mousse::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($_)
				? $_
				: Mousse::Util::resolve_metaclass_alias($type => $_, trait => 1)
			} @traits;

			require Mousse::Util::MetaRole;
			Mousse::Util::MetaRole::apply_metaroles(
				for => $into,
				Mousse::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"})
				);
		}
		Mousse::Util::install_subroutines($into, @export_table);
	}
	else{
		Mousse::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 Mousse::Exporter");

	my $from = _get_caller_package($arg);

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