File Coverage

blib/lib/MooX/Struct.pm

Criterion	Covered	Total	%
statement	244	263	92.7
branch	83	90	92.2
condition	41	54	75.9
subroutine	53	54	98.1
pod	9	17	52.9
total	430	478	89.9

package MooX::Struct;

use 5.008;
use strict;
use warnings;
use utf8;

BEGIN {
	$MooX::Struct::AUTHORITY = 'cpan:TOBYINK';
	$MooX::Struct::VERSION   = '0.020';
}

use Moo 1.000;
use Types::TypeTiny 1.000 qw( HashLike ArrayLike );
use Types::Standard 1.000 qw( HashRef ArrayRef Num Ref InstanceOf );
use namespace::autoclean;

my $HashLike  = HashLike  | Ref['HASH'];
my $ArrayLike = ArrayLike | Ref['ARRAY'];

use overload
	q[""]      => 'TO_STRING',
	q[bool]    => sub { 1 },
	q[@{}]     => 'TO_ARRAY',
	q[=]       => 'CLONE',
	fallback   => 1;

METHODS: {
	no warnings;
	sub OBJECT_ID   { require Object::ID; goto \&Object::ID::object_id };
	sub FIELDS      { qw() };
	sub TYPE        { +undef };
	sub TO_ARRAY    {  [ map {;       $_[0]->$_ } $_[0]->FIELDS ] };
	sub TO_HASH     { +{ map {; $_ => $_[0]->$_ } $_[0]->FIELDS } };
	sub TO_STRING   { join q[ ], @{ $_[0]->TO_ARRAY } };
	sub CLONE       { my $s = shift; ref($s)->new(%{$s->TO_HASH}, @_) };
	sub CLASSNAME   { ref($_[0]) or $_[0] };

	my %_cache;
	sub TYPE_TINY {
		my $class = shift->CLASSNAME;
		$_cache{$class} ||= (InstanceOf[$class])->plus_constructors(HashRef|ArrayRef, 'new');
	}
};

sub BUILDARGS
{
	my $class  = shift;
	my @fields = $class->FIELDS;

	if (
		(@_==1 and ref $_[0] eq 'ARRAY') or  # optimized usual case
		(@_==1 and ArrayLike->check($_[0]) and not $HashLike->check($_[0]))
	)
	{
		my @values = @{ $_[0] };
		Carp::confess("too many values passed to constructor (expected @fields); stopped")
			unless @fields >= @values;
		no warnings;
		return +{
			map {
				$fields[$_] => $values[$_];
			} 0 .. $#values
		}
	}

	elsif (@_ == 1 and ref $_[0] ne 'HASH' and $HashLike->check($_[0]))
	{
		# help Moo::Object!
		@_ = +{ %{$_[0]} };
	}

	my $hashref = $class->SUPER::BUILDARGS(@_);

#	my %tmp = map { $_ => 1 } keys %$hashref;
#	delete $tmp{$_} for @fields;
#	if (my @unknown = sort keys %tmp)
#	{
#		Carp::confess("unknown keys passed to constructor (@unknown); stopped");
#	}

	return $hashref;
}

sub EXTEND
{
	my ($invocant, @args) = @_;
	my $base = $invocant;
	$base = ref $invocant if ref $invocant;

	my $processor = 'MooX::Struct::Processor'->new;
	while (@args) {
		last unless $args[0] =~ /^-(.+)$/;
		$processor->flags->{ lc($1) } = !!shift @args;
	}

	my $subname = undef;
	$subname = ${ shift @args } if ref($args[0]) eq 'SCALAR';

	my $new_class = $processor->make_sub(
		$subname,
		[ -extends => [$base], @args ],
	)->();
	return $new_class unless ref $invocant;

	bless $invocant => $new_class;
}

my $done = 0;
sub _data_printer
{
	my ($self, $ddp) = @_;

	my @values;
	my $label;

	if ($Data::Printer::VERSION lt '0.90') {
		require Data::Printer::Filter;
		require Term::ANSIColor;
		@values = map scalar(&Data::Printer::p(\$_, return_value => 'dump')), @$self;
		$label  = Term::ANSIColor::colored($self->TYPE||'struct', 'bright_yellow');
	}
	else
	{
		@values = map $ddp->parse(\$_), @$self;
		$label  = $ddp->maybe_colorize($self->TYPE||'struct', 'MooX::Struct', 'bright_yellow');
	}

	if (grep /\n/, @values) {
		return sprintf(
			"%s[\n\t%s,\n]",
			$label,
			join(qq[,\n\t], map { s/\n/\n\t/gm; $_ } @values),
		);
	}

	sprintf('%s[ %s ]', $label, join q[, ], @values);
}

