{
$MooseX::ClassCompositor::VERSION = '0.004';
}
use Moose;
# ABSTRACT: a factory that builds classes from roles
use Moose::Util qw(apply_all_roles);
use MooseX::Types::Perl qw(PackageName);
use Scalar::Util qw(refaddr);
has class_basename => (
is => 'ro',
isa => PackageName,
required => 1,
);
has class_metaroles => (
reader => '_class_metaroles',
isa => 'HashRef',
default => sub { {} },
);
has known_classes => (
reader => '_known_classes',
isa => 'HashRef',
traits => [ 'Hash' ],
handles => {
_learn_class => 'set',
known_classes => 'elements',
},
init_arg => undef,
default => sub { {} },
);
has role_prefixes => (
reader => '_role_prefixes',
isa => 'HashRef',
default => sub { {} },
);
sub _rewrite_roles {
my ($self, @in) = @_;
return String::RewritePrefix->rewrite($self->_role_prefixes, @in);
}
has fixed_roles => (
reader => '_fixed_roles',
isa => 'ArrayRef',
default => sub { [] },
);
has serial_counter => (
reader => '_serial_counter',
isa => 'Str',
default => 'AA',
traits => [ 'String' ],
handles => { next_serial => 'inc' },
init_arg => undef,
);
has _memoization_table => (
is => 'ro',
isa => 'HashRef',
default => sub { {} },
traits => [ 'Hash' ],
handles => {
_class_for_key => 'get',
_set_class_for_key => 'set',
},
init_arg => undef,
);
sub class_for {
my ($self, @args) = @_;
# can't use memoize without losing subclassability, so we reimplemented
# -- rjbs, 2011-08-05
my $memo_key = $self->_memoization_key(\@args);
if (my $cached = $self->_class_for_key($memo_key)) {
return $cached;
}
# Arguments here are role names, or role objects followed by nonce-names.
my @orig_args = @args;
# $role_hash is a hash mapping nonce-names to role objects
# $role_names is an array of names of more roles to add
my (@roles, @role_class_names, @all_names);
while (@args) {
my $name = shift @args;
if (ref $name) {
my ($role_name, $moniker, $params) = @$name;
my $full_name = $self->_rewrite_roles($role_name);
Class::MOP::load_class($full_name);
my $role_object = $full_name->meta->generate_role(
parameters => $params,
);
push @roles, $role_object;
$name = $moniker;
} else {
push @role_class_names, $name;
}
$name =~ s/::/_/g if @all_names;
$name =~ s/^=//;
push @all_names, $name;
}
my $name = join q{::}, $self->class_basename, @all_names;
@role_class_names = (
$self->_rewrite_roles(
@role_class_names,
@{ $self->_fixed_roles },
),
);
Class::MOP::load_class($_) for @role_class_names;
if ($name->can('meta')) {
$name .= "_" . $self->next_serial;
}
my $class = Moose::Meta::Class->create( $name => (
superclasses => [ 'Moose::Object' ],
));
$class = Moose::Util::MetaRole::apply_metaroles(
for => $class->name,
class_metaroles => $self->_class_metaroles,
);
apply_all_roles($class, @role_class_names, map $_->name, @roles);
$class->make_immutable;
$self->_learn_class($name, \@orig_args);
$self->_set_class_for_key($memo_key, $name);
return $class->name;
}
sub _memoization_key {
my ($self, $args) = @_;
my @args = @$args;
my @k;
while (@args) {
my $arg = shift @args;
if (ref $arg) {
my ($role_name, $moniker, $params) = @$arg;
push @k, "$moniker : { " . __hash_to_string($params) . " }";
} else {
push @k, $arg;
}
}
my $key = join "; ", sort @k;
return $key;
}
sub __hash_to_string {
my ($h) = @_;
my @k;
for my $k (sort keys %$h) {
my $v = ! defined($h->{$k}) ? "<undef>" :
ref($h->{$k}) ? join("-", @{$h->{$k}}) : $h->{$k};
push @k, "$k => $v";
}
join ", " => @k;
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=head1 NAME
MooseX::ClassCompositor - a factory that builds classes from roles
=head1 VERSION
version 0.004
=head1 SYNOPSIS
my $comp = MooseX::ClassCompositor->new({
class_basename => 'MyApp::Class',
class_metaroles => {
class => [ 'MooseX::StrictConstructor::Trait::Class' ],
},
role_prefixes => {
'' => 'MyApp::Role::',
'=' => '',
},
});
my $class = $comp->class_for( qw( PieEater ContestWinner ) );
my $object = $class->new({
pie_type => 'banana',
place => '2nd',
});
=head1 OVERVIEW
A MooseX::ClassCompositor is a class factory. If you think using a class
factory will make you feel like a filthy "enterprise" programmer, maybe you
should turn back now.
The compositor has a C<L</class_for>> method that builds a class by combining a
list of roles with L<Moose::Object>, applying any supplied metaclass, and
producing an arbitrary-but-human-scannable name. The metaclass is then
made immutable, the operation is memoized, and the class name is returned.
In the L</SYNOPSIS> above, you can see all the major features used:
C<class_metaroles> to enable strict constructors, C<role_prefixes> to use
L<String::RewritePrefix> to expand role name shorthand, and C<class_basename>
to pick a namespace under which to put constructed classes.
Not shown is the C<L</known_classes>> method, which returns a list of pairs
describing all the classes that the factory has constructed. This method can
be useful for debugging and other somewhat esoteric purposes like
serialization.
=head1 ATTRIBUTES
=head2 class_basename
This attribute must be given, and must be a valid Perl package name.
Constructed classes will all be under this namespace.
=head2 class_metaroles
This attribute, if given, must be a hashref of class metaroles that will be
applied to newly-constructed classes with
L<Moose::Util::MetaRole::apply_metaroles>.
=head2 known_classes
This attribute stores a mapping of class names to the parameters used to
construct them. The C<known_classes> method returns its contents as a list of
pairs.
=head2 role_prefixes
This attribute is used as the arguments to L<String::RewritePrefix> for
expanding role names passed to the compositor's L<class_for> method.
=head2 fixed_roles
This attribute may be initialized with an arrayref of role names. These roles
will I<always> be composed in the classes built by the compositor.
These names I<will> be rewritten by the role prefixes.
=head1 METHODS
=head2 class_for
my $class = $compositor->class_for(
'Role::Name', # <-- will be expanded with role_prefixes
[
'Param::Role::Name', # <-- will be expanded with role_prefixes
'ApplicationName', # <-- will not be touched
{ ...param... },
],
);
This method will return a class with the roles passed to it. They can be given
either as names (which will be expanded according to C<L</role_prefixes>>) or
as arrayrefs containing a role name, application name, and hashref of
parameters. In the arrayref form, the application name is just a name used to
uniquely identify this application of a parameterized role, so that they can be
applied multiple times with each application accounted for internally.
Note that at present, passing Moose::Meta::Role objects is B<not> supported.
This should change in the future.
=head1 THANKS
Thanks to Pobox.com for sponsoring the development of this library.
=head1 AUTHORS
=over 4
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Mark Jason Dominus <mjd@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut