File Coverage

blib/lib/Aion/Meta/FeatureConstruct.pm

Criterion	Covered	Total	%
statement	39	41	95.1
branch	13	16	81.2
condition	1	3	33.3
subroutine	13	13	100.0
pod	7	7	100.0
total	73	80	91.2

package Aion::Meta::FeatureConstruct;

use common::sense;

use Aion::Meta::Util qw//;

Aion::Meta::Util::create_getters(qw/
	pkg name
	write read
	getvar ret
/);
Aion::Meta::Util::create_accessors(qw/
    init_arg
	set get has clear weaken
	accessor_name reader_name writer_name predicate_name clearer_name
	initer not_specified
	getter setter selfret
/);

#  Конструктор
sub new {
	my ($cls, $pkg, $name) = @_;

	bless {
		pkg => $pkg,
		name => $name,
		initializer => <<'END',
		if (exists $value{%(init_arg)s}) {
			%(initer)s
		}%(not_specified)s
END
		destroyer => <<'END',
		if (%(has)s) {
			eval {
				%(cleaner)s
			};
			warn $@ if $@;
		}
END
		accessor => <<'END',
package %(pkg)s {
	sub %(accessor_name)s%(attr)s {
		if (@_>1) {
			my ($self, $val) = @_;
			%(setter)s
			%(selfret)s
		} else {
			my ($self) = @_;
			%(getter)s
		}
	}
}
END
		reader => <<'END',
package %(pkg)s {
	sub %(reader_name)s {
		my ($self) = @_;
		%(read)s
	}
}
END
		writer => <<'END',
package %(pkg)s {
	sub %(writer_name)s {
		my ($self, $val) = @_;
		%(write)s
		%(selfret)s
	}
}
END
		predicate => <<'END',
package %(pkg)s {
	sub %(predicate_name)s {
		my ($self) = @_;
		%(has)s
	}
}
END
		clearer => <<'END',
package %(pkg)s {
	sub %(clearer_name)s {
		my ($self) = @_;
		if (%(has)s) {
			%(cleaner)s%(clear)s
		}
		%(clearret)s
	}
}
END
		accessor_name  => '%(name)s',
		reader_name    => '_get_%(name)s',
		writer_name    => '_set_%(name)s',
		attr           => '',
		write          => '%(preset)s%(set)s%(trigger)s',
		read           => '%(access)s%(getvar)s%(release)s%(ret)s',
		setter         => '%(write)s',
		getter         => '%(read)s',
		initer         => "%(initvar)s%(write)s",
		init_arg       => '%(name)s',
		initvar        => 'my $val = delete $value{%(init_arg)s};',
		not_specified  => '',
		preset         => '',
		set            => '$self->{%(name)s} = $val;',
		trigger        => '',
		selfret        => '$self',
		access         => '',
		getvar         => '%(get)s',
		get            => '$self->{%(name)s}',
		release        => '',
		ret            => '',
		predicate_name => 'has_%(name)s',
		has            => 'exists $self->{%(name)s}',
		clearer_name   => 'clear_%(name)s',
		clear          => 'delete $self->{%(name)s}',
		clearret       => '$self',
		cleaner        => '',
		weaken         => 'Scalar::Util::weaken(%(get)s);',
	}, ref $cls || $cls;
}

sub add_attr	{ shift->_expand('attr',	@_) }
sub add_preset  { shift->_expand('preset',  @_) }
sub add_trigger { shift->_expand('trigger', @_) }
sub add_cleaner { shift->_expand('cleaner', @_) }
sub add_access  { shift->_expand('access',  @_) }
sub add_release {
	my $self = shift;
	@$self{qw/getvar ret/} = ('my $val = %(get)s;', '$val') if $self->{ret} eq '';
	$self->_expand('release', @_)
}

sub _expand(@) {
	my ($self, $key, $code, $shift) = @_;

	if(ref $self->{$key}) {
		if($shift) { unshift @{$self->{$key}}, $code }
		else { push @{$self->{$key}}, $code }
	}
	elsif ($self->{$key} eq '') {
		$self->{$key} = $code;
	}
	else {
		$self->{$key} = $shift? [$code, $self->{$key}]: [$self->{$key}, $code];
	}

	$self
}

for my $key (qw/initializer destroyer accessor writer reader predicate clearer/) {
	*$key = sub {
		my ($self) = @_;
		_idents($self->_resolv($self->{$key}))
	}
}

sub _resolv {
	my ($self, $s) = @_;
	$s = join '', @$s if ref $s;
	$s =~ s{%\((\w*)\)s}{
		die "has: not construct `$1`\!" unless exists $self->{$1};
		$self->_resolv($self->{$1})
	}ge;
	$s
}

sub _idents {
	local ($_) = @_;
	my $indent;
	s{(^\t*)|;[\t ]*(\S)}{
		if(defined $1) { $indent = $1 } else { ";\n$indent$2" }
	}gme;
	$_
}

1;

__END__