BEGIN {
	package MooX::Struct::Processor;

	{
		no warnings;
		our $AUTHORITY = 'cpan:TOBYINK';
		our $VERSION   = '0.020';
	}

	sub _uniq { my %seen; grep { not $seen{$_}++ } @_ };

	use Moo 1.000;
	use Exporter::Tiny qw();
	use Types::TypeTiny 1.000 qw( TypeTiny CodeLike HashLike ArrayLike );
	use Types::Standard 1.000 qw( HashRef ArrayRef CodeRef Num );
	use Carp qw(confess);
	use Scalar::Util qw(blessed);
	use namespace::clean qw();
	use B::Hooks::EndOfScope qw(on_scope_end);

	sub __install_sub__ ($) {
		my $args = shift;
		my ($pkg, $name, $code) = @$args{qw(into as code)};
		no strict 'refs';
		*{"$pkg\::$name"} = $code;
	}

	has flags => (
		is       => 'ro',
		isa      => HashLike,
		default  => sub { +{} },
	);

	has class_map => (
		is       => 'ro',
		isa      => HashLike,
		default  => sub { +{} },
	);

	has base => (
		is       => 'ro',
		default  => sub { 'MooX::Struct' },
	);

	has trace => (
		is       => 'lazy',
	);

	sub _build_trace
	{
		$ENV{PERL_MOOX_STRUCT_TRACE}
		or shift->flags->{trace};
	}

	has trace_handle => (
		is       => 'lazy',
	);

	sub _build_trace_handle
	{
		require IO::Handle;
		\*STDERR;
	}

	my $counter = 0;
	sub create_class
	{
		my ($self, $opts) = @_;
		my $klass;
		for my $o (@$opts) {
			next unless $o->[0] eq '-class';
			$klass = ArrayRef->check($o->[1]) ? join('::', @{$o->[1]}) : ${$o->[1]};
			last;
		}
		$klass = sprintf('%s::__ANON__::%04d', $self->base, ++$counter) unless defined $klass;
		"Moo"->_set_superclasses($klass, $self->base);
		"Moo"->_maybe_reset_handlemoose($klass);
		if ($self->trace)
		{
			$self->trace_handle->printf(
				"package %s;\nuse Moo;\n",
				$klass,
			);
		}
		return $klass;
	}

	sub process_meta
	{
		my ($self, $klass, $name, $val) = @_;

		if ($name eq '-extends' or $name eq '-isa')
		{
			my @parents = map {
				exists $self->class_map->{$_}
					? $self->class_map->{$_}->()
					: $_
			} @$val;
			"Moo"->_set_superclasses($klass, @parents);
			"Moo"->_maybe_reset_handlemoose($klass);

			if ($self->trace)
			{
				$self->trace_handle->printf(
					"extends qw(%s)\n",
					join(q[ ] => @parents),
				);
			}

			return map { $_->can('FIELDS') ? $_->FIELDS : () } @parents;
		}
		elsif ($name eq '-with')
		{
			require Moo::Role;
			"Moo::Role"->apply_roles_to_package($klass, @$val);
			"Moo"->_maybe_reset_handlemoose($klass);

			if ($self->trace)
			{
				$self->trace_handle->printf(
					"with qw(%s)\n",
					join(q[ ] => @$val),
				);
			}

			return
			#	map  { my $role = $_; grep { not ref $_ } @{ $Moo::Role::INFO{$role}{attributes} } }
			#	@$val;
		}
		elsif ($name eq '-class')
		{
			# skip; already handled by 'create_class' method (hopefully)
		}
		else
		{
			confess("option '$name' unknown");
		}

		return;
	}

	sub process_method
	{
		my ($self, $klass, $name, $coderef) = @_;
		__install_sub__ {
			into   => $klass,
			as     => $name,
			code   => $coderef,
		};
		if ($self->trace)
		{
			$self->trace_handle->printf(
				"sub %s { ... }\n",
				$name,
			);
			if ($self->flags->{deparse})
			{
				require B::Deparse;
				my $code = "B::Deparse"->new(qw(-q -si8T))->coderef2text($coderef);
				$code =~ s/^/# /mig;
				$self->trace_handle->printf("$code\n");
			}
		}
		return;
	}

	my $ScalarLike;
	sub process_spec
	{
		my ($self, $klass, $name, $val) = @_;

		my %spec = (
			is => ($self->flags->{rw} ? 'rw' : 'ro'),
			( ArrayLike->check($val)
				? @$val
				: ( HashLike->check($val) ? %$val : () )
			),
		);

		if ($name =~ /^(.+)\!$/)
		{
			$name = $1;
			$spec{required} = 1;
		}

		if ($name =~ /^\@(.+)/)
		{
			$name = $1;
			$spec{isa} ||= ArrayLike;
		}
		elsif ($name =~ /^\%(.+)/)
		{
			$name = $1;
			$spec{isa} ||= HashLike;
		}
		elsif ($name =~ /^\+(.+)/)
		{
			$name = $1;
			$spec{isa}     ||= Num;
			$spec{default} ||= sub { 0 } unless $spec{required};
		}
		elsif ($name =~ /^\$(.+)/)
		{
			$ScalarLike ||= (~(ArrayRef|HashRef))->create_child_type(name => 'ScalarLike');
			$name = $1;
			$spec{isa} ||= $ScalarLike;
		}

		return ($name, \%spec);
	}

	sub process_attribute
	{
		my ($self, $klass, $name, $val) = @_;
		my $spec;
		($name, $spec) = $self->process_spec($klass, $name, $val);

		if ($self->trace)
		{
			require Data::Dumper;
			my %sanespec = %$spec;
			if (TypeTiny->check($sanespec{isa})) {
				$sanespec{isa} = $sanespec{isa}->display_name;
			}
			my $spec_str = "Data::Dumper"->new([\%sanespec])->Terse(1)->Indent(0)->Sortkeys(1)->Dump;
			$spec_str =~ s/(^\{)|(\}$)//g;
			$self->trace_handle->printf(
				"has %s => (%s);\n",
				$name,
				$spec_str,
			);
			if ($self->flags->{deparse} and CodeRef->check($spec->{isa}))
			{
				require B::Deparse;
				my $code = "B::Deparse"->new(qw(-q -si8T))->coderef2text($spec->{isa});
				$code =~ s/^/# /mig;
				$self->trace_handle->printf("$code\n");
			}
		}

		"Moo"
			->_constructor_maker_for($klass)
			->register_attribute_specs($name, $spec);

		"Moo"
			->_accessor_maker_for($klass)
			->generate_method($klass, $name, $spec);

		"Moo"
			->_maybe_reset_handlemoose($klass);

		return $name;
	}

	# returns a list of "fields" resulting from the argument
	sub process_argument
	{
		my $self = shift;
		my ($klass, $name, $val) = @_;

		return $self->process_method(@_)    if CodeLike->check($val);
		return $self->process_meta(@_)      if $name =~ /^-/;
		return $self->process_attribute(@_);
	}

	sub make_sub
	{
		my ($self, $subname, $proto) = @_;
		return sub (;$)
		{
			1; # bizarre, but necessary if $] < 5.014
			if (ref $proto)  # inflate!
			{
				my $opts   = Exporter::Tiny::mkopt($proto);
				my $klass  = $self->create_class($opts);
				my $seen_extends;
				my @fields = _uniq map {
					++$seen_extends if $_->[0] eq '-extends';
					$self->process_argument($klass, @$_);
				} @$opts;
				unshift @fields, $self->base->FIELDS
					if !$seen_extends && $self->base->can('FIELDS');
				$self->process_method($klass, FIELDS => sub { @fields });
				$self->process_method($klass, TYPE   => sub { $subname }) if defined $subname;
				$proto = $klass;
			}
			return $proto->new(@_) if @_;
			return $proto;
		}
	}

	sub process
	{
		my $self   = shift;
		my $caller = shift;

		while (@_ and $_[0] =~ /^-(.+)$/) {
			$self->flags->{ lc($1) } = !!shift;
		}

		foreach my $arg (@{ Exporter::Tiny::mkopt(\@_) })
		{
			my ($subname, $details) = @$arg;
			$details = [] unless defined $details;

			$self->class_map->{ $subname } = $self->make_sub($subname, $details);
			__install_sub__ {
				into   => $caller,
				as     => $subname,
				code   => $self->class_map->{ $subname },
			};
		}

		on_scope_end {
			namespace::clean->clean_subroutines(
				$caller,
				keys %{ $self->class_map },
			);
		} unless $self->flags->{ retain };
	}
};

sub import
{
	my $caller = caller;
	my $class  = shift;
	"$class\::Processor"->new->process($caller, @_);
}

1;

__END__