Initial Commit

This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions

View File

@@ -0,0 +1,204 @@
package MooseX::ClassAttribute;
use strict;
use warnings;
our $VERSION = '0.29';
# This module doesn't really need these pragmas - this is just for the benefit
# of prereq scanning.
use namespace::clean 0.20 ();
use namespace::autoclean 0.11 ();
use Moose 2.00 ();
use Moose::Exporter;
use Moose::Util;
use MooseX::ClassAttribute::Trait::Class;
use MooseX::ClassAttribute::Trait::Role;
use MooseX::ClassAttribute::Trait::Application::ToClass;
use MooseX::ClassAttribute::Trait::Application::ToRole;
Moose::Exporter->setup_import_methods(
with_meta => ['class_has'],
class_metaroles => {
class => ['MooseX::ClassAttribute::Trait::Class'],
},
role_metaroles => {
role => ['MooseX::ClassAttribute::Trait::Role'],
application_to_class =>
['MooseX::ClassAttribute::Trait::Application::ToClass'],
application_to_role =>
['MooseX::ClassAttribute::Trait::Application::ToRole'],
},
);
sub class_has {
my $meta = shift;
my $name = shift;
my $attrs = ref $name eq 'ARRAY' ? $name : [$name];
my %options = ( definition_context => _caller_info(), @_ );
$meta->add_class_attribute( $_, %options ) for @{$attrs};
}
# Copied from Moose::Util in 2.06
sub _caller_info {
my $level = @_ ? ( $_[0] + 1 ) : 2;
my %info;
@info{qw(package file line)} = caller($level);
return \%info;
}
1;
# ABSTRACT: Declare class attributes Moose-style
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute - Declare class attributes Moose-style
=head1 VERSION
version 0.29
=head1 SYNOPSIS
package My::Class;
use Moose;
use MooseX::ClassAttribute;
class_has 'Cache' =>
( is => 'rw',
isa => 'HashRef',
default => sub { {} },
);
__PACKAGE__->meta()->make_immutable();
no Moose;
no MooseX::ClassAttribute;
# then later ...
My::Class->Cache()->{thing} = ...;
=head1 DESCRIPTION
This module allows you to declare class attributes in exactly the same
way as object attributes, using C<class_has()> instead of C<has()>.
You can use any feature of Moose's attribute declarations, including
overriding a parent's attributes, delegation (C<handles>), attribute traits,
etc. All features should just work. The one exception is the "required" flag,
which is not allowed for class attributes.
The accessor methods for class attribute may be called on the class
directly, or on objects of that class. Passing a class attribute to
the constructor will not set that attribute.
=head1 FUNCTIONS
This class exports one function when you use it, C<class_has()>. This
works exactly like Moose's C<has()>, but it declares class attributes.
One little nit is that if you include C<no Moose> in your class, you won't
remove the C<class_has()> function. To do that you must include C<no
MooseX::ClassAttribute> as well. Or you can just use L<namespace::autoclean>
instead.
=head2 Implementation and Immutability
This module will add a role to your class's metaclass, See
L<MooseX::ClassAttribute::Trait::Class> for details. This role
provides introspection methods for class attributes.
Class attributes themselves do the
L<MooseX::ClassAttribute::Trait::Attribute> role.
=head2 Cooperation with Metaclasses and Traits
This module should work with most attribute metaclasses and traits,
but it's possible that conflicts could occur. This module has been
tested to work with Moose's native traits.
=head2 Class Attributes in Roles
You can add a class attribute to a role. When that role is applied to a class,
the class will have the relevant class attributes added. Note that attribute
defaults will be calculated when the class attribute is composed into the
class.
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 DONATIONS
If you'd like to thank me for the work I've done on this module, please
consider making a "donation" to me via PayPal. I spend a lot of free time
creating free software, and would appreciate any support you'd care to offer.
Please note that B<I am not suggesting that you must do this> in order for me
to continue working on this particular software. I will continue to do so,
inasmuch as I have in the past, for as long as it interests me.
Similarly, a donation made in this way will probably not make me work on this
software much more, unless I get so many donations that I can consider working
on free software full time (let's all have a chuckle at that together).
To donate, log into PayPal and send money to autarch@urth.org, or use the
button at L<http://www.urth.org/~autarch/fs-donation.html>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 CONTRIBUTORS
=for stopwords Andrew Rodland Karen Etheridge Rafael Kitover Robert Buels Shawn M Moore
=over 4
=item *
Andrew Rodland <andrew@cleverdomain.org>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Rafael Kitover <rkitover@cpan.org>
=item *
Robert Buels <rmb32@cornell.edu>
=item *
Shawn M Moore <sartak@gmail.com>
=back
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,69 @@
package MooseX::ClassAttribute::Meta::Role::Attribute;
use strict;
use warnings;
our $VERSION = '0.29';
use namespace::autoclean;
use Moose;
use List::Util 1.45 'uniq';
extends 'Moose::Meta::Role::Attribute';
sub new {
my ( $class, $name, %options ) = @_;
$options{traits} = [
uniq( @{ $options{traits} || [] } ),
'MooseX::ClassAttribute::Trait::Attribute'
];
return $class->SUPER::new( $name, %options );
}
1;
# ABSTRACT: An attribute metaclass for class attributes in roles
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Meta::Role::Attribute - An attribute metaclass for class attributes in roles
=head1 VERSION
version 0.29
=head1 DESCRIPTION
This class overrides L<Moose::Meta::Role::Attribute> to support class
attribute declaration in roles.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,59 @@
package MooseX::ClassAttribute::Trait::Application;
use strict;
use warnings;
our $VERSION = '0.29';
use namespace::autoclean;
use Moose::Role;
after apply_attributes => sub {
shift->_apply_class_attributes(@_);
};
1;
# ABSTRACT: A trait that supports role application for roles with class attributes
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Application - A trait that supports role application for roles with class attributes
=head1 VERSION
version 0.29
=head1 DESCRIPTION
This trait is used to allow the application of roles containing class
attributes.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,94 @@
package MooseX::ClassAttribute::Trait::Application::ToClass;
use strict;
use warnings;
our $VERSION = '0.29';
use namespace::autoclean;
use Moose::Role;
with 'MooseX::ClassAttribute::Trait::Application';
around apply => sub {
my $orig = shift;
my $self = shift;
my $role = shift;
my $class = shift;
$class = Moose::Util::MetaRole::apply_metaroles(
for => $class,
class_metaroles => {
class => ['MooseX::ClassAttribute::Trait::Class'],
},
);
$self->$orig( $role, $class );
};
sub _apply_class_attributes {
my $self = shift;
my $role = shift;
my $class = shift;
my $attr_metaclass = $class->attribute_metaclass();
foreach my $attribute_name ( $role->get_class_attribute_list() ) {
if ( $class->has_class_attribute($attribute_name)
&& $class->get_class_attribute($attribute_name)
!= $role->get_class_attribute($attribute_name) ) {
next;
}
else {
$class->add_class_attribute(
$role->get_class_attribute($attribute_name)
->attribute_for_class($attr_metaclass) );
}
}
}
1;
# ABSTRACT: A trait that supports applying class attributes to classes
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Application::ToClass - A trait that supports applying class attributes to classes
=head1 VERSION
version 0.29
=head1 DESCRIPTION
This trait is used to allow the application of roles containing class
attributes to classes.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,104 @@
package MooseX::ClassAttribute::Trait::Application::ToRole;
use strict;
use warnings;
our $VERSION = '0.29';
use Moose::Util::MetaRole;
use MooseX::ClassAttribute::Trait::Application::ToClass;
use namespace::autoclean;
use Moose::Role;
with 'MooseX::ClassAttribute::Trait::Application';
around apply => sub {
my $orig = shift;
my $self = shift;
my $role1 = shift;
my $role2 = shift;
$role2 = Moose::Util::MetaRole::apply_metaroles(
for => $role2,
role_metaroles => {
role => ['MooseX::ClassAttribute::Trait::Role'],
application_to_class =>
['MooseX::ClassAttribute::Trait::Application::ToClass'],
application_to_role =>
['MooseX::ClassAttribute::Trait::Application::ToRole'],
},
);
$self->$orig( $role1, $role2 );
};
sub _apply_class_attributes {
my $self = shift;
my $role1 = shift;
my $role2 = shift;
foreach my $attribute_name ( $role1->get_class_attribute_list() ) {
if ( $role2->has_class_attribute($attribute_name)
&& $role2->get_class_attribute($attribute_name)
!= $role1->get_class_attribute($attribute_name) ) {
require Moose;
Moose->throw_error( "Role '"
. $role1->name()
. "' has encountered a class attribute conflict "
. "during composition. This is fatal error and cannot be disambiguated."
);
}
else {
$role2->add_class_attribute(
$role1->get_class_attribute($attribute_name)->clone() );
}
}
}
1;
# ABSTRACT: A trait that supports applying class attributes to roles
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Application::ToRole - A trait that supports applying class attributes to roles
=head1 VERSION
version 0.29
=head1 DESCRIPTION
This trait is used to allow the application of roles containing class
attributes to roles.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,268 @@
package MooseX::ClassAttribute::Trait::Attribute;
use strict;
use warnings;
our $VERSION = '0.29';
use namespace::autoclean;
use Moose::Role;
# This is the worst role evar! Really, this should be a subclass,
# because it overrides a lot of behavior. However, as a subclass it
# won't cooperate with _other_ subclasses.
around _process_options => sub {
my $orig = shift;
my $class = shift;
my $name = shift;
my $options = shift;
confess 'A class attribute cannot be required'
if $options->{required};
return $class->$orig( $name, $options );
};
after attach_to_class => sub {
my $self = shift;
my $meta = shift;
$self->_initialize($meta)
unless $self->is_lazy();
};
before detach_from_class => sub {
my $self = shift;
my $meta = shift;
$self->clear_value($meta);
};
sub _initialize {
my $self = shift;
my $metaclass = shift;
if ( $self->has_default() ) {
$self->set_value(
undef,
$self->default( $self->associated_class() )
);
}
elsif ( $self->has_builder() ) {
$self->set_value( undef, $self->_call_builder( $metaclass->name() ) );
}
}
around default => sub {
my $orig = shift;
my $self = shift;
my $default = $self->$orig();
if ( $self->is_default_a_coderef() && @_ ) {
return $default->(@_);
}
return $default;
};
around _call_builder => sub {
shift;
my $self = shift;
my $class = shift;
my $builder = $self->builder();
return $class->$builder()
if $class->can( $self->builder );
confess( "$class does not support builder method '"
. $self->builder
. "' for attribute '"
. $self->name
. "'" );
};
around set_value => sub {
shift;
my $self = shift;
shift; # ignoring instance or class name
my $value = shift;
$self->associated_class()
->set_class_attribute_value( $self->name() => $value );
};
around get_value => sub {
shift;
my $self = shift;
return $self->associated_class()
->get_class_attribute_value( $self->name() );
};
around has_value => sub {
shift;
my $self = shift;
return $self->associated_class()
->has_class_attribute_value( $self->name() );
};
around clear_value => sub {
shift;
my $self = shift;
return $self->associated_class()
->clear_class_attribute_value( $self->name() );
};
if ( $Moose::VERSION < 1.99 ) {
around inline_get => sub {
shift;
my $self = shift;
return $self->associated_class()
->_inline_get_class_slot_value( $self->slots() );
};
around inline_set => sub {
shift;
my $self = shift;
shift;
my $value = shift;
my $meta = $self->associated_class();
my $code
= $meta->_inline_set_class_slot_value( $self->slots(), $value )
. ";";
$code .= $meta->_inline_weaken_class_slot_value(
$self->slots(),
$value
)
. " if ref $value;"
if $self->is_weak_ref();
return $code;
};
around inline_has => sub {
shift;
my $self = shift;
return $self->associated_class()
->_inline_is_class_slot_initialized( $self->slots() );
};
around inline_clear => sub {
shift;
my $self = shift;
return $self->associated_class()
->_inline_deinitialize_class_slot( $self->slots() );
};
}
else {
around _inline_instance_get => sub {
shift;
my $self = shift;
return $self->associated_class()
->_inline_get_class_slot_value( $self->slots() );
};
around _inline_instance_set => sub {
shift;
my $self = shift;
shift;
my $value = shift;
return $self->associated_class()
->_inline_set_class_slot_value( $self->slots(), $value );
};
around _inline_instance_has => sub {
shift;
my $self = shift;
return $self->associated_class()
->_inline_is_class_slot_initialized( $self->slots() );
};
around _inline_instance_clear => sub {
shift;
my $self = shift;
return $self->associated_class()
->_inline_deinitialize_class_slot( $self->slots() );
};
around _inline_weaken_value => sub {
shift;
my $self = shift;
shift;
my $value = shift;
return unless $self->is_weak_ref();
return (
$self->associated_class->_inline_weaken_class_slot_value(
$self->slots(), $value
),
'if ref ' . $value . ';',
);
};
}
1;
# ABSTRACT: A trait for class attributes
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Attribute - A trait for class attributes
=head1 VERSION
version 0.29
=head1 DESCRIPTION
This role modifies the behavior of class attributes in various
ways. It really should be a subclass of C<Moose::Meta::Attribute>, but
if it were then it couldn't be combined with other attribute
metaclasses, like C<MooseX::AttributeHelpers>.
There are no new public methods implemented by this role. All it does
is change the behavior of a number of existing methods.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,329 @@
package MooseX::ClassAttribute::Trait::Class;
use strict;
use warnings;
our $VERSION = '0.29';
use MooseX::ClassAttribute::Trait::Attribute;
use Scalar::Util qw( blessed );
use namespace::autoclean;
use Moose::Role;
with 'MooseX::ClassAttribute::Trait::Mixin::HasClassAttributes';
has _class_attribute_values => (
traits => ['Hash'],
is => 'ro',
isa => 'HashRef',
handles => {
'get_class_attribute_value' => 'get',
'set_class_attribute_value' => 'set',
'has_class_attribute_value' => 'exists',
'clear_class_attribute_value' => 'delete',
},
lazy => 1,
default => sub { $_[0]->_class_attribute_values_hashref() },
init_arg => undef,
);
around add_class_attribute => sub {
my $orig = shift;
my $self = shift;
my $attr = (
blessed $_[0] && $_[0]->isa('Class::MOP::Attribute')
? $_[0]
: $self->_process_class_attribute(@_)
);
$self->$orig($attr);
return $attr;
};
sub _post_add_class_attribute {
my $self = shift;
my $attr = shift;
my $name = $attr->name();
my $e = do {
local $@;
eval { $attr->install_accessors() };
$@;
};
if ($e) {
$self->remove_attribute($name);
die $e;
}
}
sub _attach_class_attribute {
my ( $self, $attribute ) = @_;
$attribute->attach_to_class($self);
}
# It'd be nice if I didn't have to replicate this for class
# attributes, since it's basically just a copy of
# Moose::Meta::Class->_process_attribute
sub _process_class_attribute {
my $self = shift;
my $name = shift;
my @args = @_;
@args = %{ $args[0] } if scalar @args == 1 && ref( $args[0] ) eq 'HASH';
if ( $name =~ /^\+(.*)/ ) {
return $self->_process_inherited_class_attribute( $1, @args );
}
else {
return $self->_process_new_class_attribute( $name, @args );
}
}
sub _process_new_class_attribute {
my $self = shift;
my $name = shift;
my %p = @_;
if ( $p{traits} ) {
push @{ $p{traits} }, 'MooseX::ClassAttribute::Trait::Attribute';
}
else {
$p{traits} = ['MooseX::ClassAttribute::Trait::Attribute'];
}
return Moose::Meta::Attribute->interpolate_class_and_new( $name, %p );
}
sub _process_inherited_class_attribute {
my $self = shift;
my $name = shift;
my %p = @_;
my $inherited_attr = $self->find_class_attribute_by_name($name);
( defined $inherited_attr )
|| confess
"Could not find an attribute by the name of '$name' to inherit from";
return $inherited_attr->clone_and_inherit_options(%p);
}
around remove_class_attribute => sub {
my $orig = shift;
my $self = shift;
my $removed_attr = $self->$orig(@_)
or return;
$removed_attr->remove_accessors();
$removed_attr->detach_from_class();
return $removed_attr;
};
sub get_all_class_attributes {
my $self = shift;
my %attrs = map {
my $meta = Class::MOP::class_of($_);
$meta && $meta->can('_class_attribute_map')
? %{ $meta->_class_attribute_map() }
: ()
}
reverse $self->linearized_isa;
return values %attrs;
}
sub compute_all_applicable_class_attributes {
warn
'The compute_all_applicable_class_attributes method has been deprecated.'
. " Use get_all_class_attributes instead.\n";
shift->compute_all_applicable_class_attributes(@_);
}
sub find_class_attribute_by_name {
my $self = shift;
my $name = shift;
foreach my $class ( $self->linearized_isa() ) {
my $meta = Class::MOP::class_of($class)
or next;
return $meta->get_class_attribute($name)
if $meta->can('has_class_attribute')
&& $meta->has_class_attribute($name);
}
return;
}
sub _class_attribute_values_hashref {
my $self = shift;
no strict 'refs';
return \%{ $self->_class_attribute_var_name() };
}
sub _class_attribute_var_name {
my $self = shift;
return $self->name() . q'::__ClassAttributeValues';
}
sub _inline_class_slot_access {
my $self = shift;
my $name = shift;
return
'$'
. $self->_class_attribute_var_name . '{"'
. quotemeta($name) . '"}';
}
sub _inline_get_class_slot_value {
my $self = shift;
my $name = shift;
return $self->_inline_class_slot_access($name);
}
sub _inline_set_class_slot_value {
my $self = shift;
my $name = shift;
my $val_name = shift;
return $self->_inline_class_slot_access($name) . ' = ' . $val_name;
}
sub _inline_is_class_slot_initialized {
my $self = shift;
my $name = shift;
return 'exists ' . $self->_inline_class_slot_access($name);
}
sub _inline_deinitialize_class_slot {
my $self = shift;
my $name = shift;
return 'delete ' . $self->_inline_class_slot_access($name);
}
sub _inline_weaken_class_slot_value {
my $self = shift;
my $name = shift;
return
'Scalar::Util::weaken( '
. $self->_inline_class_slot_access($name) . ')';
}
1;
# ABSTRACT: A trait for classes with class attributes
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Class - A trait for classes with class attributes
=head1 VERSION
version 0.29
=head1 SYNOPSIS
for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
{
print $attr->name();
}
=head1 DESCRIPTION
This role adds awareness of class attributes to a metaclass object. It
provides a set of introspection methods that largely parallel the
existing attribute methods, except they operate on class attributes.
=head1 METHODS
Every method provided by this role has an analogous method in
C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
=head2 $meta->has_class_attribute($name)
=head2 $meta->get_class_attribute($name)
=head2 $meta->get_class_attribute_list()
These methods operate on the current metaclass only.
=head2 $meta->add_class_attribute(...)
This accepts the same options as the L<Moose::Meta::Attribute>
C<add_attribute()> method. However, if an attribute is specified as
"required" an error will be thrown.
=head2 $meta->remove_class_attribute($name)
If the named class attribute exists, it is removed from the class,
along with its accessor methods.
=head2 $meta->get_all_class_attributes()
This method returns a list of attribute objects for the class and all
its parent classes.
=head2 $meta->find_class_attribute_by_name($name)
This method looks at the class and all its parent classes for the
named class attribute.
=head2 $meta->get_class_attribute_value($name)
=head2 $meta->set_class_attribute_value($name, $value)
=head2 $meta->set_class_attribute_value($name)
=head2 $meta->clear_class_attribute_value($name)
These methods operate on the storage for class attribute values, which
is attached to the metaclass object.
There's really no good reason for you to call these methods unless
you're doing some deep hacking. They are named as public methods
solely because they are used by other meta roles and classes in this
distribution.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,124 @@
package MooseX::ClassAttribute::Trait::Mixin::HasClassAttributes;
use strict;
use warnings;
our $VERSION = '0.29';
use namespace::autoclean;
use Moose::Role;
has _class_attribute_map => (
traits => ['Hash'],
is => 'ro',
isa => 'HashRef[Class::MOP::Mixin::AttributeCore]',
handles => {
'_add_class_attribute' => 'set',
'has_class_attribute' => 'exists',
'get_class_attribute' => 'get',
'_remove_class_attribute' => 'delete',
'get_class_attribute_list' => 'keys',
},
default => sub { {} },
init_arg => undef,
);
# deprecated
sub get_class_attribute_map {
return $_[0]->_class_attribute_map();
}
sub add_class_attribute {
my $self = shift;
my $attribute = shift;
( $attribute->isa('Class::MOP::Mixin::AttributeCore') )
|| confess
"Your attribute must be an instance of Class::MOP::Mixin::AttributeCore (or a subclass)";
$self->_attach_class_attribute($attribute);
my $attr_name = $attribute->name;
$self->remove_class_attribute($attr_name)
if $self->has_class_attribute($attr_name);
my $order = ( scalar keys %{ $self->_attribute_map } );
$attribute->_set_insertion_order($order);
$self->_add_class_attribute( $attr_name => $attribute );
# This method is called to allow for installing accessors. Ideally, we'd
# use method overriding, but then the subclass would be responsible for
# making the attribute, which would end up with lots of code
# duplication. Even more ideally, we'd use augment/inner, but this is
# Class::MOP!
$self->_post_add_class_attribute($attribute)
if $self->can('_post_add_class_attribute');
return $attribute;
}
sub remove_class_attribute {
my $self = shift;
my $name = shift;
( defined $name && $name )
|| confess 'You must provide an attribute name';
my $removed_attr = $self->get_class_attribute($name);
return unless $removed_attr;
$self->_remove_class_attribute($name);
return $removed_attr;
}
1;
# ABSTRACT: A mixin trait for things which have class attributes
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Mixin::HasClassAttributes - A mixin trait for things which have class attributes
=head1 VERSION
version 0.29
=head1 DESCRIPTION
This trait is like L<Class::MOP::Mixin::HasAttributes>, except that it works
with class attributes instead of object attributes.
See L<MooseX::ClassAttribute::Trait::Class> and
L<MooseX::ClassAttribute::Trait::Role> for API details.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,116 @@
package MooseX::ClassAttribute::Trait::Role;
use strict;
use warnings;
our $VERSION = '0.29';
use MooseX::ClassAttribute::Meta::Role::Attribute;
use Scalar::Util qw( blessed );
use namespace::autoclean;
use Moose::Role;
with 'MooseX::ClassAttribute::Trait::Mixin::HasClassAttributes';
around add_class_attribute => sub {
my $orig = shift;
my $self = shift;
my $attr = (
blessed $_[0] && $_[0]->isa('Class::MOP::Mixin::AttributeCore')
? $_[0]
: MooseX::ClassAttribute::Meta::Role::Attribute->new(@_)
);
$self->$orig($attr);
return $attr;
};
sub _attach_class_attribute {
my ( $self, $attribute ) = @_;
$attribute->attach_to_role($self);
}
sub composition_class_roles {
return 'MooseX::ClassAttribute::Trait::Role::Composite';
}
1;
# ABSTRACT: A trait for roles with class attributes
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Role - A trait for roles with class attributes
=head1 VERSION
version 0.29
=head1 SYNOPSIS
for my $attr ( HasClassAttributes->meta()->get_all_class_attributes() )
{
print $attr->name();
}
=head1 DESCRIPTION
This role adds awareness of class attributes to a role metaclass object. It
provides a set of introspection methods that largely parallel the existing
attribute methods, except they operate on class attributes.
=head1 METHODS
Every method provided by this role has an analogous method in
C<Class::MOP::Class> or C<Moose::Meta::Class> for regular attributes.
=head2 $meta->has_class_attribute($name)
=head2 $meta->get_class_attribute($name)
=head2 $meta->get_class_attribute_list()
These methods are exactly like their counterparts in
L<MooseX::ClassAttribute::Trait::Class>.
=head2 $meta->add_class_attribute(...)
This accepts the same options as the L<Moose::Meta::Attribute>
C<add_attribute()> method. However, if an attribute is specified as
"required" an error will be thrown.
=head2 $meta->remove_class_attribute($name)
If the named class attribute exists, it is removed from the role.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,119 @@
package MooseX::ClassAttribute::Trait::Role::Composite;
use strict;
use warnings;
our $VERSION = '0.29';
use Moose::Util::MetaRole;
use Moose::Util qw(does_role);
use namespace::autoclean;
use Moose::Role;
with 'MooseX::ClassAttribute::Trait::Role';
sub _merge_class_attributes {
my $self = shift;
my @all_attributes;
foreach my $role ( @{ $self->get_roles() } ) {
if ( does_role( $role, 'MooseX::ClassAttribute::Trait::Role' ) ) {
push @all_attributes,
map { $role->get_class_attribute($_) }
$role->get_class_attribute_list();
}
}
my %seen;
foreach my $attribute (@all_attributes) {
my $name = $attribute->name();
if ( exists $seen{$name} ) {
next if $seen{$name} == $attribute;
require Moose;
Moose->throw_error( "Role '"
. $self->name()
. "' has encountered a class attribute conflict "
. "during composition. This is a fatal error and "
. "cannot be disambiguated." );
}
$seen{$name} = $attribute;
}
foreach my $attribute (@all_attributes) {
$self->add_class_attribute( $attribute->clone() );
}
return keys %seen;
}
around apply_params => sub {
my $orig = shift;
my $self = shift;
$self->$orig(@_);
$self = Moose::Util::MetaRole::apply_metaroles(
for => $self,
role_metaroles => {
application_to_class =>
['MooseX::ClassAttribute::Trait::Application::ToClass'],
application_to_role =>
['MooseX::ClassAttribute::Trait::Application::ToRole'],
},
);
$self->_merge_class_attributes();
return $self;
};
1;
# ABSTRACT: A trait that supports applying multiple roles at once
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::ClassAttribute::Trait::Role::Composite - A trait that supports applying multiple roles at once
=head1 VERSION
version 0.29
=head1 DESCRIPTION
This trait is used to allow the application of multiple roles (one
or more of which contain class attributes) to a class or role.
=head1 BUGS
See L<MooseX::ClassAttribute> for details.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-ClassAttribute>
(or L<bug-moosex-classattribute@rt.cpan.org|mailto:bug-moosex-classattribute@rt.cpan.org>).
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 AUTHOR
Dave Rolsky <autarch@urth.org>
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut

View File

@@ -0,0 +1,640 @@
use strict;
use warnings;
package MooseX::Declare; # git description: v0.42-6-gab03158
# ABSTRACT: (DEPRECATED) Declarative syntax for Moose
# KEYWORDS: moose extension declaration syntax sugar method class deprecated
our $VERSION = '0.43';
use aliased 'MooseX::Declare::Syntax::Keyword::Class', 'ClassKeyword';
use aliased 'MooseX::Declare::Syntax::Keyword::Role', 'RoleKeyword';
use aliased 'MooseX::Declare::Syntax::Keyword::Namespace', 'NamespaceKeyword';
use namespace::clean 0.19;
sub import {
my ($class, %args) = @_;
my $caller = caller();
strict->import;
warnings->import;
for my $keyword ($class->keywords) {
$keyword->setup_for($caller, %args, provided_by => $class);
}
}
sub keywords {
ClassKeyword->new(identifier => 'class'),
RoleKeyword->new(identifier => 'role'),
NamespaceKeyword->new(identifier => 'namespace'),
}
#pod =head1 SYNOPSIS
#pod
#pod use MooseX::Declare;
#pod
#pod class BankAccount {
#pod has 'balance' => ( isa => 'Num', is => 'rw', default => 0 );
#pod
#pod method deposit (Num $amount) {
#pod $self->balance( $self->balance + $amount );
#pod }
#pod
#pod method withdraw (Num $amount) {
#pod my $current_balance = $self->balance();
#pod ( $current_balance >= $amount )
#pod || confess "Account overdrawn";
#pod $self->balance( $current_balance - $amount );
#pod }
#pod }
#pod
#pod class CheckingAccount extends BankAccount {
#pod has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
#pod
#pod before withdraw (Num $amount) {
#pod my $overdraft_amount = $amount - $self->balance();
#pod if ( $self->overdraft_account && $overdraft_amount > 0 ) {
#pod $self->overdraft_account->withdraw($overdraft_amount);
#pod $self->deposit($overdraft_amount);
#pod }
#pod }
#pod }
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module provides syntactic sugar for Moose, the postmodern object system
#pod for Perl 5. When used, it sets up the C<class> and C<role> keywords.
#pod
#pod B<Note:> Please see the L</WARNING> section below!
#pod
#pod =head1 KEYWORDS
#pod
#pod =head2 class
#pod
#pod class Foo { ... }
#pod
#pod my $anon_class = class { ... };
#pod
#pod Declares a new class. The class can be either named or anonymous, depending on
#pod whether or not a classname is given. Within the class definition Moose and
#pod L<MooseX::Method::Signatures> are set up automatically in addition to the other
#pod keywords described in this document. At the end of the definition the class
#pod will be made immutable. namespace::autoclean is injected to clean up Moose and
#pod other imports for you.
#pod
#pod Because of the way the options are parsed, you cannot have a class named "is",
#pod "with" or "extends".
#pod
#pod It's possible to specify options for classes:
#pod
#pod =over 4
#pod
#pod =item extends
#pod
#pod class Foo extends Bar { ... }
#pod
#pod Sets a superclass for the class being declared.
#pod
#pod =item with
#pod
#pod class Foo with Role { ... }
#pod class Foo with Role1 with Role2 { ... }
#pod class Foo with (Role1, Role2) { ... }
#pod
#pod Applies a role or roles to the class being declared.
#pod
#pod =item is mutable
#pod
#pod class Foo is mutable { ... }
#pod
#pod Causes the class not to be made immutable after its definition.
#pod
#pod Options can also be provided for anonymous classes using the same syntax:
#pod
#pod my $meta_class = class with Role;
#pod
#pod =back
#pod
#pod =head2 role
#pod
#pod role Foo { ... }
#pod
#pod my $anon_role = role { ... };
#pod
#pod Declares a new role. The role can be either named or anonymous, depending on
#pod whether or not a name is given. Within the role definition Moose::Role and
#pod MooseX::Method::Signatures are set up automatically in addition to the other
#pod keywords described in this document. Again, namespace::autoclean is injected to
#pod clean up Moose::Role and other imports for you.
#pod
#pod It's possible to specify options for roles:
#pod
#pod =over 4
#pod
#pod =item with
#pod
#pod role Foo with Bar { ... }
#pod
#pod Applies a role to the role being declared.
#pod
#pod =back
#pod
#pod =head2 before / after / around / override / augment
#pod
#pod before foo ($x, $y, $z) { ... }
#pod after bar ($x, $y, $z) { ... }
#pod around baz ($x, $y, $z) { ... }
#pod override moo ($x, $y, $z) { ... }
#pod augment kuh ($x, $y, $z) { ... }
#pod
#pod Add a method modifier. Those work like documented in L<Moose|Moose>, except for
#pod the slightly nicer syntax and the method signatures, which work like documented
#pod in L<MooseX::Method::Signatures|MooseX::Method::Signatures>.
#pod
#pod For the C<around> modifier an additional argument called C<$orig> is
#pod automatically set up as the invocant for the method.
#pod
#pod =head2 clean
#pod
#pod Sometimes you don't want the automatic cleaning the C<class> and C<role>
#pod keywords provide using namespace::autoclean. In those cases you can specify the
#pod C<dirty> trait for your class or role:
#pod
#pod use MooseX::Declare;
#pod class Foo is dirty { ... }
#pod
#pod This will prevent cleaning of your namespace, except for the keywords imported
#pod from C<Moose> or C<Moose::Role>. Additionally, a C<clean> keyword is provided,
#pod which allows you to explicitly clean all functions that were defined prior to
#pod calling C<clean>. Here's an example:
#pod
#pod use MooseX::Declare;
#pod class Foo is dirty {
#pod sub helper_function { ... }
#pod clean;
#pod method foo ($stuff) { ...; return helper_function($stuff); }
#pod }
#pod
#pod With that, the helper function won't be available as a method to a user of your
#pod class, but you're still able to use it inside your class.
#pod
#pod =head1 NOTE ON IMPORTS
#pod
#pod When creating a class with MooseX::Declare like:
#pod
#pod use MooseX::Declare;
#pod class Foo { ... }
#pod
#pod What actually happens is something like this:
#pod
#pod {
#pod package Foo;
#pod use Moose;
#pod use namespace::autoclean;
#pod ...
#pod __PACKAGE__->meta->make_immutable;
#pod }
#pod
#pod So if you declare imports outside the class, the symbols get imported into the
#pod C<main::> namespace, not the class' namespace. The symbols then cannot be called
#pod from within the class:
#pod
#pod use MooseX::Declare;
#pod use Data::Dump qw/dump/;
#pod class Foo {
#pod method dump($value) { return dump($value) } # Data::Dump::dump IS NOT in Foo::
#pod method pp($value) { $self->dump($value) } # an alias for our dump method
#pod }
#pod
#pod To solve this, only import MooseX::Declare outside the class definition
#pod (because you have to). Make all other imports inside the class definition.
#pod
#pod use MooseX::Declare;
#pod class Foo {
#pod use Data::Dump qw/dump/;
#pod method dump($value) { return dump($value) } # Data::Dump::dump IS in Foo::
#pod method pp($value) { $self->dump($value) } # an alias for our dump method
#pod }
#pod
#pod Foo->new->dump($some_value);
#pod Foo->new->pp($some_value);
#pod
#pod B<NOTE> that the import C<Data::Dump::dump()> and the method C<Foo::dump()>,
#pod although having the same name, do not conflict with each other, because the
#pod imported C<dump> function will be cleaned during compile time, so only the
#pod method remains there at run time. If you want to do more esoteric things with
#pod imports, have a look at the C<clean> keyword and the C<dirty> trait.
#pod
#pod =head1 WARNING
#pod
#pod =for comment rafl agreed we should have a warning, and mst wrote this:
#pod
#pod B<Warning:> MooseX::Declare is based on L<Devel::Declare>, a giant bag of crack
#pod originally implemented by mst with the goal of upsetting the perl core
#pod developers so much by its very existence that they implemented proper
#pod keyword handling in the core.
#pod
#pod As of perl5 version 14, this goal has been achieved, and modules such
#pod as L<Devel::CallParser>, L<Function::Parameters>, and L<Keyword::Simple> provide
#pod mechanisms to mangle perl syntax that don't require hallucinogenic
#pod drugs to interpret the error messages they produce.
#pod
#pod If you want to use declarative syntax in new code, please for the love
#pod of kittens get yourself a recent perl and look at L<Moops> instead.
#pod
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<Moose>
#pod * L<Moose::Role>
#pod * L<MooseX::Method::Signatures>
#pod * L<namespace::autoclean>
#pod * vim syntax: L<http://www.vim.org/scripts/script.php?script_id=2526>
#pod * emacs syntax: L<http://github.com/jrockway/cperl-mode>
#pod * Geany syntax + notes: L<http://www.cattlegrid.info/blog/2009/09/moosex-declare-geany-syntax.html>
#pod * L<Devel::CallParser>
#pod * L<Function::Parameters>
#pod * L<Keyword::Simple>
#pod * L<Moops>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare - (DEPRECATED) Declarative syntax for Moose
=head1 VERSION
version 0.43
=head1 SYNOPSIS
use MooseX::Declare;
class BankAccount {
has 'balance' => ( isa => 'Num', is => 'rw', default => 0 );
method deposit (Num $amount) {
$self->balance( $self->balance + $amount );
}
method withdraw (Num $amount) {
my $current_balance = $self->balance();
( $current_balance >= $amount )
|| confess "Account overdrawn";
$self->balance( $current_balance - $amount );
}
}
class CheckingAccount extends BankAccount {
has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
before withdraw (Num $amount) {
my $overdraft_amount = $amount - $self->balance();
if ( $self->overdraft_account && $overdraft_amount > 0 ) {
$self->overdraft_account->withdraw($overdraft_amount);
$self->deposit($overdraft_amount);
}
}
}
=head1 DESCRIPTION
This module provides syntactic sugar for Moose, the postmodern object system
for Perl 5. When used, it sets up the C<class> and C<role> keywords.
B<Note:> Please see the L</WARNING> section below!
=head1 KEYWORDS
=head2 class
class Foo { ... }
my $anon_class = class { ... };
Declares a new class. The class can be either named or anonymous, depending on
whether or not a classname is given. Within the class definition Moose and
L<MooseX::Method::Signatures> are set up automatically in addition to the other
keywords described in this document. At the end of the definition the class
will be made immutable. namespace::autoclean is injected to clean up Moose and
other imports for you.
Because of the way the options are parsed, you cannot have a class named "is",
"with" or "extends".
It's possible to specify options for classes:
=over 4
=item extends
class Foo extends Bar { ... }
Sets a superclass for the class being declared.
=item with
class Foo with Role { ... }
class Foo with Role1 with Role2 { ... }
class Foo with (Role1, Role2) { ... }
Applies a role or roles to the class being declared.
=item is mutable
class Foo is mutable { ... }
Causes the class not to be made immutable after its definition.
Options can also be provided for anonymous classes using the same syntax:
my $meta_class = class with Role;
=back
=head2 role
role Foo { ... }
my $anon_role = role { ... };
Declares a new role. The role can be either named or anonymous, depending on
whether or not a name is given. Within the role definition Moose::Role and
MooseX::Method::Signatures are set up automatically in addition to the other
keywords described in this document. Again, namespace::autoclean is injected to
clean up Moose::Role and other imports for you.
It's possible to specify options for roles:
=over 4
=item with
role Foo with Bar { ... }
Applies a role to the role being declared.
=back
=head2 before / after / around / override / augment
before foo ($x, $y, $z) { ... }
after bar ($x, $y, $z) { ... }
around baz ($x, $y, $z) { ... }
override moo ($x, $y, $z) { ... }
augment kuh ($x, $y, $z) { ... }
Add a method modifier. Those work like documented in L<Moose|Moose>, except for
the slightly nicer syntax and the method signatures, which work like documented
in L<MooseX::Method::Signatures|MooseX::Method::Signatures>.
For the C<around> modifier an additional argument called C<$orig> is
automatically set up as the invocant for the method.
=head2 clean
Sometimes you don't want the automatic cleaning the C<class> and C<role>
keywords provide using namespace::autoclean. In those cases you can specify the
C<dirty> trait for your class or role:
use MooseX::Declare;
class Foo is dirty { ... }
This will prevent cleaning of your namespace, except for the keywords imported
from C<Moose> or C<Moose::Role>. Additionally, a C<clean> keyword is provided,
which allows you to explicitly clean all functions that were defined prior to
calling C<clean>. Here's an example:
use MooseX::Declare;
class Foo is dirty {
sub helper_function { ... }
clean;
method foo ($stuff) { ...; return helper_function($stuff); }
}
With that, the helper function won't be available as a method to a user of your
class, but you're still able to use it inside your class.
=head1 NOTE ON IMPORTS
When creating a class with MooseX::Declare like:
use MooseX::Declare;
class Foo { ... }
What actually happens is something like this:
{
package Foo;
use Moose;
use namespace::autoclean;
...
__PACKAGE__->meta->make_immutable;
}
So if you declare imports outside the class, the symbols get imported into the
C<main::> namespace, not the class' namespace. The symbols then cannot be called
from within the class:
use MooseX::Declare;
use Data::Dump qw/dump/;
class Foo {
method dump($value) { return dump($value) } # Data::Dump::dump IS NOT in Foo::
method pp($value) { $self->dump($value) } # an alias for our dump method
}
To solve this, only import MooseX::Declare outside the class definition
(because you have to). Make all other imports inside the class definition.
use MooseX::Declare;
class Foo {
use Data::Dump qw/dump/;
method dump($value) { return dump($value) } # Data::Dump::dump IS in Foo::
method pp($value) { $self->dump($value) } # an alias for our dump method
}
Foo->new->dump($some_value);
Foo->new->pp($some_value);
B<NOTE> that the import C<Data::Dump::dump()> and the method C<Foo::dump()>,
although having the same name, do not conflict with each other, because the
imported C<dump> function will be cleaned during compile time, so only the
method remains there at run time. If you want to do more esoteric things with
imports, have a look at the C<clean> keyword and the C<dirty> trait.
=head1 WARNING
=for comment rafl agreed we should have a warning, and mst wrote this:
B<Warning:> MooseX::Declare is based on L<Devel::Declare>, a giant bag of crack
originally implemented by mst with the goal of upsetting the perl core
developers so much by its very existence that they implemented proper
keyword handling in the core.
As of perl5 version 14, this goal has been achieved, and modules such
as L<Devel::CallParser>, L<Function::Parameters>, and L<Keyword::Simple> provide
mechanisms to mangle perl syntax that don't require hallucinogenic
drugs to interpret the error messages they produce.
If you want to use declarative syntax in new code, please for the love
of kittens get yourself a recent perl and look at L<Moops> instead.
=head1 SEE ALSO
=over 4
=item *
L<Moose>
=item *
L<Moose::Role>
=item *
L<MooseX::Method::Signatures>
=item *
L<namespace::autoclean>
=item *
vim syntax: L<http://www.vim.org/scripts/script.php?script_id=2526>
=item *
emacs syntax: L<http://github.com/jrockway/cperl-mode>
=item *
Geany syntax + notes: L<http://www.cattlegrid.info/blog/2009/09/moosex-declare-geany-syntax.html>
=item *
L<Devel::CallParser>
=item *
L<Function::Parameters>
=item *
L<Keyword::Simple>
=item *
L<Moops>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Piers Cawley Robert 'phaylon' Sedlacek Ash Berlin Nick Perez Nelo Onyiah Chas. J. Owens IV leedo Michele Beltrame Frank Wiegand David Steinbrunner Oleg Kostyuk Dave Rolsky Rafael Kitover Chris Prather Stevan Little Tomas Doran Yanick Champoux Justin Hunter
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Piers Cawley <pdcawley@bofh.org.uk>
=item *
Robert 'phaylon' Sedlacek <rs@474.at>
=item *
Ash Berlin <ash_github@firemirror.com>
=item *
Nick Perez <nperez@cpan.org>
=item *
Nelo Onyiah <nelo.onyiah@gmail.com>
=item *
Chas. J. Owens IV <chas.owens@gmail.com>
=item *
leedo <lee@laylward.com>
=item *
Michele Beltrame <arthas@cpan.org>
=item *
Frank Wiegand <fwie@cpan.org>
=item *
David Steinbrunner <dsteinbrunner@pobox.com>
=item *
Oleg Kostyuk <cub.uanic@gmail.com>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Rafael Kitover <rkitover@io.com>
=item *
Chris Prather <chris@prather.org>
=item *
Stevan Little <stevan.little@iinteractive.com>
=item *
Tomas Doran <bobtfish@bobtfish.net>
=item *
Yanick Champoux <yanick@babyl.dyndns.org>
=item *
Justin Hunter <justin.d.hunter@gmail.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,510 @@
package MooseX::Declare::Context;
# ABSTRACT: Per-keyword declaration context
our $VERSION = '0.43';
use Moose 0.90;
use Moose::Util::TypeConstraints qw(subtype as where);
use Carp qw/croak/;
use aliased 'Devel::Declare::Context::Simple', 'DDContext';
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This is not a subclass of L<Devel::Declare::Context::Simple>, but it will
#pod delegate all default methods and extend it with some attributes and methods
#pod of its own.
#pod
#pod A context object will be instantiated for every keyword that is handled by
#pod L<MooseX::Declare>. If handlers want to communicate with other handlers (for
#pod example handlers that will only be setup inside a namespace block) it must
#pod do this via the generated code.
#pod
#pod In addition to all the methods documented here, all methods from
#pod L<Devel::Declare::Context::Simple> are available and will be delegated to an
#pod internally stored instance of it.
#pod
#pod =type BlockCodePart
#pod
#pod An C<ArrayRef> with at least one element that stringifies to either C<BEGIN>
#pod or C<END>. The other parts will be stringified and used as the body for the
#pod generated block. An example would be this compiletime role composition:
#pod
#pod ['BEGIN', 'with q{ MyRole }']
#pod
#pod =cut
subtype 'MooseX::Declare::BlockCodePart',
as 'ArrayRef',
where { @$_ > 1 and sub { grep { $_[0] eq $_ } qw( BEGIN END ) } -> ($_->[0]) };
#pod =type CodePart
#pod
#pod A part of code represented by either a C<Str> or a L</BlockCodePart>.
#pod
#pod =cut
subtype 'MooseX::Declare::CodePart',
as 'Str|MooseX::Declare::BlockCodePart';
has _dd_context => (
is => 'ro',
isa => DDContext,
required => 1,
builder => '_build_dd_context',
lazy => 1,
handles => qr/.*/,
);
has _dd_init_args => (
is => 'rw',
isa => 'HashRef',
default => sub { {} },
required => 1,
);
has provided_by => (
is => 'ro',
isa => 'ClassName',
required => 1,
);
#pod =attr caller_file
#pod
#pod A required C<Str> containing the file the keyword was encountered in.
#pod
#pod =cut
has caller_file => (
is => 'rw',
isa => 'Str',
required => 1,
);
#pod =attr preamble_code_parts
#pod
#pod An C<ArrayRef> of L</CodePart>s that will be used as preamble. A preamble in
#pod this context means the beginning of the generated code.
#pod
#pod =method add_preamble_code_parts(CodePart @parts)
#pod
#pod Object->add_preamble_code_parts (CodeRef @parts)
#pod
#pod See L</add_cleanup_code_parts>.
#pod
#pod =cut
has preamble_code_parts => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef[MooseX::Declare::CodePart]',
required => 1,
default => sub { [] },
handles => {
add_preamble_code_parts => 'push',
},
);
#pod =attr scope_code_parts
#pod
#pod These parts will come before the actual body and after the
#pod L</preamble_code_parts>. It is an C<ArrayRef> of L</CodePart>s.
#pod
#pod =method add_scope_code_parts(CodePart @parts)
#pod
#pod Object->add_scope_code_parts (CodeRef @parts)
#pod
#pod See L</add_cleanup_code_parts>.
#pod
#pod =cut
has scope_code_parts => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef[MooseX::Declare::CodePart]',
required => 1,
default => sub { [] },
handles => {
add_scope_code_parts => 'push',
},
);
#pod =attr cleanup_code_parts
#pod
#pod An C<ArrayRef> of L</CodePart>s that will not be directly inserted
#pod into the code, but instead be installed in a handler that will run at
#pod the end of the scope so you can do namespace cleanups and such.
#pod
#pod =method add_cleanup_code_parts(CodePart @parts)
#pod
#pod Object->add_cleanup_code_parts (CodeRef @parts)
#pod
#pod For these three methods please look at the corresponding C<*_code_parts>
#pod attribute in the list above. These methods are merely convenience methods
#pod that allow adding entries to the code part containers.
#pod
#pod =cut
has cleanup_code_parts => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef[MooseX::Declare::CodePart]',
required => 1,
default => sub { [] },
handles => {
add_cleanup_code_parts => 'push',
add_early_cleanup_code_parts => 'unshift',
},
);
#pod =attr stack
#pod
#pod An C<ArrayRef> that contains the stack of handlers. A keyword that was
#pod only setup inside a scoped block will have the blockhandler be put in
#pod the stack.
#pod
#pod =cut
has stack => (
is => 'rw',
isa => 'ArrayRef',
default => sub { [] },
required => 1,
);
#pod =method inject_code_parts_here
#pod
#pod True Object->inject_code_parts_here (CodePart @parts)
#pod
#pod Will inject the passed L</CodePart>s at the current position in the code.
#pod
#pod =cut
sub inject_code_parts_here {
my ($self, @parts) = @_;
# get code to inject and rest of line
my $inject = $self->_joined_statements(\@parts);
my $linestr = $self->get_linestr;
# add code to inject to current line and inject it
substr($linestr, $self->offset, 0, "$inject");
$self->set_linestr($linestr);
return 1;
}
#pod =method peek_next_char
#pod
#pod Str Object->peek_next_char ()
#pod
#pod Will return the next char without stripping it from the stream.
#pod
#pod =cut
sub peek_next_char {
my ($self) = @_;
# return next char in line
my $linestr = $self->get_linestr;
return substr $linestr, $self->offset, 1;
}
sub peek_next_word {
my ($self) = @_;
$self->skipspace;
my $len = Devel::Declare::toke_scan_word($self->offset, 1);
return unless $len;
my $linestr = $self->get_linestr;
return substr($linestr, $self->offset, $len);
}
#pod =method inject_code_parts
#pod
#pod Object->inject_code_parts (
#pod Bool :$inject_cleanup_code_parts,
#pod CodeRef :$missing_block_handler
#pod )
#pod
#pod This will inject the code parts from the attributes above at the current
#pod position. The preamble and scope code parts will be inserted first. Then
#pod then call to the cleanup code will be injected, unless the options
#pod contain a key named C<inject_cleanup_code_parts> with a false value.
#pod
#pod The C<inject_if_block> method will be called if the next char is a C<{>
#pod indicating a following block.
#pod
#pod If it is not a block, but a semi-colon is found and the options
#pod contained a C<missing_block_handler> key was passed, it will be called
#pod as method on the context object with the code to inject and the
#pod options as arguments. All options that are not recognized are passed
#pod through to the C<missing_block_handler>. You are well advised to prefix
#pod option names in your extensions.
#pod
#pod =cut
sub inject_code_parts {
my ($self, %args) = @_;
# default to injecting cleanup code
$args{inject_cleanup_code_parts} = 1
unless exists $args{inject_cleanup_code_parts};
# add preamble and scope statements to injected code
my $inject;
$inject .= $self->_joined_statements('preamble');
$inject .= ';' . $self->_joined_statements('scope');
# if we should also inject the cleanup code
if ($args{inject_cleanup_code_parts}) {
$inject .= ';' . $self->scope_injector_call($self->_joined_statements('cleanup'));
}
$inject .= ';';
# we have a block
if ($self->peek_next_char eq '{') {
$self->inject_if_block("$inject");
}
# there was no block to inject into
else {
# require end of statement
croak "block or semi-colon expected after " . $self->declarator . " statement"
unless $self->peek_next_char eq ';';
# if we can't handle non-blocks, we expect one
croak "block expected after " . $self->declarator . " statement"
unless exists $args{missing_block_handler};
# delegate the processing of the missing block
$args{missing_block_handler}->($self, $inject, %args);
}
return 1;
}
sub _joined_statements {
my ($self, $section) = @_;
# if the section was not an array reference, get the
# section contents of that name
$section = $self->${\"${section}_code_parts"}
unless ref $section;
# join statements via semicolon
# array references are expected to be in the form [FOO => 1, 2, 3]
# which would yield BEGIN { 1; 2; 3 }
return join '; ', map {
not( ref $_ ) ? $_ : do {
my ($block, @parts) = @$_;
sprintf '%s { %s }', $block, join '; ', @parts;
};
} @{ $section };
}
sub BUILD {
my ($self, $attrs) = @_;
# remember the constructor arguments for the delegated context
$self->_dd_init_args($attrs);
}
sub _build_dd_context {
my ($self) = @_;
# create delegated context with remembered arguments
return DDContext->new(%{ $self->_dd_init_args });
}
sub strip_word {
my ($self) = @_;
$self->skipspace;
my $linestr = $self->get_linestr;
return if substr($linestr, $self->offset, 1) =~ /[{;]/;
# TODO:
# - provide a reserved_words attribute
# - allow keywords to consume reserved_words autodiscovery role
my $word = $self->peek_next_word;
return if !defined $word || $word =~ /^(?:extends|with|is)$/;
return scalar $self->strip_name;
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<Devel::Declare>
#pod * L<Devel::Declare::Context::Simple>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Context - Per-keyword declaration context
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This is not a subclass of L<Devel::Declare::Context::Simple>, but it will
delegate all default methods and extend it with some attributes and methods
of its own.
A context object will be instantiated for every keyword that is handled by
L<MooseX::Declare>. If handlers want to communicate with other handlers (for
example handlers that will only be setup inside a namespace block) it must
do this via the generated code.
In addition to all the methods documented here, all methods from
L<Devel::Declare::Context::Simple> are available and will be delegated to an
internally stored instance of it.
=head1 ATTRIBUTES
=head2 caller_file
A required C<Str> containing the file the keyword was encountered in.
=head2 preamble_code_parts
An C<ArrayRef> of L</CodePart>s that will be used as preamble. A preamble in
this context means the beginning of the generated code.
=head2 scope_code_parts
These parts will come before the actual body and after the
L</preamble_code_parts>. It is an C<ArrayRef> of L</CodePart>s.
=head2 cleanup_code_parts
An C<ArrayRef> of L</CodePart>s that will not be directly inserted
into the code, but instead be installed in a handler that will run at
the end of the scope so you can do namespace cleanups and such.
=head2 stack
An C<ArrayRef> that contains the stack of handlers. A keyword that was
only setup inside a scoped block will have the blockhandler be put in
the stack.
=head1 METHODS
=head2 add_preamble_code_parts(CodePart @parts)
Object->add_preamble_code_parts (CodeRef @parts)
See L</add_cleanup_code_parts>.
=head2 add_scope_code_parts(CodePart @parts)
Object->add_scope_code_parts (CodeRef @parts)
See L</add_cleanup_code_parts>.
=head2 add_cleanup_code_parts(CodePart @parts)
Object->add_cleanup_code_parts (CodeRef @parts)
For these three methods please look at the corresponding C<*_code_parts>
attribute in the list above. These methods are merely convenience methods
that allow adding entries to the code part containers.
=head2 inject_code_parts_here
True Object->inject_code_parts_here (CodePart @parts)
Will inject the passed L</CodePart>s at the current position in the code.
=head2 peek_next_char
Str Object->peek_next_char ()
Will return the next char without stripping it from the stream.
=head2 inject_code_parts
Object->inject_code_parts (
Bool :$inject_cleanup_code_parts,
CodeRef :$missing_block_handler
)
This will inject the code parts from the attributes above at the current
position. The preamble and scope code parts will be inserted first. Then
then call to the cleanup code will be injected, unless the options
contain a key named C<inject_cleanup_code_parts> with a false value.
The C<inject_if_block> method will be called if the next char is a C<{>
indicating a following block.
If it is not a block, but a semi-colon is found and the options
contained a C<missing_block_handler> key was passed, it will be called
as method on the context object with the code to inject and the
options as arguments. All options that are not recognized are passed
through to the C<missing_block_handler>. You are well advised to prefix
option names in your extensions.
=head1 TYPES
=head2 BlockCodePart
An C<ArrayRef> with at least one element that stringifies to either C<BEGIN>
or C<END>. The other parts will be stringified and used as the body for the
generated block. An example would be this compiletime role composition:
['BEGIN', 'with q{ MyRole }']
=head2 CodePart
A part of code represented by either a C<Str> or a L</BlockCodePart>.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<Devel::Declare>
=item *
L<Devel::Declare::Context::Simple>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,153 @@
package MooseX::Declare::Context::Namespaced;
# ABSTRACT: Namespaced context
our $VERSION = '0.43';
use Moose::Role;
use Carp qw( croak );
use MooseX::Declare::Util qw( outer_stack_peek );
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This context trait will add namespace functionality to the context.
#pod
#pod =attr namespace
#pod
#pod This will be set when the C<strip_namespace> method is called and the
#pod namespace wasn't anonymous. It will contain the specified namespace, not
#pod the fully qualified one.
#pod
#pod =cut
has namespace => (
is => 'rw',
isa => 'Str',
);
#pod =method strip_namespace
#pod
#pod Maybe[Str] Object->strip_namespace()
#pod
#pod This method is intended to parse the main namespace of a namespaced keyword.
#pod It will use L<Devel::Declare::Context::Simple>s C<strip_word> method and store
#pod the result in the L</namespace> attribute if true.
#pod
#pod =cut
sub strip_namespace {
my ($self) = @_;
my $namespace = $self->strip_word;
$self->namespace($namespace)
if defined $namespace and length $namespace;
return $namespace;
}
#pod =method qualify_namespace
#pod
#pod Str Object->qualify_namespace(Str $namespace)
#pod
#pod If the C<$namespace> passed it begins with a C<::>, it will be prefixed with
#pod the outer namespace in the file. If there is no outer namespace, an error
#pod will be thrown.
#pod
#pod =cut
sub qualify_namespace {
my ($self, $namespace) = @_;
# only qualify namespaces starting with ::
return $namespace
unless $namespace =~ /^::/;
# try to find the enclosing package
my $outer = outer_stack_peek($self->caller_file)
or croak "No outer namespace found to apply relative $namespace to";
return $outer . $namespace;
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Context>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Context::Namespaced - Namespaced context
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This context trait will add namespace functionality to the context.
=head1 ATTRIBUTES
=head2 namespace
This will be set when the C<strip_namespace> method is called and the
namespace wasn't anonymous. It will contain the specified namespace, not
the fully qualified one.
=head1 METHODS
=head2 strip_namespace
Maybe[Str] Object->strip_namespace()
This method is intended to parse the main namespace of a namespaced keyword.
It will use L<Devel::Declare::Context::Simple>s C<strip_word> method and store
the result in the L</namespace> attribute if true.
=head2 qualify_namespace
Str Object->qualify_namespace(Str $namespace)
If the C<$namespace> passed it begins with a C<::>, it will be prefixed with
the outer namespace in the file. If there is no outer namespace, an error
will be thrown.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Context>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,159 @@
package MooseX::Declare::Context::Parameterized;
# ABSTRACT: context for parsing optionally parameterized statements
our $VERSION = '0.43';
use Moose::Role;
use MooseX::Types::Moose qw/Str HashRef/;
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This context trait will add optional parameterization functionality to the
#pod context.
#pod
#pod =attr parameter_signature
#pod
#pod This will be set when the C<strip_parameter_signature> method is called and it
#pod was able to extract a list of parameterisations.
#pod
#pod =method has_parameter_signature
#pod
#pod Predicate method for the C<parameter_signature> attribute.
#pod
#pod =cut
has parameter_signature => (
is => 'rw',
isa => Str,
predicate => 'has_parameter_signature',
);
#pod =method add_parameter
#pod
#pod Allows storing parameters extracted from C<parameter_signature> to be used
#pod later on.
#pod
#pod =method get_parameters
#pod
#pod Returns all previously added parameters.
#pod
#pod =cut
has parameters => (
traits => ['Hash'],
isa => HashRef,
default => sub { {} },
handles => {
add_parameter => 'set',
get_parameters => 'kv',
},
);
#pod =method strip_parameter_signature
#pod
#pod Maybe[Str] Object->strip_parameter_signature()
#pod
#pod This method is intended to parse the main namespace of a namespaced keyword.
#pod It will use L<Devel::Declare::Context::Simple>s C<strip_word> method and store
#pod the result in the L</namespace> attribute if true.
#pod
#pod =cut
sub strip_parameter_signature {
my ($self) = @_;
my $signature = $self->strip_proto;
$self->parameter_signature($signature)
if defined $signature && length $signature;
return $signature;
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Context>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Context::Parameterized - context for parsing optionally parameterized statements
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This context trait will add optional parameterization functionality to the
context.
=head1 ATTRIBUTES
=head2 parameter_signature
This will be set when the C<strip_parameter_signature> method is called and it
was able to extract a list of parameterisations.
=head1 METHODS
=head2 has_parameter_signature
Predicate method for the C<parameter_signature> attribute.
=head2 add_parameter
Allows storing parameters extracted from C<parameter_signature> to be used
later on.
=head2 get_parameters
Returns all previously added parameters.
=head2 strip_parameter_signature
Maybe[Str] Object->strip_parameter_signature()
This method is intended to parse the main namespace of a namespaced keyword.
It will use L<Devel::Declare::Context::Simple>s C<strip_word> method and store
the result in the L</namespace> attribute if true.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Context>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,70 @@
package # hide from PAUSE
MooseX::Declare::Context::WithOptions;
our $VERSION = '0.43';
use Moose::Role;
use Carp qw/croak/;
use MooseX::Types::Moose 0.20 qw/HashRef/;
use namespace::autoclean;
has options => (
is => 'rw',
isa => HashRef,
default => sub { {} },
lazy => 1,
);
sub strip_options {
my ($self) = @_;
my %ret;
# Make errors get reported from right place in source file
local $Carp::Internal{'MooseX::Declare'} = 1;
local $Carp::Internal{'Devel::Declare'} = 1;
$self->skipspace;
my $linestr = $self->get_linestr;
while (substr($linestr, $self->offset, 1) !~ /[{;]/) {
my $key = $self->strip_name;
if (!defined $key) {
croak 'expected option name'
if keys %ret;
return; # This is the case when { class => 'foo' } happens
}
croak "unknown option name '$key'"
unless $key =~ /^(extends|with|is)$/;
my $val = $self->strip_name;
if (!defined $val) {
if (defined($val = $self->strip_proto)) {
$val = [split /\s*,\s*/, $val];
}
else {
croak "expected option value after $key";
}
}
$ret{$key} ||= [];
push @{ $ret{$key} }, ref $val ? @{ $val } : $val;
} continue {
$self->skipspace;
$linestr = $self->get_linestr();
}
my $options = { map {
my $key = $_;
$key eq 'is'
? ($key => { map { ($_ => 1) } @{ $ret{$key} } })
: ($key => $ret{$key})
} keys %ret };
$self->options($options);
return $options;
}
1;

View File

@@ -0,0 +1,59 @@
package # hide from PAUSE
MooseX::Declare::StackItem;
our $VERSION = '0.43';
use Moose;
use namespace::autoclean;
use overload '""' => 'as_string', fallback => 1;
has identifier => (
is => 'rw',
isa => 'Str',
required => 1,
);
has handler => (
is => 'ro',
required => 1,
default => '',
);
has is_dirty => (
is => 'ro',
isa => 'Bool',
);
has is_parameterized => (
is => 'ro',
isa => 'Bool',
);
has namespace => (
is => 'ro',
isa => 'Str|Undef',
);
sub as_string {
my ($self) = @_;
return $self->identifier;
}
sub serialize {
my ($self) = @_;
return sprintf '%s->new(%s)',
ref($self),
join ', ', map { defined($_) ? "q($_)" : 'undef' }
'identifier', $self->identifier,
'handler', $self->handler,
'is_dirty', ( $self->is_dirty ? 1 : 0 ),
'is_parameterized', ( $self->is_parameterized ? 1 : 0 ),
'namespace', $self->namespace,
;
}
__PACKAGE__->meta->make_immutable;
1;

View File

@@ -0,0 +1,95 @@
package MooseX::Declare::Syntax::EmptyBlockIfMissing;
# ABSTRACT: Handle missing blocks after keywords
our $VERSION = '0.43';
use Moose::Role;
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod The L<MooseX::Declare::Syntax::NamespaceHandling> role will require that the
#pod consumer handles the case of non-existent blocks. This role will inject
#pod an empty block with only the generated code parts in it.
#pod
#pod =method handle_missing_block
#pod
#pod Object->handle_missing_block (Object $context, Str $body, %args)
#pod
#pod This will inject the generated code surrounded by C<{ ... }> into the code
#pod where the keyword was called.
#pod
#pod =cut
sub handle_missing_block {
my ($self, $ctx, $inject, %args) = @_;
# default to block with nothing more than the default contents
$ctx->inject_code_parts_here("{ $inject }");
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::NamespaceHandling>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::EmptyBlockIfMissing - Handle missing blocks after keywords
=head1 VERSION
version 0.43
=head1 DESCRIPTION
The L<MooseX::Declare::Syntax::NamespaceHandling> role will require that the
consumer handles the case of non-existent blocks. This role will inject
an empty block with only the generated code parts in it.
=head1 METHODS
=head2 handle_missing_block
Object->handle_missing_block (Object $context, Str $body, %args)
This will inject the generated code surrounded by C<{ ... }> into the code
where the keyword was called.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::NamespaceHandling>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,138 @@
package MooseX::Declare::Syntax::Extending;
# ABSTRACT: Extending with superclasses
our $VERSION = '0.43';
use Moose::Role;
use aliased 'MooseX::Declare::Context::Namespaced';
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod Extends a class by a specified C<extends> option.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::OptionHandling>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::OptionHandling
);
around context_traits => sub { shift->(@_), Namespaced };
#pod =method add_extends_option_customizations
#pod
#pod Object->add_extends_option_customizations (
#pod Object $ctx,
#pod Str $package,
#pod ArrayRef $superclasses,
#pod HashRef $options
#pod )
#pod
#pod This will add a code part that will call C<extends> with the C<$superclasses>
#pod as arguments.
#pod
#pod =cut
sub add_extends_option_customizations {
my ($self, $ctx, $package, $superclasses) = @_;
# add code for extends keyword
$ctx->add_scope_code_parts(
sprintf 'extends %s',
join ', ',
map { "'$_'" }
map { $ctx->qualify_namespace($_) }
@{ $superclasses },
);
return 1;
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::Keyword::Class>
#pod * L<MooseX::Declare::Syntax::OptionHandling>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Extending - Extending with superclasses
=head1 VERSION
version 0.43
=head1 DESCRIPTION
Extends a class by a specified C<extends> option.
=head1 METHODS
=head2 add_extends_option_customizations
Object->add_extends_option_customizations (
Object $ctx,
Str $package,
ArrayRef $superclasses,
HashRef $options
)
This will add a code part that will call C<extends> with the C<$superclasses>
as arguments.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::OptionHandling>
=back
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::Keyword::Class>
=item *
L<MooseX::Declare::Syntax::OptionHandling>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,174 @@
package MooseX::Declare::Syntax::InnerSyntaxHandling;
# ABSTRACT: Keywords inside blocks
our $VERSION = '0.43';
use Moose::Role;
use MooseX::Declare::Util qw( outer_stack_push );
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This role allows you to setup keyword handlers that are only available
#pod inside blocks or other scoping environments.
#pod
#pod =head1 REQUIRED METHODS
#pod
#pod =head2 get_identifier
#pod
#pod Str get_identifier ()
#pod
#pod Required to return the name of the identifier of the current handler.
#pod
#pod =cut
requires qw(
get_identifier
);
#pod =method default_inner
#pod
#pod ArrayRef[Object] Object->default_inner ()
#pod
#pod Returns an empty C<ArrayRef> by default. If you want to setup additional
#pod keywords you will have to C<around> this method.
#pod
#pod =cut
sub default_inner { [] }
#pod =head1 MODIFIED METHODS
#pod
#pod =head2 setup_for
#pod
#pod Object->setup_for(ClassName $class, %args)
#pod
#pod After the keyword is setup inside itself, this will call L</setup_inner_for>.
#pod
#pod =cut
after setup_for => sub {
my ($self, $setup_class, %args) = @_;
# make sure stack is valid
my $stack = $args{stack} || [];
# setup inner keywords if we're inside ourself
if (grep { $_ eq $self->get_identifier } @$stack) {
$self->setup_inner_for($setup_class, %args);
}
};
#pod =method setup_inner_for
#pod
#pod Object->setup_inner_for(ClassName $class, %args)
#pod
#pod Sets up all handlers in the inner class.
#pod
#pod =cut
sub setup_inner_for {
my ($self, $setup_class, %args) = @_;
# setup each keyword in target class
for my $inner (@{ $self->default_inner($args{stack}) }) {
$inner->setup_for($setup_class, %args);
}
# push package onto stack for namespace management
if (exists $args{file}) {
outer_stack_push $args{file}, $args{outer_package};
}
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::NamespaceHandling>
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::InnerSyntaxHandling - Keywords inside blocks
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This role allows you to setup keyword handlers that are only available
inside blocks or other scoping environments.
=head1 METHODS
=head2 default_inner
ArrayRef[Object] Object->default_inner ()
Returns an empty C<ArrayRef> by default. If you want to setup additional
keywords you will have to C<around> this method.
=head2 setup_inner_for
Object->setup_inner_for(ClassName $class, %args)
Sets up all handlers in the inner class.
=head1 REQUIRED METHODS
=head2 get_identifier
Str get_identifier ()
Required to return the name of the identifier of the current handler.
=head1 MODIFIED METHODS
=head2 setup_for
Object->setup_for(ClassName $class, %args)
After the keyword is setup inside itself, this will call L</setup_inner_for>.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::NamespaceHandling>
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,179 @@
package MooseX::Declare::Syntax::Keyword::Class;
# ABSTRACT: Class declarations
our $VERSION = '0.43';
use Moose;
use namespace::autoclean;
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod * L<MooseX::Declare::Syntax::RoleApplication>
#pod * L<MooseX::Declare::Syntax::Extending>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::MooseSetup
MooseX::Declare::Syntax::RoleApplication
MooseX::Declare::Syntax::Extending
);
#pod =head1 MODIFIED METHODS
#pod
#pod =head2 imported_moose_symbols
#pod
#pod List Object->imported_moose_symbols ()
#pod
#pod Extends the existing L<MooseX::Declare::Syntax::MooseSetup/imported_moose_symbols>
#pod with C<extends>, C<has>, C<inner> and C<super>.
#pod
#pod =cut
around imported_moose_symbols => sub { shift->(@_), qw( extends has inner super ) };
#pod =method generate_export
#pod
#pod CodeRef generate_export ()
#pod
#pod This will return a closure doing a call to L</make_anon_metaclass>.
#pod
#pod =cut
sub generate_export { my $self = shift; sub { $self->make_anon_metaclass } }
#pod =head2 auto_make_immutable
#pod
#pod Bool Object->auto_make_immutable ()
#pod
#pod Is set to a true value, so classes are made immutable by default.
#pod
#pod =cut
around auto_make_immutable => sub { 1 };
#pod =head2 make_anon_metaclass
#pod
#pod Object Object->make_anon_metaclass ()
#pod
#pod Returns an anonymous instance of L<Moose::Meta::Class>.
#pod
#pod =cut
around make_anon_metaclass => sub { Moose::Meta::Class->create_anon_class };
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::Keyword::Role>
#pod * L<MooseX::Declare::Syntax::RoleApplication>
#pod * L<MooseX::Declare::Syntax::Extending>
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Keyword::Class - Class declarations
=head1 VERSION
version 0.43
=head1 METHODS
=head2 generate_export
CodeRef generate_export ()
This will return a closure doing a call to L</make_anon_metaclass>.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=item *
L<MooseX::Declare::Syntax::RoleApplication>
=item *
L<MooseX::Declare::Syntax::Extending>
=back
=head1 MODIFIED METHODS
=head2 imported_moose_symbols
List Object->imported_moose_symbols ()
Extends the existing L<MooseX::Declare::Syntax::MooseSetup/imported_moose_symbols>
with C<extends>, C<has>, C<inner> and C<super>.
=head2 auto_make_immutable
Bool Object->auto_make_immutable ()
Is set to a true value, so classes are made immutable by default.
=head2 make_anon_metaclass
Object Object->make_anon_metaclass ()
Returns an anonymous instance of L<Moose::Meta::Class>.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::Keyword::Role>
=item *
L<MooseX::Declare::Syntax::RoleApplication>
=item *
L<MooseX::Declare::Syntax::Extending>
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,136 @@
package MooseX::Declare::Syntax::Keyword::Clean;
# ABSTRACT: Explicit namespace cleanups
our $VERSION = '0.43';
use Moose;
use constant NAMESPACING_ROLE => 'MooseX::Declare::Syntax::NamespaceHandling';
use Carp qw( cluck );
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This keyword will inject a call to L<namespace::clean> into its current
#pod position.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::KeywordHandling>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::KeywordHandling
);
sub find_namespace_handler {
my ($self, $ctx) = @_;
for my $item (reverse @{ $ctx->stack }) {
return $item
if $item->handler->does(NAMESPACING_ROLE);
}
return undef;
}
#pod =method parse
#pod
#pod Object->parse(Object $context)
#pod
#pod This will inject a call to L<namespace::clean> C<< -except => 'meta' >> into
#pod the code at the position of the keyword.
#pod
#pod =cut
sub parse {
my ($self, $ctx) = @_;
if (my $stack_item = $self->find_namespace_handler($ctx)) {
my $namespace = $stack_item->namespace;
cluck "Attempted to clean an already cleaned namespace ($namespace). Did you mean to use 'is dirty'?"
unless $stack_item->is_dirty;
}
$ctx->skip_declarator;
$ctx->inject_code_parts_here(
';use namespace::clean -except => [qw( meta )]',
);
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::KeywordHandling>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Keyword::Clean - Explicit namespace cleanups
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This keyword will inject a call to L<namespace::clean> into its current
position.
=head1 METHODS
=head2 parse
Object->parse(Object $context)
This will inject a call to L<namespace::clean> C<< -except => 'meta' >> into
the code at the position of the keyword.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::KeywordHandling>
=back
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::KeywordHandling>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,146 @@
package MooseX::Declare::Syntax::Keyword::Method;
# ABSTRACT: Handle method declarations
our $VERSION = '0.43';
use Moose;
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This role is an extension of L<MooseX::Declare::Syntax::MethodDeclaration>
#pod that allows you to install keywords that declare methods.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::MethodDeclaration>
#pod
#pod =cut
with 'MooseX::Declare::Syntax::MethodDeclaration';
#pod =method register_method_declaration
#pod
#pod Object->register_method_declaration (Object $metaclass, Str $name, Object $method)
#pod
#pod This method required by the method declaration role will register the finished
#pod method object via the C<< $metaclass->add_method >> method.
#pod
#pod MethodModifier->new(
#pod identifier => 'around',
#pod modifier_type => 'around',
#pod prototype_injections => {
#pod declarator => 'around',
#pod injections => [ 'CodeRef $orig' ],
#pod },
#pod );
#pod
#pod This will mean that the signature C<(Str $foo)> will become
#pod C<CodeRef $orig: Object $self, Str $foo> and C<()> will become
#pod C<CodeRef $orig: Object $self>.
#pod
#pod =cut
sub register_method_declaration {
my ($self, $meta, $name, $method) = @_;
return $meta->add_method($name, $method);
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod * L<MooseX::Declare::Syntax::MethodDeclaration>
#pod * L<MooseX::Method::Signatures>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Keyword::Method - Handle method declarations
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This role is an extension of L<MooseX::Declare::Syntax::MethodDeclaration>
that allows you to install keywords that declare methods.
=head1 METHODS
=head2 register_method_declaration
Object->register_method_declaration (Object $metaclass, Str $name, Object $method)
This method required by the method declaration role will register the finished
method object via the C<< $metaclass->add_method >> method.
MethodModifier->new(
identifier => 'around',
modifier_type => 'around',
prototype_injections => {
declarator => 'around',
injections => [ 'CodeRef $orig' ],
},
);
This will mean that the signature C<(Str $foo)> will become
C<CodeRef $orig: Object $self, Str $foo> and C<()> will become
C<CodeRef $orig: Object $self>.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::MethodDeclaration>
=back
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=item *
L<MooseX::Declare::Syntax::MethodDeclaration>
=item *
L<MooseX::Method::Signatures>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,173 @@
package MooseX::Declare::Syntax::Keyword::MethodModifier;
# ABSTRACT: Handle method modifier declarations
our $VERSION = '0.43';
use Moose;
use Moose::Util;
use Moose::Util::TypeConstraints 'enum';
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod Allows the implementation of method modification handlers like C<around> and
#pod C<before>.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::MethodDeclaration>
#pod
#pod =cut
with 'MooseX::Declare::Syntax::MethodDeclaration';
#pod =attr modifier_type
#pod
#pod A required string that is one of:
#pod
#pod =for :list
#pod * around
#pod * after
#pod * before
#pod * override
#pod * augment
#pod
#pod =cut
has modifier_type => (
is => 'rw',
isa => enum([qw( around after before override augment )]),
required => 1,
);
#pod =method register_method_declaration
#pod
#pod Object->register_method_declaration (Object $metaclass, Str $name, Object $method)
#pod
#pod This will add the method modifier to the C<$metaclass> via L<Moose::Util>s
#pod C<add_method_modifier>, whose return value will also be returned from this
#pod method.
#pod
#pod =cut
sub register_method_declaration {
my ($self, $meta, $name, $method) = @_;
return Moose::Util::add_method_modifier($meta->name, $self->modifier_type, [$name, $method->body]);
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod * L<MooseX::Declare::Syntax::MethodDeclaration>
#pod * L<MooseX::Method::Signatures>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Keyword::MethodModifier - Handle method modifier declarations
=head1 VERSION
version 0.43
=head1 DESCRIPTION
Allows the implementation of method modification handlers like C<around> and
C<before>.
=head1 ATTRIBUTES
=head2 modifier_type
A required string that is one of:
=over 4
=item *
around
=item *
after
=item *
before
=item *
override
=item *
augment
=back
=head1 METHODS
=head2 register_method_declaration
Object->register_method_declaration (Object $metaclass, Str $name, Object $method)
This will add the method modifier to the C<$metaclass> via L<Moose::Util>s
C<add_method_modifier>, whose return value will also be returned from this
method.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::MethodDeclaration>
=back
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=item *
L<MooseX::Declare::Syntax::MethodDeclaration>
=item *
L<MooseX::Method::Signatures>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,160 @@
package MooseX::Declare::Syntax::Keyword::Namespace;
# ABSTRACT: Declare outer namespace
our $VERSION = '0.43';
use Moose;
use Carp qw( confess );
use MooseX::Declare::Util qw( outer_stack_push outer_stack_peek );
use namespace::autoclean;
#pod =head1 SYNOPSIS
#pod
#pod use MooseX::Declare;
#pod
#pod namespace Foo::Bar;
#pod
#pod class ::Baz extends ::Qux with ::Fnording {
#pod ...
#pod }
#pod
#pod =head1 DESCRIPTION
#pod
#pod The C<namespace> keyword allows you to declare an outer namespace under
#pod which other namespaced constructs can be nested. The L</SYNOPSIS> is
#pod effectively the same as
#pod
#pod use MooseX::Declare;
#pod
#pod class Foo::Bar::Baz extends Foo::Bar::Qux with Foo::Bar::Fnording {
#pod ...
#pod }
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::KeywordHandling>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::KeywordHandling
);
#pod =method parse
#pod
#pod Object->parse(Object $context)
#pod
#pod Will skip the declarator, parse the namespace and push the namespace
#pod in the file package stack.
#pod
#pod =cut
sub parse {
my ($self, $ctx) = @_;
confess "Nested namespaces are not supported yet"
if outer_stack_peek $ctx->caller_file;
$ctx->skip_declarator;
my $namespace = $ctx->strip_word
or confess "Expected a namespace argument to use from here on";
confess "Relative namespaces are currently not supported"
if $namespace =~ /^::/;
$ctx->skipspace;
my $next_char = $ctx->peek_next_char;
confess "Expected end of statement after namespace argument"
unless $next_char eq ';';
outer_stack_push $ctx->caller_file, $namespace;
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Keyword::Namespace - Declare outer namespace
=head1 VERSION
version 0.43
=head1 SYNOPSIS
use MooseX::Declare;
namespace Foo::Bar;
class ::Baz extends ::Qux with ::Fnording {
...
}
=head1 DESCRIPTION
The C<namespace> keyword allows you to declare an outer namespace under
which other namespaced constructs can be nested. The L</SYNOPSIS> is
effectively the same as
use MooseX::Declare;
class Foo::Bar::Baz extends Foo::Bar::Qux with Foo::Bar::Fnording {
...
}
=head1 METHODS
=head2 parse
Object->parse(Object $context)
Will skip the declarator, parse the namespace and push the namespace
in the file package stack.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::KeywordHandling>
=back
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,256 @@
package MooseX::Declare::Syntax::Keyword::Role;
# ABSTRACT: Role declarations
our $VERSION = '0.43';
use Moose;
use Moose::Util qw(does_role find_meta);
use aliased 'Parse::Method::Signatures' => 'PMS';
use aliased 'MooseX::Declare::Syntax::MethodDeclaration';
use aliased 'Parse::Method::Signatures::Param::Placeholder';
use aliased 'MooseX::Declare::Context::Parameterized', 'ParameterizedCtx';
use aliased 'MooseX::Declare::Syntax::MethodDeclaration::Parameterized', 'ParameterizedMethod';
use namespace::autoclean;
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod * L<MooseX::Declare::Syntax::RoleApplication>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::MooseSetup
MooseX::Declare::Syntax::RoleApplication
);
#pod =head1 MODIFIED METHODS
#pod
#pod =head2 imported_moose_symbols
#pod
#pod List Object->imported_moose_symbols ()
#pod
#pod Extends the existing L<MooseX::Declare::Syntax::MooseSetup/imported_moose_symbols>
#pod with C<requires>, C<extends>, C<has>, C<inner> and C<super>.
#pod
#pod =cut
around imported_moose_symbols => sub { shift->(@_), qw( requires excludes extends has inner super ) };
#pod =head2 import_symbols_from
#pod
#pod Str Object->import_symbols_from ()
#pod
#pod Will return L<Moose::Role> instead of the default L<Moose>.
#pod
#pod =cut
around import_symbols_from => sub {
my ($next, $self, $ctx) = @_;
return $ctx->has_parameter_signature
? 'MooseX::Role::Parameterized'
: 'Moose::Role';
};
#pod =head2 make_anon_metaclass
#pod
#pod Object Object->make_anon_metaclass ()
#pod
#pod This will return an anonymous instance of L<Moose::Meta::Role>.
#pod
#pod =cut
around make_anon_metaclass => sub { Moose::Meta::Role->create_anon_role };
around context_traits => sub { shift->(@_), ParameterizedCtx };
around default_inner => sub {
my ($next, $self, $stack) = @_;
my $inner = $self->$next;
return $inner
if !@{ $stack || [] } || !$stack->[-1]->is_parameterized;
ParameterizedMethod->meta->apply($_)
for grep { does_role($_, MethodDeclaration) } @{ $inner };
return $inner;
};
#pod =method generate_export
#pod
#pod CodeRef Object->generate_export ()
#pod
#pod Returns a closure with a call to L</make_anon_metaclass>.
#pod
#pod =cut
sub generate_export { my $self = shift; sub { $self->make_anon_metaclass } }
after parse_namespace_specification => sub {
my ($self, $ctx) = @_;
$ctx->strip_parameter_signature;
};
after add_namespace_customizations => sub {
my ($self, $ctx, $package, $options) = @_;
$self->add_parameterized_customizations($ctx, $package, $options)
if $ctx->has_parameter_signature;
};
sub add_parameterized_customizations {
my ($self, $ctx, $package, $options) = @_;
my $sig = PMS->signature(
input => "(${\$ctx->parameter_signature})",
from_namespace => $ctx->get_curstash_name,
);
confess 'Positional parameters are not allowed in parameterized roles'
if $sig->has_positional_params;
my @vars = map {
does_role($_, Placeholder)
? ()
: {
var => $_->variable_name,
name => $_->label,
tc => $_->meta_type_constraint,
($_->has_default_value
? (default => $_->default_value)
: ()),
},
} $sig->named_params;
$ctx->add_preamble_code_parts(
sprintf 'my (%s) = map { $_[0]->$_ } qw(%s);',
join(',', map { $_->{var} } @vars),
join(' ', map { $_->{name} } @vars),
);
for my $var (@vars) {
$ctx->add_parameter($var->{name} => {
is => 'ro',
isa => $var->{tc},
(exists $var->{default}
? (default => sub { eval $var->{default} })
: ()),
});
}
}
after handle_post_parsing => sub {
my ($self, $ctx, $package, $class) = @_;
return unless $ctx->has_parameter_signature;
$ctx->shadow(sub (&) {
my $meta = find_meta($class);
$meta->add_parameter($_->[0], %{ $_->[1] })
for $ctx->get_parameters;
$meta->role_generator($_[0]);
return $class;
});
};
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::Keyword::Class>
#pod * L<MooseX::Declare::Syntax::RoleApplication>
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Keyword::Role - Role declarations
=head1 VERSION
version 0.43
=head1 METHODS
=head2 generate_export
CodeRef Object->generate_export ()
Returns a closure with a call to L</make_anon_metaclass>.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=item *
L<MooseX::Declare::Syntax::RoleApplication>
=back
=head1 MODIFIED METHODS
=head2 imported_moose_symbols
List Object->imported_moose_symbols ()
Extends the existing L<MooseX::Declare::Syntax::MooseSetup/imported_moose_symbols>
with C<requires>, C<extends>, C<has>, C<inner> and C<super>.
=head2 import_symbols_from
Str Object->import_symbols_from ()
Will return L<Moose::Role> instead of the default L<Moose>.
=head2 make_anon_metaclass
Object Object->make_anon_metaclass ()
This will return an anonymous instance of L<Moose::Meta::Role>.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::Keyword::Class>
=item *
L<MooseX::Declare::Syntax::RoleApplication>
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,153 @@
package MooseX::Declare::Syntax::Keyword::With;
# ABSTRACT: Apply roles within a class- or role-body
our $VERSION = '0.43';
use Moose;
use Moose::Util;
use MooseX::Declare::Util qw( outer_stack_peek );
use aliased 'MooseX::Declare::Context::Namespaced';
use namespace::autoclean;
#pod =head1 SYNOPSIS
#pod
#pod use MooseX::Declare;
#pod
#pod class ::Baz {
#pod with 'Qux';
#pod ...
#pod }
#pod
#pod =head1 DESCRIPTION
#pod
#pod The C<with> keyword allows you to apply roles to the local class or role. It
#pod differs from the C<with>-option of the C<class> and C<role> keywords in that it
#pod applies the roles immediately instead of deferring application until the end of
#pod the class- or role-definition.
#pod
#pod It also differs slightly from the C<with> provided by L<Moose|Moose> in that it
#pod expands relative role names (C<::Foo>) according to the current C<namespace>.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::KeywordHandling>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::KeywordHandling
);
around context_traits => sub { shift->(@_), Namespaced };
#pod =method parse
#pod
#pod Object->parse(Object $context)
#pod
#pod Will skip the declarator and make with C<with> invocation apply the set of
#pod specified roles after possible C<namespace>-expanding has been done.
#pod
#pod =cut
sub parse {
my ($self, $ctx) = @_;
$ctx->skip_declarator;
my $pkg = outer_stack_peek $ctx->caller_file;
$ctx->shadow(sub {
Moose::Util::apply_all_roles($pkg, map {
$ctx->qualify_namespace($_)
} @_);
});
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::Keyword::Namespace>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::Keyword::With - Apply roles within a class- or role-body
=head1 VERSION
version 0.43
=head1 SYNOPSIS
use MooseX::Declare;
class ::Baz {
with 'Qux';
...
}
=head1 DESCRIPTION
The C<with> keyword allows you to apply roles to the local class or role. It
differs from the C<with>-option of the C<class> and C<role> keywords in that it
applies the roles immediately instead of deferring application until the end of
the class- or role-definition.
It also differs slightly from the C<with> provided by L<Moose|Moose> in that it
expands relative role names (C<::Foo>) according to the current C<namespace>.
=head1 METHODS
=head2 parse
Object->parse(Object $context)
Will skip the declarator and make with C<with> invocation apply the set of
specified roles after possible C<namespace>-expanding has been done.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::KeywordHandling>
=back
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::Keyword::Namespace>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,240 @@
package MooseX::Declare::Syntax::KeywordHandling;
# ABSTRACT: Basic keyword functionality
our $VERSION = '0.43';
use Moose::Role;
use Moose::Util::TypeConstraints qw(subtype as where);
use Devel::Declare ();
use Sub::Install qw( install_sub );
use Moose::Meta::Class ();
use Module::Runtime 'use_module';
use aliased 'MooseX::Declare::Context';
use namespace::autoclean -also => ['_uniq'];
#pod =head1 DESCRIPTION
#pod
#pod This role provides the functionality common for all keyword handlers
#pod in L<MooseX::Declare>.
#pod
#pod =head1 REQUIRED METHODS
#pod
#pod =head2 parse
#pod
#pod Object->parse (Object $context)
#pod
#pod This method must implement the actual parsing of the keyword syntax.
#pod
#pod =cut
requires qw(
parse
);
#pod =attr identifier
#pod
#pod This is the name of the actual keyword. It is a required string that is in
#pod the same format as a usual Perl identifier.
#pod
#pod =cut
has identifier => (
is => 'ro',
isa => subtype(as 'Str', where { /^ [_a-z] [_a-z0-9]* $/ix }),
required => 1,
);
#pod =method get_identifier
#pod
#pod Str Object->get_identifier ()
#pod
#pod Returns the name the handler will be setup under.
#pod
#pod =cut
sub get_identifier { shift->identifier }
sub context_class { Context }
sub context_traits { }
#pod =method setup_for
#pod
#pod Object->setup_for (ClassName $class, %args)
#pod
#pod This will setup the handler in the specified C<$class>. The handler will
#pod dispatch to the L</parse_declaration> method when the keyword is used.
#pod
#pod A normal code reference will also be exported into the calling namespace.
#pod It will either be empty or, if a C<generate_export> method is provided,
#pod the return value of that method.
#pod
#pod =cut
sub setup_for {
my ($self, $setup_class, %args) = @_;
# make sure the stack is valid
my $stack = $args{stack} || [];
my $ident = $self->get_identifier;
# setup the D:D handler for our keyword
Devel::Declare->setup_for($setup_class, {
$ident => {
const => sub { $self->parse_declaration((caller(1))[1], \%args, @_) },
},
});
# search or generate a real export
my $export = $self->can('generate_export') ? $self->generate_export($setup_class) : sub { };
# export subroutine
install_sub({
code => $export,
into => $setup_class,
as => $ident,
}) unless $setup_class->can($ident);
return 1;
}
#pod =method parse_declaration
#pod
#pod Object->parse_declaration (Str $filename, HashRef $setup_args, @call_args)
#pod
#pod This simply creates a new L<context|MooseX::Declare::Context> and passes it
#pod to the L</parse> method.
#pod
#pod =cut
sub parse_declaration {
my ($self, $caller_file, $args, @ctx_args) = @_;
# find and load context object class
my $ctx_class = $self->context_class;
use_module $ctx_class;
# do we have traits?
if (my @ctx_traits = _uniq($self->context_traits)) {
use_module $_
for @ctx_traits;
$ctx_class = Moose::Meta::Class->create_anon_class(
superclasses => [$ctx_class],
roles => [@ctx_traits],
cache => 1,
)->name;
}
# create a context object and initialize it
my $ctx = $ctx_class->new(
%{ $args },
caller_file => $caller_file,
);
$ctx->init(@ctx_args);
# parse with current context
return $self->parse($ctx);
}
sub _uniq { keys %{ +{ map { $_ => undef } @_ } } }
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Context>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::KeywordHandling - Basic keyword functionality
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This role provides the functionality common for all keyword handlers
in L<MooseX::Declare>.
=head1 ATTRIBUTES
=head2 identifier
This is the name of the actual keyword. It is a required string that is in
the same format as a usual Perl identifier.
=head1 METHODS
=head2 get_identifier
Str Object->get_identifier ()
Returns the name the handler will be setup under.
=head2 setup_for
Object->setup_for (ClassName $class, %args)
This will setup the handler in the specified C<$class>. The handler will
dispatch to the L</parse_declaration> method when the keyword is used.
A normal code reference will also be exported into the calling namespace.
It will either be empty or, if a C<generate_export> method is provided,
the return value of that method.
=head2 parse_declaration
Object->parse_declaration (Str $filename, HashRef $setup_args, @call_args)
This simply creates a new L<context|MooseX::Declare::Context> and passes it
to the L</parse> method.
=head1 REQUIRED METHODS
=head2 parse
Object->parse (Object $context)
This method must implement the actual parsing of the keyword syntax.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Context>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,189 @@
package MooseX::Declare::Syntax::MethodDeclaration;
# ABSTRACT: Handles method declarations
our $VERSION = '0.43';
use Moose::Role;
use MooseX::Method::Signatures::Meta::Method;
use MooseX::Method::Signatures 0.36 ();
use MooseX::Method::Signatures::Types qw/PrototypeInjections/;
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod A role for keyword handlers that gives a framework to add or modify
#pod methods or things that look like methods.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::KeywordHandling>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::KeywordHandling
);
#pod =head1 REQUIRED METHODS
#pod
#pod =head2 register_method_declaration
#pod
#pod Object->register_method_declaration (Object $metaclass, Str $name, Object $method)
#pod
#pod This method will be called with the target metaclass and the final built
#pod L<method meta object|MooseX::Method::Signatures::Meta::Method> and its name.
#pod The value it returns will be the value returned where the method was declared.
#pod
#pod =cut
requires qw(
register_method_declaration
);
#pod =attr prototype_injections
#pod
#pod An optional structure describing additional things to be added to a methods
#pod signature. A popular example is found in the C<around>
#pod L<method modifier handler|MooseX::Declare::Syntax::Keyword::MethodModifier>:
#pod
#pod =cut
has prototype_injections => (
is => 'ro',
isa => PrototypeInjections,
predicate => 'has_prototype_injections',
);
#pod =method parse
#pod
#pod Object->parse (Object $ctx);
#pod
#pod Reads a name and a prototype and builds the method meta object then registers
#pod it into the current class using MooseX::Method::Signatures and a
#pod C<custom_method_application>, that calls L</register_method_declaration>.
#pod
#pod =cut
sub parse {
my ($self, $ctx) = @_;
my %args = (
context => $ctx->_dd_context,
initialized_context => 1,
custom_method_application => sub {
my ($meta, $name, $method) = @_;
$self->register_method_declaration($meta, $name, $method);
},
);
$args{prototype_injections} = $self->prototype_injections
if $self->has_prototype_injections;
my $mxms = MooseX::Method::Signatures->new(%args);
$mxms->parser;
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::NamespaceHandling>
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod * L<MooseX::Method::Signatures>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::MethodDeclaration - Handles method declarations
=head1 VERSION
version 0.43
=head1 DESCRIPTION
A role for keyword handlers that gives a framework to add or modify
methods or things that look like methods.
=head1 ATTRIBUTES
=head2 prototype_injections
An optional structure describing additional things to be added to a methods
signature. A popular example is found in the C<around>
L<method modifier handler|MooseX::Declare::Syntax::Keyword::MethodModifier>:
=head1 METHODS
=head2 parse
Object->parse (Object $ctx);
Reads a name and a prototype and builds the method meta object then registers
it into the current class using MooseX::Method::Signatures and a
C<custom_method_application>, that calls L</register_method_declaration>.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::KeywordHandling>
=back
=head1 REQUIRED METHODS
=head2 register_method_declaration
Object->register_method_declaration (Object $metaclass, Str $name, Object $method)
This method will be called with the target metaclass and the final built
L<method meta object|MooseX::Method::Signatures::Meta::Method> and its name.
The value it returns will be the value returned where the method was declared.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::NamespaceHandling>
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=item *
L<MooseX::Method::Signatures>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,24 @@
package # hide from PAUSE
MooseX::Declare::Syntax::MethodDeclaration::Parameterized;
our $VERSION = '0.43';
use Moose::Role;
# we actually require MXRP 1.06 if versions 1.03,1.04,1.05 are installed
# (which is where current_metaclass was removed from the API), but this was
# only in the wild for a short time, so it's not worth creating a dynamic
# prereq for.
use MooseX::Role::Parameterized 0.12 ();
use namespace::autoclean;
around register_method_declaration => sub {
my ($next, $self, $parameterizable_meta, $name, $method) = @_;
my $meta = $self->metaclass_for_method_application($parameterizable_meta, $name, $method);
$self->$next($meta, $name, $method);
};
sub metaclass_for_method_application {
return MooseX::Role::Parameterized->current_metaclass;
}
1;

View File

@@ -0,0 +1,359 @@
package MooseX::Declare::Syntax::MooseSetup;
# ABSTRACT: Common Moose namespaces declarations
our $VERSION = '0.43';
use Moose::Role;
use Moose::Util qw( find_meta );
use Sub::Install qw( install_sub );
use aliased 'MooseX::Declare::Syntax::Keyword::MethodModifier';
use aliased 'MooseX::Declare::Syntax::Keyword::Method';
use aliased 'MooseX::Declare::Syntax::Keyword::With', 'WithKeyword';
use aliased 'MooseX::Declare::Syntax::Keyword::Clean', 'CleanKeyword';
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This role is basically an extension to
#pod L<NamespaceHandling|MooseX::Declare::Syntax::NamespaceHandling>. It adds all
#pod the common parts for L<Moose> namespace definitions. Examples of this role
#pod can be found in the L<class|MooseX::Declare::Syntax::Keyword::Class> and
#pod L<role|MooseX::Declare::Syntax::Keyword::Role> keywords.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::NamespaceHandling>
#pod * L<MooseX::Declare::Syntax::EmptyBlockIfMissing>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::NamespaceHandling
MooseX::Declare::Syntax::EmptyBlockIfMissing
);
#pod =method auto_make_immutable
#pod
#pod Bool Object->auto_make_immutable ()
#pod
#pod Since L<Moose::Role>s can't be made immutable (this is not a bug or a
#pod missing feature, it would make no sense), this always returns false.
#pod
#pod =cut
sub auto_make_immutable { 0 }
#pod =method imported_moose_symbols
#pod
#pod List Object->imported_moose_symbols ()
#pod
#pod This will return C<confess> and C<blessed> by default to provide as
#pod additional imports to the namespace.
#pod
#pod =cut
sub imported_moose_symbols { qw( confess blessed ) }
#pod =method import_symbols_from
#pod
#pod Str Object->import_symbols_from ()
#pod
#pod The namespace from which the additional imports will be imported. This
#pod will return C<Moose> by default.
#pod
#pod =cut
sub import_symbols_from { 'Moose' }
#pod =head1 MODIFIED METHODS
#pod
#pod =head2 default_inner
#pod
#pod ArrayRef default_inner ()
#pod
#pod This will provide the following default inner-handlers to the namespace:
#pod
#pod =for :list
#pod * method
#pod A simple L<Method|MooseX::Declare::Syntax::Keyword::Method> handler.
#pod * around
#pod This is a L<MethodModifier|MooseX::Declare::Syntax::Keyword::MethodModifier>
#pod handler that will start the signature of the generated method with
#pod C<$orig: $self> to provide the original method in C<$orig>.
#pod * after
#pod * before
#pod * override
#pod * augment
#pod These four handlers are L<MethodModifier|MooseX::Declare::Syntax::Keyword::MethodModifier>
#pod instances.
#pod * clean
#pod This is an instance of the L<Clean|MooseX::Declare::Syntax::Keyword::Clean> keyword
#pod handler.
#pod
#pod The original method will never be called and all arguments are ignored at the
#pod moment.
#pod
#pod =cut
around default_inner => sub {
return [
WithKeyword->new(identifier => 'with'),
Method->new(identifier => 'method'),
MethodModifier->new(
identifier => 'around',
modifier_type => 'around',
prototype_injections => {
declarator => 'around',
injections => [ 'CodeRef $orig' ],
},
),
map { MethodModifier->new(identifier => $_, modifier_type => $_) }
qw( after before override augment ),
];
};
#pod =head2 setup_inner_for
#pod
#pod Object->setup_inner_for (ClassName $class)
#pod
#pod This will install a C<with> function that will push its arguments onto a global
#pod storage array holding the roles of the current namespace.
#pod
#pod =cut
after setup_inner_for => sub {
my ($self, $setup_class, %args) = @_;
my $keyword = CleanKeyword->new(identifier => 'clean');
$keyword->setup_for($setup_class, %args);
};
#pod =head2 add_namespace_customizations
#pod
#pod Object->add_namespace_customizations (Object $context, Str $package, HashRef $options)
#pod
#pod After all other customizations, this will first add code to import the
#pod L</imported_moose_symbols> from the package returned in L</import_symbols_from> to
#pod the L<preamble|MooseX::Declare::Context/preamble_code_parts>.
#pod
#pod Then it will add a code part that will immutabilize the class to the
#pod L<cleanup|MooseX::Declare::Context/cleanup_code_parts> code if the
#pod L</auto_make_immutable> method returned a true value and C<< $options->{is}{mutable} >>
#pod does not exist.
#pod
#pod =cut
after add_namespace_customizations => sub {
my ($self, $ctx, $package) = @_;
# add Moose initializations to preamble
$ctx->add_preamble_code_parts(
sprintf 'use %s qw( %s )', $self->import_symbols_from($ctx), join ' ', $self->imported_moose_symbols($ctx),
);
# make class immutable unless specified otherwise
$ctx->add_cleanup_code_parts(
"${package}->meta->make_immutable",
) if $self->auto_make_immutable
and not exists $ctx->options->{is}{mutable};
};
#pod =head2 handle_post_parsing
#pod
#pod CodeRef Object->handle_post_parsing (Object $context, Str $package, Str|Object $name)
#pod
#pod Generates a callback that sets up the roles in the global role storage for the current
#pod namespace. The C<$name> parameter will be the specified name (in contrast to C<$package>
#pod which will always be the fully qualified name) or the anonymous metaclass instance if
#pod none was specified.
#pod
#pod =cut
after handle_post_parsing => sub {
my ($self, $ctx, $package, $class) = @_;
$ctx->shadow(sub (&) { shift->(); return $class; });
};
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<Moose>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::MooseSetup - Common Moose namespaces declarations
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This role is basically an extension to
L<NamespaceHandling|MooseX::Declare::Syntax::NamespaceHandling>. It adds all
the common parts for L<Moose> namespace definitions. Examples of this role
can be found in the L<class|MooseX::Declare::Syntax::Keyword::Class> and
L<role|MooseX::Declare::Syntax::Keyword::Role> keywords.
=head1 METHODS
=head2 auto_make_immutable
Bool Object->auto_make_immutable ()
Since L<Moose::Role>s can't be made immutable (this is not a bug or a
missing feature, it would make no sense), this always returns false.
=head2 imported_moose_symbols
List Object->imported_moose_symbols ()
This will return C<confess> and C<blessed> by default to provide as
additional imports to the namespace.
=head2 import_symbols_from
Str Object->import_symbols_from ()
The namespace from which the additional imports will be imported. This
will return C<Moose> by default.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::NamespaceHandling>
=item *
L<MooseX::Declare::Syntax::EmptyBlockIfMissing>
=back
=head1 MODIFIED METHODS
=head2 default_inner
ArrayRef default_inner ()
This will provide the following default inner-handlers to the namespace:
=over 4
=item *
method
A simple L<Method|MooseX::Declare::Syntax::Keyword::Method> handler.
=item *
around
This is a L<MethodModifier|MooseX::Declare::Syntax::Keyword::MethodModifier>
handler that will start the signature of the generated method with
C<$orig: $self> to provide the original method in C<$orig>.
=item *
after
=item *
before
=item *
override
=item *
augment
These four handlers are L<MethodModifier|MooseX::Declare::Syntax::Keyword::MethodModifier>
instances.
=item *
clean
This is an instance of the L<Clean|MooseX::Declare::Syntax::Keyword::Clean> keyword
handler.
=back
The original method will never be called and all arguments are ignored at the
moment.
=head2 setup_inner_for
Object->setup_inner_for (ClassName $class)
This will install a C<with> function that will push its arguments onto a global
storage array holding the roles of the current namespace.
=head2 add_namespace_customizations
Object->add_namespace_customizations (Object $context, Str $package, HashRef $options)
After all other customizations, this will first add code to import the
L</imported_moose_symbols> from the package returned in L</import_symbols_from> to
the L<preamble|MooseX::Declare::Context/preamble_code_parts>.
Then it will add a code part that will immutabilize the class to the
L<cleanup|MooseX::Declare::Context/cleanup_code_parts> code if the
L</auto_make_immutable> method returned a true value and C<< $options->{is}{mutable} >>
does not exist.
=head2 handle_post_parsing
CodeRef Object->handle_post_parsing (Object $context, Str $package, Str|Object $name)
Generates a callback that sets up the roles in the global role storage for the current
namespace. The C<$name> parameter will be the specified name (in contrast to C<$package>
which will always be the fully qualified name) or the anonymous metaclass instance if
none was specified.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<Moose>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,440 @@
package MooseX::Declare::Syntax::NamespaceHandling;
# ABSTRACT: Handle namespaced blocks
our $VERSION = '0.43';
use Moose::Role;
use Moose::Util qw( does_role );
use MooseX::Declare::Util qw( outer_stack_peek );
use Carp;
use aliased 'MooseX::Declare::Context::Namespaced';
use aliased 'MooseX::Declare::Context::WithOptions';
use aliased 'MooseX::Declare::Context::Parameterized';
use aliased 'MooseX::Declare::StackItem';
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod Allows the implementation of namespaced blocks like the
#pod L<role|MooseX::Declare::Syntax::Keyword::Role> and
#pod L<class|MooseX::Declare::Syntax::Keyword::Class> keyword handlers.
#pod
#pod Namespaces are automatically nested. Meaning that, for example, a C<class Bar>
#pod declaration inside another C<class Foo> block gives the inner one actually the
#pod name C<Foo::Bar>.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::KeywordHandling>
#pod * L<MooseX::Declare::Syntax::InnerSyntaxHandling>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::KeywordHandling
MooseX::Declare::Syntax::InnerSyntaxHandling
);
#pod =head1 REQUIRED METHODS
#pod
#pod =head2 handle_missing_block
#pod
#pod Object->handle_missing_block (Object $context, Str $body, %args)
#pod
#pod This must be implemented to decide what to do in case the statement is
#pod terminated rather than followed by a block. It will receive the context
#pod object, the produced code that needs to be injected, and all the arguments
#pod that were passed to the call to L<MooseX::Declare::Context/inject_code_parts>.
#pod
#pod The return value will be ignored.
#pod
#pod =cut
requires qw(
handle_missing_block
);
#pod =head1 EXTENDABLE STUB METHODS
#pod
#pod =head2 add_namespace_customizations
#pod
#pod =head2 add_optional_customizations
#pod
#pod Object->add_namespace_customizations (Object $context, Str $package, HashRef $options)
#pod Object->add_optional_customizations (Object $context, Str $package, HashRef $options)
#pod
#pod These will be called (in this order) by the L</parse> method. They allow specific hooks
#pod to attach before/after/around the customizations for the namespace and the provided
#pod options that are not attached to the namespace directly.
#pod
#pod While this distinction might seem superficial, we advise library developers facilitating
#pod this role to follow the precedent. This ensures that when another component needs to
#pod tie between the namespace and any additional customizations everything will run in the
#pod correct order. An example of this separation would be
#pod
#pod class Foo is mutable ...
#pod
#pod being an option of the namespace generation, while
#pod
#pod class Foo with Bar ...
#pod
#pod is an additional optional customization.
#pod
#pod =head2 handle_post_parsing
#pod
#pod Object->handle_post_parsing (Object $context, Str $package, Str | Object $name)
#pod
#pod Allows for additional modifications to the namespace after everything else has been
#pod done. It will receive the context, the fully qualified package name, and either a
#pod string with the name that was specified (might not be fully qualified, since
#pod namespaces can be nested) or the anonymous metaclass instance if no name was
#pod specified.
#pod
#pod The return value of this method will be the value returned to the user of the
#pod keyword. If you always return the C<$package> argument like this:
#pod
#pod sub handle_post_parsing {
#pod my ($self, $context, $package, $name) = @_;
#pod return $package;
#pod }
#pod
#pod and set this up in a C<foo> keyword handler, you can use it like this:
#pod
#pod foo Cthulhu {
#pod
#pod my $fhtagn = foo Fhtagn { }
#pod my $anon = foo { };
#pod
#pod say $fhtagn; # Cthulhu::Fhtagn
#pod say $anon; # some autogenerated package name
#pod }
#pod
#pod =head2 make_anon_metaclass
#pod
#pod Class::MOP::Class Object->make_anon_metaclass ()
#pod
#pod This method should be overridden if you want to provide anonymous namespaces.
#pod
#pod It does not receive any arguments for customization of the metaclass, because
#pod the configuration and customization will be done by L<MooseX::Declare> in the
#pod package of the generated class in the same way as in those that have specified
#pod names. This way ensures that anonymous and named namespaces are always handled
#pod equally.
#pod
#pod If you do not extend this method (it will return nothing by default), an error
#pod will be thrown when a user attempts to declare an anonymous namespace.
#pod
#pod =cut
sub add_namespace_customizations { }
sub add_optional_customizations { }
sub handle_post_parsing { }
sub make_anon_metaclass { }
around context_traits => sub { super, WithOptions, Namespaced };
sub parse_specification {
my ($self, $ctx) = @_;
$self->parse_namespace_specification($ctx);
$self->parse_option_specification($ctx);
return;
}
sub parse_namespace_specification {
my ($self, $ctx) = @_;
return scalar $ctx->strip_namespace;
}
sub parse_option_specification {
my ($self, $ctx) = @_;
return scalar $ctx->strip_options;
}
sub generate_inline_stack {
my ($self, $ctx) = @_;
return join ', ',
map { $_->serialize }
@{ $ctx->stack },
$self->generate_current_stack_item($ctx);
}
sub generate_current_stack_item {
my ($self, $ctx) = @_;
return StackItem->new(
identifier => $self->identifier,
is_dirty => $ctx->options->{is}{dirty},
is_parameterized => does_role($ctx, Parameterized) && $ctx->has_parameter_signature,
handler => ref($self),
namespace => $ctx->namespace,
);
}
#pod =method parse
#pod
#pod Any Object->parse (Object $context)
#pod
#pod This is the main handling routine for namespaces. It will remove the namespace
#pod name and its options. If the handler was invoked without a name, options or
#pod a following block, it is assumed that this is an instance of an autoquoted
#pod bareword like C<< class => "Foo" >>.
#pod
#pod The return value of the C<parse> method is also the value that is returned
#pod to the user of the keyword.
#pod
#pod =cut
sub parse {
my ($self, $ctx) = @_;
# keyword comes first
$ctx->skip_declarator;
# read the name and unwrap the options
$self->parse_specification($ctx);
my $name = $ctx->namespace;
my ($package, $anon);
# we have a name in the declaration, which will be used as package name
if (defined $name) {
$package = $name;
# there is an outer namespace stack item, meaning we namespace below
# it, if the name starts with ::
if (my $outer = outer_stack_peek $ctx->caller_file) {
$package = $outer . $package
if $name =~ /^::/;
}
}
# no name, no options, no block. Probably { class => 'foo' }
elsif (not(keys %{ $ctx->options }) and $ctx->peek_next_char ne '{') {
return;
}
# we have options and/or a block, but not name
else {
$anon = $self->make_anon_metaclass
or croak sprintf 'Unable to create an anonymized %s namespace', $self->identifier;
$package = $anon->name;
}
# namespace and mx:d initialisations
$ctx->add_preamble_code_parts(
"package ${package}",
sprintf(
"use %s %s => '%s', file => __FILE__, stack => [ %s ]",
$ctx->provided_by,
outer_package => $package,
$self->generate_inline_stack($ctx),
),
);
# allow consumer to provide specialisations
$self->add_namespace_customizations($ctx, $package);
# make options a separate step
$self->add_optional_customizations($ctx, $package);
# finish off preamble with a namespace cleanup
$ctx->add_preamble_code_parts(
$ctx->options->{is}->{dirty}
? 'use namespace::clean -except => [qw( meta )]'
: 'use namespace::autoclean'
);
# clean up our stack afterwards, if there was a name
$ctx->add_cleanup_code_parts(
['BEGIN',
'MooseX::Declare::Util::outer_stack_pop __FILE__',
],
);
# actual code injection
$ctx->inject_code_parts(
missing_block_handler => sub { $self->handle_missing_block(@_) },
);
# a last chance to change things
$self->handle_post_parsing($ctx, $package, defined($name) ? $name : $anon);
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::MooseSetup>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::NamespaceHandling - Handle namespaced blocks
=head1 VERSION
version 0.43
=head1 DESCRIPTION
Allows the implementation of namespaced blocks like the
L<role|MooseX::Declare::Syntax::Keyword::Role> and
L<class|MooseX::Declare::Syntax::Keyword::Class> keyword handlers.
Namespaces are automatically nested. Meaning that, for example, a C<class Bar>
declaration inside another C<class Foo> block gives the inner one actually the
name C<Foo::Bar>.
=head1 METHODS
=head2 parse
Any Object->parse (Object $context)
This is the main handling routine for namespaces. It will remove the namespace
name and its options. If the handler was invoked without a name, options or
a following block, it is assumed that this is an instance of an autoquoted
bareword like C<< class => "Foo" >>.
The return value of the C<parse> method is also the value that is returned
to the user of the keyword.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::KeywordHandling>
=item *
L<MooseX::Declare::Syntax::InnerSyntaxHandling>
=back
=head1 REQUIRED METHODS
=head2 handle_missing_block
Object->handle_missing_block (Object $context, Str $body, %args)
This must be implemented to decide what to do in case the statement is
terminated rather than followed by a block. It will receive the context
object, the produced code that needs to be injected, and all the arguments
that were passed to the call to L<MooseX::Declare::Context/inject_code_parts>.
The return value will be ignored.
=head1 EXTENDABLE STUB METHODS
=head2 add_namespace_customizations
=head2 add_optional_customizations
Object->add_namespace_customizations (Object $context, Str $package, HashRef $options)
Object->add_optional_customizations (Object $context, Str $package, HashRef $options)
These will be called (in this order) by the L</parse> method. They allow specific hooks
to attach before/after/around the customizations for the namespace and the provided
options that are not attached to the namespace directly.
While this distinction might seem superficial, we advise library developers facilitating
this role to follow the precedent. This ensures that when another component needs to
tie between the namespace and any additional customizations everything will run in the
correct order. An example of this separation would be
class Foo is mutable ...
being an option of the namespace generation, while
class Foo with Bar ...
is an additional optional customization.
=head2 handle_post_parsing
Object->handle_post_parsing (Object $context, Str $package, Str | Object $name)
Allows for additional modifications to the namespace after everything else has been
done. It will receive the context, the fully qualified package name, and either a
string with the name that was specified (might not be fully qualified, since
namespaces can be nested) or the anonymous metaclass instance if no name was
specified.
The return value of this method will be the value returned to the user of the
keyword. If you always return the C<$package> argument like this:
sub handle_post_parsing {
my ($self, $context, $package, $name) = @_;
return $package;
}
and set this up in a C<foo> keyword handler, you can use it like this:
foo Cthulhu {
my $fhtagn = foo Fhtagn { }
my $anon = foo { };
say $fhtagn; # Cthulhu::Fhtagn
say $anon; # some autogenerated package name
}
=head2 make_anon_metaclass
Class::MOP::Class Object->make_anon_metaclass ()
This method should be overridden if you want to provide anonymous namespaces.
It does not receive any arguments for customization of the metaclass, because
the configuration and customization will be done by L<MooseX::Declare> in the
package of the generated class in the same way as in those that have specified
names. This way ensures that anonymous and named namespaces are always handled
equally.
If you do not extend this method (it will return nothing by default), an error
will be thrown when a user attempts to declare an anonymous namespace.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::MooseSetup>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,157 @@
package MooseX::Declare::Syntax::OptionHandling;
# ABSTRACT: Option parser dispatching
our $VERSION = '0.43';
use Moose::Role;
use Carp qw( croak );
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This role will call a C<add_foo_option_customization> for every C<foo> option
#pod that is discovered.
#pod
#pod =head1 REQUIRED METHODS
#pod
#pod =head2 get_identifier
#pod
#pod Str Object->get_identifier ()
#pod
#pod This must return the name of the current keyword's identifier.
#pod
#pod =cut
requires qw( get_identifier );
#pod =method ignored_options
#pod
#pod List[Str] Object->ignored_options ()
#pod
#pod This method returns a list of option names that won't be dispatched. By default
#pod this only contains the C<is> option.
#pod
#pod =cut
sub ignored_options { qw( is ) }
#pod =head1 MODIFIED METHODS
#pod
#pod =head2 add_optional_customizations
#pod
#pod Object->add_optional_customizations (Object $context, Str $package, HashRef $options)
#pod
#pod This will dispatch to the respective C<add_*_option_customization> method for option
#pod handling unless the option is listed in the L</ignored_options>.
#pod
#pod =cut
after add_optional_customizations => sub {
my ($self, $ctx, $package) = @_;
my $options = $ctx->options;
# ignored options
my %ignored = map { ($_ => 1) } $self->ignored_options;
# try to find a handler for each option
for my $option (keys %$options) {
next if $ignored{ $option };
# call the handler with its own value and all options
if (my $method = $self->can("add_${option}_option_customizations")) {
$self->$method($ctx, $package, $options->{ $option }, $options);
}
# no handler method was found
else {
croak sprintf q/The '%s' keyword does not know what to do with an '%s' option/,
$self->get_identifier,
$option;
}
}
return 1;
};
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::NamespaceHandling>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::OptionHandling - Option parser dispatching
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This role will call a C<add_foo_option_customization> for every C<foo> option
that is discovered.
=head1 METHODS
=head2 ignored_options
List[Str] Object->ignored_options ()
This method returns a list of option names that won't be dispatched. By default
this only contains the C<is> option.
=head1 REQUIRED METHODS
=head2 get_identifier
Str Object->get_identifier ()
This must return the name of the current keyword's identifier.
=head1 MODIFIED METHODS
=head2 add_optional_customizations
Object->add_optional_customizations (Object $context, Str $package, HashRef $options)
This will dispatch to the respective C<add_*_option_customization> method for option
handling unless the option is listed in the L</ignored_options>.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::NamespaceHandling>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,134 @@
package MooseX::Declare::Syntax::RoleApplication;
# ABSTRACT: Handle user specified roles
our $VERSION = '0.43';
use Moose::Role;
use aliased 'MooseX::Declare::Context::Namespaced';
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This role extends L<MooseX::Declare::Syntax::OptionHandling> and provides
#pod a C<with|/add_with_option_customizations> option.
#pod
#pod =head1 CONSUMES
#pod
#pod =for :list
#pod * L<MooseX::Declare::Syntax::OptionHandling>
#pod
#pod =cut
with qw(
MooseX::Declare::Syntax::OptionHandling
);
around context_traits => sub { shift->(@_), Namespaced };
#pod =method add_with_option_customizations
#pod
#pod Object->add_with_option_customizations (
#pod Object $context,
#pod Str $package,
#pod ArrayRef $roles,
#pod HashRef $options
#pod )
#pod
#pod This will add a call to C<with> in the scope code.
#pod
#pod =cut
sub add_with_option_customizations {
my ($self, $ctx, $package, $roles) = @_;
# consume roles
$ctx->add_early_cleanup_code_parts(
sprintf 'Moose::Util::apply_all_roles(%s->meta, %s)',
$package,
join ', ',
map { "q[$_]" }
map { $ctx->qualify_namespace($_) }
@{ $roles },
);
return 1;
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod * L<MooseX::Declare::Syntax::OptionHandling>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Syntax::RoleApplication - Handle user specified roles
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This role extends L<MooseX::Declare::Syntax::OptionHandling> and provides
a C<with|/add_with_option_customizations> option.
=head1 METHODS
=head2 add_with_option_customizations
Object->add_with_option_customizations (
Object $context,
Str $package,
ArrayRef $roles,
HashRef $options
)
This will add a call to C<with> in the scope code.
=head1 CONSUMES
=over 4
=item *
L<MooseX::Declare::Syntax::OptionHandling>
=back
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<MooseX::Declare::Syntax::OptionHandling>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,149 @@
use strict;
use warnings;
package MooseX::Declare::Util;
# ABSTRACT: Common declarative utility functions
our $VERSION = '0.43';
use Sub::Exporter -setup => {
exports => [qw(
outer_stack_push
outer_stack_pop
outer_stack_peek
)],
};
#pod =head1 DESCRIPTION
#pod
#pod This exporter collection contains the commonly used functions in
#pod L<MooseX::Declare>.
#pod
#pod All functions in this package will be exported upon request.
#pod
#pod =cut
my %OuterStack;
#pod =func outer_stack_push
#pod
#pod outer_stack_push (Str $file, Str $value)
#pod
#pod Pushes the C<$value> on the internal stack for the file C<$file>.
#pod
#pod =cut
sub outer_stack_push {
my ($file, $value) = @_;
push @{ $OuterStack{ $file } }, $value;
return $value;
}
#pod =func outer_stack_pop
#pod
#pod outer_stack_pop (Str $file)
#pod
#pod Removes one item from the internal stack of the file C<$file>.
#pod
#pod =cut
sub outer_stack_pop {
my ($file) = @_;
return undef
unless @{ $OuterStack{ $file } || [] };
return pop @{ $OuterStack{ $file } };
}
#pod =func outer_stack_peek
#pod
#pod outer_stack_peek (Str $file)
#pod
#pod Returns the topmost item in the internal stack for C<$file> without removing
#pod it from the stack.
#pod
#pod =cut
sub outer_stack_peek {
my ($file) = @_;
return undef
unless @{ $OuterStack{ $file } || [] };
return $OuterStack{ $file }[-1];
}
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L<MooseX::Declare>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Declare::Util - Common declarative utility functions
=head1 VERSION
version 0.43
=head1 DESCRIPTION
This exporter collection contains the commonly used functions in
L<MooseX::Declare>.
All functions in this package will be exported upon request.
=head1 FUNCTIONS
=head2 outer_stack_push
outer_stack_push (Str $file, Str $value)
Pushes the C<$value> on the internal stack for the file C<$file>.
=head2 outer_stack_pop
outer_stack_pop (Str $file)
Removes one item from the internal stack of the file C<$file>.
=head2 outer_stack_peek
outer_stack_peek (Str $file)
Returns the topmost item in the internal stack for C<$file> without removing
it from the stack.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=back
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,182 @@
package MooseX::LazyRequire;
# git description: v0.10-7-gf996968
$MooseX::LazyRequire::VERSION = '0.11';
# ABSTRACT: Required attributes which fail only when trying to use them
# KEYWORDS: moose extension attribute required lazy defer populate method
use Moose 0.94 ();
use Moose::Exporter;
use aliased 0.30 'MooseX::LazyRequire::Meta::Attribute::Trait::LazyRequire';
use namespace::autoclean;
#pod =head1 SYNOPSIS
#pod
#pod package Foo;
#pod
#pod use Moose;
#pod use MooseX::LazyRequire;
#pod
#pod has foo => (
#pod is => 'ro',
#pod lazy_required => 1,
#pod );
#pod
#pod has bar => (
#pod is => 'ro',
#pod builder => '_build_bar',
#pod );
#pod
#pod sub _build_bar { shift->foo }
#pod
#pod
#pod Foo->new(foo => 42); # succeeds, foo and bar will be 42
#pod Foo->new(bar => 42); # succeeds, bar will be 42
#pod Foo->new; # fails, neither foo nor bare were given
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module adds a C<lazy_required> option to Moose attribute declarations.
#pod
#pod The reader methods for all attributes with that option will throw an exception
#pod unless a value for the attributes was provided earlier by a constructor
#pod parameter or through a writer method.
#pod
#pod =head1 CAVEATS
#pod
#pod Prior to Moose 1.9900, roles didn't have an attribute metaclass, so this module can't
#pod easily apply its magic to attributes defined in roles. If you want to use
#pod C<lazy_required> in role attributes, you'll have to apply the attribute trait
#pod yourself:
#pod
#pod has foo => (
#pod traits => ['LazyRequire'],
#pod is => 'ro',
#pod lazy_required => 1,
#pod );
#pod
#pod With Moose 1.9900, you can use this module in roles just the same way you can
#pod in classes.
#pod
#pod =cut
my %metaroles = (
class_metaroles => {
attribute => [LazyRequire],
},
);
$metaroles{role_metaroles} = {
applied_attribute => [LazyRequire],
}
if $Moose::VERSION >= 1.9900;
Moose::Exporter->setup_import_methods(%metaroles);
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::LazyRequire - Required attributes which fail only when trying to use them
=head1 VERSION
version 0.11
=head1 SYNOPSIS
package Foo;
use Moose;
use MooseX::LazyRequire;
has foo => (
is => 'ro',
lazy_required => 1,
);
has bar => (
is => 'ro',
builder => '_build_bar',
);
sub _build_bar { shift->foo }
Foo->new(foo => 42); # succeeds, foo and bar will be 42
Foo->new(bar => 42); # succeeds, bar will be 42
Foo->new; # fails, neither foo nor bare were given
=head1 DESCRIPTION
This module adds a C<lazy_required> option to Moose attribute declarations.
The reader methods for all attributes with that option will throw an exception
unless a value for the attributes was provided earlier by a constructor
parameter or through a writer method.
=head1 CAVEATS
Prior to Moose 1.9900, roles didn't have an attribute metaclass, so this module can't
easily apply its magic to attributes defined in roles. If you want to use
C<lazy_required> in role attributes, you'll have to apply the attribute trait
yourself:
has foo => (
traits => ['LazyRequire'],
is => 'ro',
lazy_required => 1,
);
With Moose 1.9900, you can use this module in roles just the same way you can
in classes.
=for Pod::Coverage init_meta
=head1 AUTHORS
=over 4
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Dave Rolsky <autarch@urth.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2009 by Florian Ragwitz.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge David Precious Jesse Luehrs
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
David Precious <davidp@preshweb.co.uk>
=item *
Jesse Luehrs <doy@tozt.net>
=back
=cut

View File

@@ -0,0 +1,80 @@
package MooseX::LazyRequire::Meta::Attribute::Trait::LazyRequire;
# ABSTRACT: Attribute trait to make getters fail on unset attributes
$MooseX::LazyRequire::Meta::Attribute::Trait::LazyRequire::VERSION = '0.11';
use Moose::Role;
use Carp qw/cluck/;
use namespace::autoclean;
has lazy_required => (
is => 'ro',
isa => 'Bool',
default => 0,
);
after _process_options => sub {
my ($class, $name, $options) = @_;
if (exists $options->{lazy_require}) {
cluck "deprecated option 'lazy_require' used. use 'lazy_required' instead.";
$options->{lazy_required} = delete $options->{lazy_require};
}
return unless $options->{lazy_required};
# lazy_required + default or builder doesn't make sense because if there
# is a default/builder, the reader will always be able to return a value.
Moose->throw_error(
"You may not use both a builder or a default and lazy_required for one attribute ($name)",
data => $options,
) if $options->{builder} or $options->{default};
$options->{ lazy } = 1;
$options->{ required } = 1;
$options->{ default } = sub {
confess "Attribute '$name' must be provided before calling reader"
};
};
package # hide
Moose::Meta::Attribute::Custom::Trait::LazyRequire;
sub register_implementation { 'MooseX::LazyRequire::Meta::Attribute::Trait::LazyRequire' }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::LazyRequire::Meta::Attribute::Trait::LazyRequire - Attribute trait to make getters fail on unset attributes
=head1 VERSION
version 0.11
=head1 AUTHORS
=over 4
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Dave Rolsky <autarch@urth.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2009 by Florian Ragwitz.
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

View File

@@ -0,0 +1,15 @@
package ## Hide from PAUSE
MooseX::Meta::TypeCoercion::Structured;
our $VERSION = '0.36';
use Moose;
extends 'Moose::Meta::TypeCoercion';
# We need to make sure we can properly coerce the structure elements inside a
# structured type constraint. However requirements for the best way to allow
# this are still in flux. For now this class is a placeholder.
# see also Moose::Meta::TypeCoercion.
no Moose;
__PACKAGE__->meta->make_immutable(inline_constructor => 0);

View File

@@ -0,0 +1,29 @@
package ## Hide from PAUSE
MooseX::Meta::TypeCoercion::Structured::Optional;
our $VERSION = '0.36';
use Moose;
extends 'Moose::Meta::TypeCoercion';
sub compile_type_coercion {
my ($self) = @_;
my $constraint = $self->type_constraint->type_parameter;
$self->_compiled_type_coercion(sub {
my ($value) = @_;
return unless $constraint->has_coercion;
return $constraint->coerce($value);
});
}
sub has_coercion_for_type { 0 }
sub add_type_coercions {
Moose->throw_error("Cannot add additional type coercions to Optional types");
}
no Moose;
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
1;

View File

@@ -0,0 +1,145 @@
package MooseX::Meta::TypeConstraint::ForceCoercion;
our $VERSION = '0.01';
# ABSTRACT: Force coercion when validating type constraints
use Moose;
use namespace::autoclean;
has _type_constraint => (
is => 'ro',
isa => 'Moose::Meta::TypeConstraint',
init_arg => 'type_constraint',
required => 1,
);
sub check {
my ($self, $value) = @_;
my $coerced = $self->_type_constraint->coerce($value);
return undef if $coerced == $value;
return $self->_type_constraint->check($coerced);
}
sub validate {
my ($self, $value, $coerced_ref) = @_;
my $coerced = $self->_type_constraint->coerce($value);
return 'Coercion failed' if $coerced == $value;
${ $coerced_ref } = $coerced if $coerced_ref;
return $self->_type_constraint->validate($coerced);
}
my $meta = __PACKAGE__->meta;
for my $meth (qw/isa can meta/) {
my $orig = __PACKAGE__->can($meth);
$meta->add_method($meth => sub {
my ($self) = shift;
return $self->$orig(@_) unless blessed $self;
my $tc = $self->_type_constraint;
# this might happen during global destruction
return $self->$orig(@_) unless $tc;
return $tc->$meth(@_);
});
}
sub AUTOLOAD {
my $self = shift;
my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/);
return unless blessed $self;
my $tc = $self->_type_constraint;
return unless $tc;
return $tc->$meth(@_);
}
$meta->make_immutable;
1;
__END__
=head1 NAME
MooseX::Meta::TypeConstraint::ForceCoercion - Force coercion when validating type constraints
=head1 VERSION
version 0.01
=head1 SYNOPSIS
use MooseX::Types:::Moose qw/Str Any/;
use Moose::Util::TypeConstraints;
use MooseX::Meta::TypeConstraint::ForceCoercion;
# get any type constraint
my $tc = Str;
# declare one or more coercions for it
coerce $tc,
from Any,
via { ... };
# wrap the $tc to force coercion
my $coercing_tc = MooseX::Meta::TypeConstraint::ForceCoercion->new(
type_constraint => $tc,
);
# check a value against new type constraint. this will run the type
# coercions for the wrapped type, even if the value already passes
# validation before coercion. it will fail if the value couldn't be
# coerced
$coercing_tc->check('Affe');
=head1 DESCRIPTION
This class allows to wrap any C<Moose::Meta::TypeConstraint> in a way that will
force coercion of the value when checking or validating a value against it.
=head1 ATTRIBUTES
=head2 type_constraint
The type constraint to wrap. All methods except for C<validate> and C<check>
are delegated to the value of this attribute.
=head1 METHODS
=head2 check ($value)
Same as C<Moose::Meta::TypeConstraint::check>, except it will always try to
coerce C<$value> before checking it against the actual type constraint. If
coercing fails the check will fail, too.
=head2 validate ($value, $coerced_ref?)
Same as C<Moose::Meta::TypeConstraint::validate>, except it will always try to
coerce C<$value> before validating it against the actual type constraint. If
coercing fails the validation will fail, too.
If coercion was successful and a C<$coerced_ref> references was passed, the
coerced value will be stored in that.
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2009 by Florian Ragwitz.
This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.

View File

@@ -0,0 +1,500 @@
package ## Hide from PAUSE
MooseX::Meta::TypeConstraint::Structured;
# ABSTRACT: Structured type constraints
our $VERSION = '0.36';
use Moose;
use Devel::PartialDump;
use MooseX::Meta::TypeCoercion::Structured;
extends 'Moose::Meta::TypeConstraint';
#pod =head1 DESCRIPTION
#pod
#pod A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
#pod such a way as that they are all applied to an incoming list of arguments. The
#pod idea here is that a Type Constraint could be something like, "An C<Int> followed by
#pod an C<Int> and then a C<Str>" and that this could be done so with a declaration like:
#pod
#pod Tuple[Int,Int,Str]; ## Example syntax
#pod
#pod So a structure is a list of type constraints (the C<Int,Int,Str> in the above
#pod example) which are intended to function together.
#pod
#pod =attr type_constraints
#pod
#pod A list of L<Moose::Meta::TypeConstraint> objects.
#pod
#pod =cut
has 'type_constraints' => (
is=>'ro',
isa=>'Ref',
predicate=>'has_type_constraints',
);
#pod =attr constraint_generator
#pod
#pod =for stopwords subref
#pod
#pod A subref or closure that contains the way we validate incoming values against
#pod a set of type constraints.
#pod
#pod =cut
has 'constraint_generator' => (
is=>'ro',
isa=>'CodeRef',
predicate=>'has_constraint_generator',
);
has coercion => (
is => 'ro',
isa => 'Object',
builder => '_build_coercion',
);
sub _build_coercion {
my ($self) = @_;
return MooseX::Meta::TypeCoercion::Structured->new(
type_constraint => $self,
);
}
#pod =method validate
#pod
#pod Messing with validate so that we can support nicer error messages.
#pod
#pod =cut
sub _clean_message {
my $message = shift @_;
$message =~s/MooseX::Types::Structured:://g;
return $message;
}
override 'validate' => sub {
my ($self, $value, $message_stack) = @_;
unless ($message_stack) {
$message_stack = MooseX::Types::Structured::MessageStack->new();
}
$message_stack->inc_level;
if ($self->_compiled_type_constraint->($value, $message_stack)) {
## Everything is good, no error message to return
return undef;
} else {
## Whoops, need to figure out the right error message
my $args = Devel::PartialDump::dump($value);
$message_stack->dec_level;
if($message_stack->has_messages) {
if($message_stack->level) {
## we are inside a deeply structured constraint
return $self->get_message($args);
} else {
my $message_str = $message_stack->as_string;
return _clean_message($self->get_message("$args, Internal Validation Error is: $message_str"));
}
} else {
return $self->get_message($args);
}
}
};
#pod =method generate_constraint_for ($type_constraints)
#pod
#pod Given some type constraints, use them to generate validation rules for an ref
#pod of values (to be passed at check time)
#pod
#pod =cut
sub generate_constraint_for {
my ($self, $type_constraints) = @_;
return $self->constraint_generator->($self, $type_constraints);
}
#pod =for :prelude
#pod =for stopwords parameterize
#pod
#pod =method parameterize (@type_constraints)
#pod
#pod Given a ref of type constraints, create a structured type.
#pod
#pod =cut
sub parameterize {
my ($self, @type_constraints) = @_;
my $class = ref $self;
my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
my $constraint_generator = $self->__infer_constraint_generator;
return $class->new(
name => $name,
parent => $self,
type_constraints => \@type_constraints,
constraint_generator => $constraint_generator,
);
}
#pod =method __infer_constraint_generator
#pod
#pod =for stopwords servicable
#pod
#pod This returns a CODEREF which generates a suitable constraint generator. Not
#pod user servicable, you'll never call this directly.
#pod
#pod =cut
sub __infer_constraint_generator {
my ($self) = @_;
if($self->has_constraint_generator) {
return $self->constraint_generator;
} else {
return sub {
## I'm not sure about this stuff but everything seems to work
my $tc = shift @_;
my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
$self->constraint->($merged_tc, @_);
};
}
}
#pod =method compile_type_constraint
#pod
#pod hook into compile_type_constraint so we can set the correct validation rules.
#pod
#pod =cut
around 'compile_type_constraint' => sub {
my ($compile_type_constraint, $self, @args) = @_;
if($self->has_type_constraints) {
my $type_constraints = $self->type_constraints;
my $constraint = $self->generate_constraint_for($type_constraints);
$self->_set_constraint($constraint);
}
return $self->$compile_type_constraint(@args);
};
#pod =method create_child_type
#pod
#pod modifier to make sure we get the constraint_generator
#pod
#pod =cut
around 'create_child_type' => sub {
my ($create_child_type, $self, %opts) = @_;
return $self->$create_child_type(
%opts,
constraint_generator => $self->__infer_constraint_generator,
);
};
#pod =method is_a_type_of
#pod
#pod =method is_subtype_of
#pod
#pod =method equals
#pod
#pod Override the base class behavior.
#pod
#pod =cut
sub equals {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
return unless $other->isa(__PACKAGE__);
return (
$self->parent->equals($other->parent)
and
$self->type_constraints_equals($other)
);
}
sub is_a_type_of {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) {
if ( $self->parent->is_a_type_of($other->parent) ) {
return $self->_type_constraints_op_all($other, "is_a_type_of");
} elsif ( $self->parent->is_a_type_of($other) ) {
return 1;
# FIXME compare?
} else {
return 0;
}
} else {
return $self->SUPER::is_a_type_of($other);
}
}
sub is_subtype_of {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
if ( $other->isa(__PACKAGE__) ) {
if ( $other->type_constraints and $self->type_constraints ) {
if ( $self->parent->is_a_type_of($other->parent) ) {
return (
$self->_type_constraints_op_all($other, "is_a_type_of")
and
$self->_type_constraints_op_any($other, "is_subtype_of")
);
} elsif ( $self->parent->is_a_type_of($other) ) {
return 1;
# FIXME compare?
} else {
return 0;
}
} else {
if ( $self->type_constraints ) {
if ( $self->SUPER::is_subtype_of($other) ) {
return 1;
} else {
return;
}
} else {
return $self->parent->is_subtype_of($other->parent);
}
}
} else {
return $self->SUPER::is_subtype_of($other);
}
}
#pod =method type_constraints_equals
#pod
#pod Checks to see if the internal type constraints are equal.
#pod
#pod =cut
sub type_constraints_equals {
my ( $self, $other ) = @_;
$self->_type_constraints_op_all($other, "equals");
}
sub _type_constraints_op_all {
my ($self, $other, $op) = @_;
return unless $other->isa(__PACKAGE__);
my @self_type_constraints = @{$self->type_constraints||[]};
my @other_type_constraints = @{$other->type_constraints||[]};
return unless @self_type_constraints == @other_type_constraints;
## Incoming ay be either arrayref or hashref, need top compare both
while(@self_type_constraints) {
my $self_type_constraint = shift @self_type_constraints;
my $other_type_constraint = shift @other_type_constraints;
$_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
for $self_type_constraint, $other_type_constraint;
my $result = $self_type_constraint->$op($other_type_constraint);
return unless $result;
}
return 1; ##If we get this far, everything is good.
}
sub _type_constraints_op_any {
my ($self, $other, $op) = @_;
return unless $other->isa(__PACKAGE__);
my @self_type_constraints = @{$self->type_constraints||[]};
my @other_type_constraints = @{$other->type_constraints||[]};
return unless @self_type_constraints == @other_type_constraints;
## Incoming ay be either arrayref or hashref, need top compare both
while(@self_type_constraints) {
my $self_type_constraint = shift @self_type_constraints;
my $other_type_constraint = shift @other_type_constraints;
$_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
for $self_type_constraint, $other_type_constraint;
return 1 if $self_type_constraint->$op($other_type_constraint);
}
return 0;
}
#pod =method get_message
#pod
#pod Give you a better peek into what's causing the error. For now we stringify the
#pod incoming deep value with L<Devel::PartialDump> and pass that on to either your
#pod custom error message or the default one. In the future we'll try to provide a
#pod more complete stack trace of the actual offending elements
#pod
#pod =cut
around 'get_message' => sub {
my ($get_message, $self, $value) = @_;
$value = Devel::PartialDump::dump($value)
if ref $value;
return $self->$get_message($value);
};
#pod =head1 SEE ALSO
#pod
#pod The following modules or resources may be of interest.
#pod
#pod L<Moose>, L<Moose::Meta::TypeConstraint>
#pod
#pod =cut
no Moose;
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Meta::TypeConstraint::Structured - Structured type constraints
=head1 VERSION
version 0.36
=for stopwords parameterize
=head1 DESCRIPTION
A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
such a way as that they are all applied to an incoming list of arguments. The
idea here is that a Type Constraint could be something like, "An C<Int> followed by
an C<Int> and then a C<Str>" and that this could be done so with a declaration like:
Tuple[Int,Int,Str]; ## Example syntax
So a structure is a list of type constraints (the C<Int,Int,Str> in the above
example) which are intended to function together.
=head1 ATTRIBUTES
=head2 type_constraints
A list of L<Moose::Meta::TypeConstraint> objects.
=head2 constraint_generator
=head1 METHODS
=head2 validate
Messing with validate so that we can support nicer error messages.
=head2 generate_constraint_for ($type_constraints)
Given some type constraints, use them to generate validation rules for an ref
of values (to be passed at check time)
=head2 parameterize (@type_constraints)
Given a ref of type constraints, create a structured type.
=head2 __infer_constraint_generator
=head2 compile_type_constraint
hook into compile_type_constraint so we can set the correct validation rules.
=head2 create_child_type
modifier to make sure we get the constraint_generator
=head2 is_a_type_of
=head2 is_subtype_of
=head2 equals
Override the base class behavior.
=head2 type_constraints_equals
Checks to see if the internal type constraints are equal.
=head2 get_message
Give you a better peek into what's causing the error. For now we stringify the
incoming deep value with L<Devel::PartialDump> and pass that on to either your
custom error message or the default one. In the future we'll try to provide a
more complete stack trace of the actual offending elements
=for stopwords subref
A subref or closure that contains the way we validate incoming values against
a set of type constraints.
=for stopwords servicable
This returns a CODEREF which generates a suitable constraint generator. Not
user servicable, you'll never call this directly.
=head1 SEE ALSO
The following modules or resources may be of interest.
L<Moose>, L<Moose::Meta::TypeConstraint>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types-Structured>
(or L<bug-MooseX-Types-Structured@rt.cpan.org|mailto:bug-MooseX-Types-Structured@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHORS
=over 4
=item *
John Napiorkowski <jjnapiork@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
=item *
Tomas (t0m) Doran <bobtfish@bobtfish.net>
=item *
Robert Sedlacek <rs@474.at>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by John Napiorkowski.
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

View File

@@ -0,0 +1,25 @@
package ## Hide from PAUSE
MooseX::Meta::TypeConstraint::Structured::Optional;
our $VERSION = '0.36';
use Moose;
use MooseX::Meta::TypeCoercion::Structured::Optional;
extends 'Moose::Meta::TypeConstraint::Parameterizable';
around parameterize => sub {
my $orig = shift;
my $self = shift;
my $ret = $self->$orig(@_);
$ret->coercion(MooseX::Meta::TypeCoercion::Structured::Optional->new(type_constraint => $ret));
return $ret;
};
no Moose;
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
1;

View File

@@ -0,0 +1,777 @@
use strict;
use warnings;
package MooseX::Method::Signatures; # git description: v0.48-15-gd03dfc1
# ABSTRACT: (DEPRECATED) Method declarations with type constraints and no source filter
# KEYWORDS: moose extension method declaration signature prototype syntax sugar deprecated
our $VERSION = '0.49';
use Moose 0.89;
use Devel::Declare 0.005011 ();
use B::Hooks::EndOfScope 0.10;
use Moose::Meta::Class;
use MooseX::LazyRequire 0.06;
use MooseX::Types::Moose 0.19 qw/Str Bool CodeRef/;
use Text::Balanced qw/extract_quotelike/;
use MooseX::Method::Signatures::Meta::Method;
use MooseX::Method::Signatures::Types qw/PrototypeInjections/;
use Sub::Name;
use Moose::Util 'find_meta';
use Module::Runtime 'use_module';
use Carp;
use aliased 'Devel::Declare::Context::Simple', 'ContextSimple';
use namespace::autoclean;
has package => (
is => 'ro',
isa => Str,
lazy_required => 1,
);
has context => (
is => 'ro',
isa => ContextSimple,
lazy => 1,
builder => '_build_context',
);
has initialized_context => (
is => 'ro',
isa => Bool,
default => 0,
);
has custom_method_application => (
is => 'ro',
isa => CodeRef,
predicate => 'has_custom_method_application',
);
has prototype_injections => (
is => 'ro',
isa => PrototypeInjections,
predicate => 'has_prototype_injections',
);
sub _build_context {
my ($self) = @_;
return ContextSimple->new(into => $self->package);
}
sub import {
my ($class, %args) = @_;
my $caller = caller();
$class->setup_for($caller, \%args);
}
sub setup_for {
my ($class, $pkg, $args) = @_;
# process arguments to import
while (my ($declarator, $injections) = each %{ $args }) {
my $obj = $class->new(
package => $pkg,
prototype_injections => {
declarator => $declarator,
injections => $injections,
},
);
Devel::Declare->setup_for($pkg, {
$declarator => { const => sub { $obj->parser(@_) } },
});
{
no strict 'refs';
*{ "${pkg}::$declarator" } = sub {};
}
}
my $self = $class->new(package => $pkg);
Devel::Declare->setup_for($pkg, {
method => { const => sub { $self->parser(@_) } },
});
{
no strict 'refs';
*{ "${pkg}::method" } = sub {};
}
return;
}
sub strip_name {
my ($self) = @_;
my $ctx = $self->context;
my $ret = $ctx->strip_name;
return $ret if defined $ret;
my $line = $ctx->get_linestr;
my $offset = $ctx->offset;
local $@;
my $copy = substr($line, $offset);
my ($str) = extract_quotelike($copy);
return unless defined $str;
return if ($@ && $@ =~ /^No quotelike operator found/);
die $@ if $@;
substr($line, $offset, length $str) = '';
$ctx->set_linestr($line);
return \$str;
}
sub strip_traits {
my ($self) = @_;
my $ctx = $self->context;
my $linestr = $ctx->get_linestr;
unless (substr($linestr, $ctx->offset, 2) eq 'is' ||
substr($linestr, $ctx->offset, 4) eq 'does') {
# No 'is' means no traits
return;
}
my @traits;
while (1) {
if (substr($linestr, $ctx->offset, 2) eq 'is') {
# Eat the 'is' so we can call strip_names_and_args
substr($linestr, $ctx->offset, 2) = '';
} elsif (substr($linestr, $ctx->offset, 4) eq 'does') {
# Eat the 'does' so we can call strip_names_and_args
substr($linestr, $ctx->offset, 4) = '';
} else {
last;
}
$ctx->set_linestr($linestr);
push @traits, @{ $ctx->strip_names_and_args };
# Get the current linestr so that the loop can look for more 'is'
$ctx->skipspace;
$linestr = $ctx->get_linestr;
}
confess "expected traits after 'is' or 'does', found nothing"
unless scalar(@traits);
# Let's check to make sure these traits aren't aliased locally
for my $t (@traits) {
next if $t->[0] =~ /::/;
my $class = $ctx->get_curstash_name;
my $meta = find_meta($class) || Moose::Meta::Class->initialize($class);
my $func = $meta->get_package_symbol('&' . $t->[0]);
next unless $func;
my $proto = prototype $func;
next if !defined $proto || length $proto;
$t->[0] = $func->();
}
return \@traits;
}
sub strip_return_type_constraint {
my ($self) = @_;
my $ctx = $self->context;
my $returns = $ctx->strip_name;
return unless defined $returns;
confess "expected 'returns', found '${returns}'"
unless $returns eq 'returns';
return $ctx->strip_proto;
}
sub parser {
my $self = shift;
my $err;
# Keep any previous compile errors from getting stepped on. But report
# errors from inside MXMS nicely.
{
local $@;
eval { $self->_parser(@_) };
$err = $@;
}
die $err if $err;
}
my $anon_counter = 1;
sub _parser {
my $self = shift;
my $ctx = $self->context;
$ctx->init(@_) unless $self->initialized_context;
$ctx->skip_declarator;
my $name = $self->strip_name;
my $proto = $ctx->strip_proto;
my $attrs = $ctx->strip_attrs || '';
my $traits = $self->strip_traits;
my $ret_tc = $self->strip_return_type_constraint;
my $compile_stash = $ctx->get_curstash_name;
my %args = (
# This might get reset later, but its where we search for exported
# symbols at compile time
package_name => $compile_stash,
);
$args{ signature } = qq{($proto)} if defined $proto;
$args{ traits } = $traits if $traits;
$args{ return_signature } = $ret_tc if defined $ret_tc;
# Class::MOP::Method requires a name
$args{ name } = $name || '__ANON__'.($anon_counter++).'__';
if ($self->has_prototype_injections) {
confess('Configured declarator does not match context declarator')
if $ctx->declarator ne $self->prototype_injections->{declarator};
$args{prototype_injections} = $self->prototype_injections->{injections};
}
my $meth_class = 'MooseX::Method::Signatures::Meta::Method';
if ($args{traits}) {
my @traits = ();
foreach my $t (@{$args{traits}}) {
use_module($t->[0]);
if ($t->[1]) {
%args = (%args, eval $t->[1]);
};
push @traits, $t->[0];
}
my $meta = Moose::Meta::Class->create_anon_class(
superclasses => [ $meth_class ],
roles => [ @traits ],
cache => 1,
);
$meth_class = $meta->name;
delete $args{traits};
}
my $proto_method = $meth_class->wrap(sub { }, %args);
my $after_block = ')';
if ($traits) {
if (my @trait_args = grep { defined } map { $_->[1] } @{ $traits }) {
$after_block = q{, } . join(q{,} => @trait_args) . $after_block;
}
}
if (defined $name) {
my $name_arg = q{, } . (ref $name ? ${$name} : qq{q[${name}]});
$after_block = $name_arg . $after_block . q{;};
}
my $inject = $proto_method->injectable_code;
$inject = $self->scope_injector_call($after_block) . $inject;
$ctx->inject_if_block($inject, "(sub ${attrs} ");
my $create_meta_method = sub {
my ($code, $pkg, $meth_name, @args) = @_;
subname $pkg . "::" .$meth_name, $code;
# we want to reinitialize with all the args,
# so we give the opportunity for traits to wrap the correct
# closure.
my %other_args = %{$proto_method};
delete $other_args{body};
delete $other_args{actual_body};
my $ret = $meth_class->wrap(
$code,
%other_args, @args
);
};
if (defined $name) {
my $apply = $self->has_custom_method_application
? $self->custom_method_application
: sub {
my ($meta, $name, $method) = @_;
if (warnings::enabled("redefine") && (my $meta_meth = $meta->get_method($name))) {
warnings::warn("redefine", "Method $name redefined on package ${ \$meta->name }")
if $meta_meth->isa('MooseX::Method::Signatures::Meta::Method');
}
$meta->add_method($name => $method);
};
$ctx->shadow(sub {
my ($code, $name, @args) = @_;
my $pkg = $compile_stash;
($pkg, $name) = $name =~ /^(.*)::([^:]+)$/
if $name =~ /::/;
my $meth = $create_meta_method->($code, $pkg, $name, @args);
my $meta = Moose::Meta::Class->initialize($pkg);
$meta->$apply($name, $meth);
return;
});
}
else {
$ctx->shadow(sub {
return $create_meta_method->(shift, $compile_stash, '__ANON__', @_);
});
}
}
sub scope_injector_call {
my ($self, $code) = @_;
$code =~ s/'/\\'/g; # we're generating code that's quoted with single quotes
return qq[BEGIN { ${\ref $self}->inject_scope('${code}') }];
}
sub inject_scope {
my ($class, $inject) = @_;
on_scope_end {
my $line = Devel::Declare::get_linestr();
return unless defined $line;
my $offset = Devel::Declare::get_linestr_offset();
substr($line, $offset, 0) = $inject;
Devel::Declare::set_linestr($line);
};
}
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Method::Signatures - (DEPRECATED) Method declarations with type constraints and no source filter
=head1 VERSION
version 0.49
=head1 SYNOPSIS
package Foo;
use Moose;
use MooseX::Method::Signatures;
method morning (Str $name) {
$self->say("Good morning ${name}!");
}
method hello (Str :$who, Int :$age where { $_ > 0 }) {
$self->say("Hello ${who}, I am ${age} years old!");
}
method greet (Str $name, Bool :$excited = 0) {
if ($excited) {
$self->say("GREETINGS ${name}!");
}
else {
$self->say("Hi ${name}!");
}
}
$foo->morning('Resi'); # This works.
$foo->hello(who => 'world', age => 42); # This too.
$foo->greet('Resi', excited => 1); # And this as well.
$foo->hello(who => 'world', age => 'fortytwo'); # This doesn't.
$foo->hello(who => 'world', age => -23); # This neither.
$foo->morning; # Won't work.
$foo->greet; # Will fail.
=head1 DESCRIPTION
Provides a proper method keyword, like "sub" but specifically for making methods
and validating their arguments against Moose type constraints.
=head1 DEPRECATION NOTICE
=for stopwords mst
=for comment rafl agreed we should have a warning, and mst wrote this for MooseX::Declare, but it applies equally well here:
B<Warning:> MooseX::Method::Signatures and L<MooseX::Declare> are based on
L<Devel::Declare>, a giant bag of crack originally implemented by mst with the
goal of upsetting the perl core developers so much by its very existence that
they implemented proper keyword handling in the core.
As of perl5 version 14, this goal has been achieved, and modules such as
L<Devel::CallParser>, L<Function::Parameters>, and L<Keyword::Simple> provide
mechanisms to mangle perl syntax that don't require hallucinogenic drugs to
interpret the error messages they produce.
If you want to use declarative syntax in new code, please for the love
of kittens get yourself a recent perl and look at L<Moops> and
L<core signatures|perlsub/Signatures> instead.
=head1 SIGNATURE SYNTAX
The signature syntax is heavily based on Perl 6. However not the full Perl 6
signature syntax is supported yet and some of it never will be.
=head2 Type Constraints
method foo ( $affe) # no type checking
method bar (Animal $affe) # $affe->isa('Animal')
method baz (Animal|Human $affe) # $affe->isa('Animal') || $affe->isa('Human')
=head2 Positional vs. Named
method foo ( $a, $b, $c) # positional
method bar (:$a, :$b, :$c) # named
method baz ( $a, $b, :$c) # combined
=head2 Required vs. Optional
method foo ($a , $b!, :$c!, :$d!) # required
method bar ($a?, $b?, :$c , :$d?) # optional
=head2 Defaults
method foo ($a = 42) # defaults to 42
=head2 Constraints
method foo ($foo where { $_ % 2 == 0 }) # only even
=for stopwords Invocant
=head2 Invocant
method foo ( $moo) # invocant is called $self and is required
method bar ($self: $moo) # same, but explicit
method baz ($class: $moo) # invocant is called $class
=head2 Labels
method foo (: $affe ) # called as $obj->foo(affe => $value)
method bar (:apan($affe)) # called as $obj->foo(apan => $value)
=head2 Traits
method foo (Affe $bar does trait)
method foo (Affe $bar is trait)
The only currently supported trait is C<coerce>, which will attempt to coerce
the value provided if it doesn't satisfy the requirements of the type
constraint.
=head2 Placeholders
method foo ($bar, $, $baz)
=for stopwords sigil
Sometimes you don't care about some parameters you're being called with. Just put
the bare sigil instead of a full variable name into the signature to avoid an
extra lexical variable to be created.
=head2 Complex Example
method foo ( SomeClass $thing where { $_->can('stuff') }:
Str $bar = "apan",
Int :$baz! = 42 where { $_ % 2 == 0 } where { $_ > 10 } )
# the invocant is called $thing, must be an instance of SomeClass and
has to implement a 'stuff' method
# $bar is positional, required, must be a string and defaults to "apan"
# $baz is named, required, must be an integer, defaults to 42 and needs
# to be even and greater than 10
=head1 CAVEATS AND NOTES
This module is as stable now, but this is not to say that it is entirely bug
free. If you notice any odd behaviour (messages not being as good as they could
for example) then please raise a bug.
=head2 Fancy signatures
L<Parse::Method::Signatures> is used to parse the signatures. However, some
signatures that can be parsed by it aren't supported by this module (yet).
=head2 No source filter
While this module does rely on the hairy black magic of L<Devel::Declare> it
does not depend on a source filter. As such, it doesn't try to parse and
rewrite your source code and there should be no weird side effects.
Devel::Declare only effects compilation. After that, it's a normal subroutine.
As such, for all that hairy magic, this module is surprisingly stable.
=head2 What about regular subroutines?
L<Devel::Declare> cannot yet change the way C<sub> behaves. However, the
L<signatures|signatures> module can. Right now it only provides very basic
signatures, but it's extendable enough that plugging MooseX::Method::Signatures
signatures into that should be quite possible.
=head2 What about the return value?
Type constraints for return values can be declared using
method foo (Int $x, Str $y) returns (Bool) { ... }
however, this feature only works with scalar return values and is still
considered to be experimental.
=head2 Interaction with L<Moose::Role>
=head3 Methods not seen by a role's C<requires>
Because the processing of the L<MooseX::Method::Signatures>
C<method> and the L<Moose> C<with> keywords are both
done at runtime, it can happen that a role will require
a method before it is declared (which will cause
Moose to complain very loudly and abort the program).
For example, the following will not work:
# in file Canine.pm
package Canine;
use Moose;
use MooseX::Method::Signatures;
with 'Watchdog';
method bark { print "Woof!\n"; }
1;
# in file Watchdog.pm
package Watchdog;
use Moose::Role;
requires 'bark'; # will assert! evaluated before 'method' is processed
sub warn_intruder {
my $self = shift;
my $intruder = shift;
$self->bark until $intruder->gone;
}
1;
A workaround for this problem is to use C<with> only
after the methods have been defined. To take our previous
example, B<Canine> could be reworked thus:
package Canine;
use Moose;
use MooseX::Method::Signatures;
method bark { print "Woof!\n"; }
with 'Watchdog';
1;
A better solution is to use L<MooseX::Declare> instead of plain
L<MooseX::Method::Signatures>. It defers application of roles until the end
of the class definition. With it, our example would becomes:
# in file Canine.pm
use MooseX::Declare;
class Canine with Watchdog {
method bark { print "Woof!\n"; }
}
1;
# in file Watchdog.pm
use MooseX::Declare;
role Watchdog {
requires 'bark';
method warn_intruder ( $intruder ) {
$self->bark until $intruder->gone;
}
}
1;
=head3 I<Subroutine redefined> warnings
When composing a L<Moose::Role> into a class that uses
L<MooseX::Method::Signatures>, you may get a "Subroutine redefined"
warning. This happens when both the role and the class define a
method/subroutine of the same name. (The way roles work, the one
defined in the class takes precedence.) To eliminate this warning,
make sure that your C<with> declaration happens after any
method/subroutine declarations that may have the same name as a
method/subroutine within a role.
=head1 SEE ALSO
=over 4
=item *
L<MooseX::Declare>
=item *
L<Method::Signatures::Simple>
=item *
L<Method::Signatures>
=item *
L<Devel::Declare>
=item *
L<Parse::Method::Signatures>
=item *
L<Moose>
=item *
L<signatures>
=back
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Method-Signatures>
(or L<bug-MooseX-Method-Signatures@rt.cpan.org|mailto:bug-MooseX-Method-Signatures@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
irc://irc.perl.org/#moose.
I am also usually active on irc, as 'ether' at C<irc.perl.org>.
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Ash Berlin Daniel Ruoso Justin Hunter Nicholas Perez Dagfinn Ilmari Mannsåker Rhesa Rozendaal Yanick Champoux Cory Watson Kent Fredric Lukas Mai Matt Kraai Jonathan Scott Duff Jesse Luehrs Hakim Cassimally Dave Rolsky Ricardo SIGNES Sebastian Willert Steffen Schwigon
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Ash Berlin <ash@cpan.org>
=item *
Daniel Ruoso <daniel@ruoso.com>
=item *
Justin Hunter <justin.d.hunter@gmail.com>
=item *
Nicholas Perez <nperez@cpan.org>
=item *
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
=item *
Rhesa Rozendaal <rhesa@cpan.org>
=item *
Yanick Champoux <yanick@babyl.dyndns.org>
=item *
Cory Watson <gphat@cpan.org>
=item *
Kent Fredric <kentfredric@gmail.com>
=item *
Lukas Mai <l.mai@web.de>
=item *
Matt Kraai <kraai@ftbfs.org>
=item *
Jonathan Scott Duff <duff@pobox.com>
=item *
Jesse Luehrs <doy@tozt.net>
=item *
Hakim Cassimally <osfameron@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Sebastian Willert <willert@cpan.org>
=item *
Steffen Schwigon <ss5@renormalist.net>
=back
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,489 @@
package MooseX::Method::Signatures::Meta::Method;
# ABSTRACT: (DEPRECATED) Provides the metaclass for methods with signatures
our $VERSION = '0.49';
use Moose;
use Carp qw/cluck/;
use Context::Preserve;
use Parse::Method::Signatures 1.003014;
use Parse::Method::Signatures::TypeConstraint;
use Scalar::Util qw/weaken/;
use Moose::Util qw/does_role/;
use Moose::Util::TypeConstraints;
use MooseX::Meta::TypeConstraint::ForceCoercion;
use MooseX::Types::Util qw/has_available_type_export/;
use MooseX::Types::Structured qw/Tuple Dict Optional slurpy/;
use MooseX::Types::Moose qw/ArrayRef Str Maybe Object Any CodeRef Bool/;
use MooseX::Method::Signatures::Types qw/Injections Params/;
use aliased 'Parse::Method::Signatures::Param::Named';
use aliased 'Parse::Method::Signatures::Param::Placeholder';
use namespace::autoclean;
extends 'Moose::Meta::Method';
has signature => (
is => 'ro',
isa => Str,
default => '(@)',
required => 1,
);
has parsed_signature => (
is => 'ro',
isa => class_type('Parse::Method::Signatures::Sig'),
lazy => 1,
builder => '_build_parsed_signature',
);
sub _parsed_signature {
cluck '->_parsed_signature is deprecated. use ->parsed_signature instead.';
shift->parsed_signature;
}
has _lexicals => (
is => 'ro',
isa => ArrayRef[Str],
lazy => 1,
builder => '_build__lexicals',
);
has injectable_code => (
is => 'ro',
isa => Str,
lazy => 1,
builder => '_build_injectable_code',
);
has _positional_args => (
is => 'ro',
isa => ArrayRef,
lazy => 1,
builder => '_build__positional_args',
);
has _named_args => (
is => 'ro',
isa => ArrayRef,
lazy => 1,
builder => '_build__named_args',
);
has _has_slurpy_positional => (
is => 'rw',
isa => Bool,
);
has type_constraint => (
is => 'ro',
isa => class_type('Moose::Meta::TypeConstraint'),
lazy => 1,
builder => '_build_type_constraint',
);
has return_signature => (
is => 'ro',
isa => Str,
predicate => 'has_return_signature',
);
has _return_type_constraint => (
is => 'ro',
isa => class_type('Moose::Meta::TypeConstraint'),
lazy => 1,
builder => '_build__return_type_constraint',
);
has actual_body => (
is => 'ro',
isa => CodeRef,
predicate => '_has_actual_body',
);
has prototype_injections => (
is => 'rw',
isa => Injections,
trigger => \&_parse_prototype_injections
);
has _parsed_prototype_injections => (
is => 'ro',
isa => Params,
predicate => '_has_parsed_prototype_injections',
writer => '_set_parsed_prototype_injections',
);
before actual_body => sub {
my ($self) = @_;
confess "method doesn't have an actual body yet"
unless $self->_has_actual_body;
};
around name => sub {
my ($next, $self) = @_;
my $ret = $self->$next;
confess "method doesn't have a name yet"
unless defined $ret;
return $ret;
};
sub _wrapped_body {
my ($class, $self, %args) = @_;
if (exists $args{return_signature}) {
return sub {
my @args = ${ $self }->validate(\@_);
return preserve_context { ${ $self }->actual_body->(@args) }
after => sub {
if (defined (my $msg = ${ $self }->_return_type_constraint->validate(\@_))) {
confess $msg;
}
};
};
}
my $actual_body;
return sub {
@_ = ${ $self }->validate(\@_);
$actual_body ||= ${ $self }->actual_body;
goto &{ $actual_body };
};
}
around wrap => sub {
my $orig = shift;
my $self;
my ($class, $code, %args);
if (ref $_[1]) {
($class, $code, %args) = @_;
} else {
($class, %args) = @_;
$code = delete $args{body};
}
my $wrapped = $class->_wrapped_body(\$self, %args);
$self = $class->$orig($wrapped, %args, $code ? (actual_body => $code) : ());
# Vivify the type constraints so TC lookups happen before namespace::clean
# removes them
$self->type_constraint;
$self->_return_type_constraint if $self->has_return_signature;
weaken($self->{associated_metaclass})
if $self->{associated_metaclass};
return $self;
};
sub reify {
my $self = shift;
my %args = @_;
my %other_args = %{$self};
delete $other_args{body};
delete $other_args{actual_body};
my $body = delete $args{body} || delete $args{actual_body} || $self->body;
my %final_args = (%other_args, %args);
return $self->meta->name->wrap($body, %final_args);
}
sub _build_parsed_signature {
my ($self) = @_;
return Parse::Method::Signatures->signature(
input => $self->signature,
from_namespace => $self->package_name,
);
}
sub _build__return_type_constraint {
my ($self) = @_;
confess 'no return type constraint'
unless $self->has_return_signature;
my $parser = Parse::Method::Signatures->new(
input => $self->return_signature,
from_namespace => $self->package_name,
);
my $param = $parser->_param_typed({});
confess 'failed to parse return value type constraint'
unless exists $param->{type_constraints};
return Tuple[$param->{type_constraints}->tc];
}
sub _param_to_spec {
my ($self, $param) = @_;
my $tc = Any;
{
# Ensure errors get reported from the right place
local $Carp::Internal{'MooseX::Method::Signatures::Meta::Method'} = 1;
local $Carp::Internal{'Moose::Meta::Method::Delegation'} = 1;
local $Carp::Internal{'Moose::Meta::Method::Accessor'} = 1;
local $Carp::Internal{'MooseX::Method::Signatures'} = 1;
local $Carp::Internal{'Devel::Declare'} = 1;
$tc = $param->meta_type_constraint
if $param->has_type_constraints;
}
if ($param->has_constraints) {
my $cb = join ' && ', map { "sub {${_}}->(\\\@_)" } $param->constraints;
my $code = eval "sub {${cb}}";
$tc = subtype({ as => $tc, where => $code });
}
my %spec;
if ($param->sigil ne '$') {
$spec{slurpy} = 1;
$tc = slurpy ArrayRef[$tc];
}
$spec{tc} = $param->required
? $tc
: Optional[$tc];
$spec{default} = $param->default_value
if $param->has_default_value;
if ($param->has_traits) {
for my $trait (@{ $param->param_traits }) {
next unless $trait->[1] eq 'coerce';
$spec{coerce} = 1;
}
}
return \%spec;
}
sub _parse_prototype_injections {
my $self = shift;
my @params;
for my $inject (@{ $self->prototype_injections }) {
my $param;
eval {
$param = Parse::Method::Signatures->param($inject);
};
confess "There was a problem parsing the prototype injection '$inject': $@"
if $@ || !defined $param;
push @params, $param;
}
my @return = reverse @params;
$self->_set_parsed_prototype_injections(\@return);
}
sub _build__lexicals {
my ($self) = @_;
my ($sig) = $self->parsed_signature;
my @lexicals;
if ($self->_has_parsed_prototype_injections) {
push @lexicals, $_->variable_name
for @{ $self->_parsed_prototype_injections };
}
push @lexicals, $sig->has_invocant
? $sig->invocant->variable_name
: '$self';
push @lexicals,
(does_role($_, Placeholder)
? 'undef'
: $_->variable_name)
for (($sig->has_positional_params ? $sig->positional_params : ()),
($sig->has_named_params ? $sig->named_params : ()));
return \@lexicals;
}
sub _build_injectable_code {
my ($self) = @_;
my $vars = join q{,}, @{ $self->_lexicals };
return "my (${vars}) = \@_;";
}
sub _build__positional_args {
my ($self) = @_;
my $sig = $self->parsed_signature;
my @positional;
if ($self->_has_parsed_prototype_injections) {
push @positional, map {
$self->_param_to_spec($_)
} @{ $self->_parsed_prototype_injections };
}
push @positional, $sig->has_invocant
? $self->_param_to_spec($sig->invocant)
: { tc => Object };
my $slurpy = 0;
if ($sig->has_positional_params) {
for my $param ($sig->positional_params) {
my $spec = $self->_param_to_spec($param);
$slurpy ||= 1 if $spec->{slurpy};
push @positional, $spec;
}
}
$self->_has_slurpy_positional($slurpy);
return \@positional;
}
sub _build__named_args {
my ($self) = @_;
my $sig = $self->parsed_signature;
# triggering building of positionals before named params is important
# because the latter needs to know if there have been any slurpy
# positionals to report errors
$self->_positional_args;
my @named;
if ($sig->has_named_params) {
confess 'Named parameters cannot be combined with slurpy positionals'
if $self->_has_slurpy_positional;
for my $param ($sig->named_params) {
push @named, $param->label => $self->_param_to_spec($param);
}
}
return \@named;
}
sub _build_type_constraint {
my ($self) = @_;
my ($positional, $named) = map { $self->$_ } map { "_${_}_args" } qw/positional named/;
my $tc = Tuple[
Tuple[ map { $_->{tc} } @{ $positional } ],
Dict[ map { ref $_ ? $_->{tc} : $_ } @{ $named } ],
];
my $coerce_param = sub {
my ($spec, $value) = @_;
return $value unless exists $spec->{coerce};
return $spec->{tc}->coerce($value);
};
my %named = @{ $named };
coerce $tc,
from ArrayRef,
via {
my (@positional_args, %named_args);
my $i = 0;
for my $param (@{ $positional }) {
push @positional_args, map { $coerce_param->($param, $_) }
$#{ $_ } < $i
? (exists $param->{default} ? eval $param->{default} : ())
: $_->[$i];
$i++;
}
if (%named) {
my @rest = @{ $_ }[$i .. $#{ $_ }];
confess "Expected named arguments but didn't find an even-sized list"
unless @rest % 2 == 0;
my %rest = @rest;
while (my ($key, $spec) = each %named) {
if (exists $rest{$key}) {
$named_args{$key} = $coerce_param->($spec, delete $rest{$key});
next;
}
if (exists $spec->{default}) {
$named_args{$key} = $coerce_param->($spec, eval $spec->{default});
}
}
@named_args{keys %rest} = values %rest;
}
elsif ($#{ $_ } >= $i) {
push @positional_args, @{ $_ }[$i .. $#{ $_ }];
}
return [\@positional_args, \%named_args];
};
return MooseX::Meta::TypeConstraint::ForceCoercion->new(
type_constraint => $tc,
);
}
sub validate {
my ($self, $args) = @_;
my @named = grep { !ref $_ } @{ $self->_named_args };
my $coerced;
if (defined (my $msg = $self->type_constraint->validate($args, \$coerced))) {
confess $msg;
}
return @{ $coerced->[0] }, map { $coerced->[1]->{$_} } @named;
}
__PACKAGE__->meta->make_immutable;
#pod =pod
#pod
#pod =for stopwords metaclass
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Method::Signatures::Meta::Method - (DEPRECATED) Provides the metaclass for methods with signatures
=head1 VERSION
version 0.49
=for stopwords metaclass
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Method-Signatures>
(or L<bug-MooseX-Method-Signatures@rt.cpan.org|mailto:bug-MooseX-Method-Signatures@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
irc://irc.perl.org/#moose.
I am also usually active on irc, as 'ether' at C<irc.perl.org>.
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,61 @@
package MooseX::Method::Signatures::Types;
#ABSTRACT: (DEPRECATED) Provides common MooseX::Types used by MooseX::Method::Signatures
our $VERSION = '0.49';
use MooseX::Types 0.19 -declare => [qw/ Injections PrototypeInjections Params /];
use MooseX::Types::Moose qw/Str ArrayRef/;
use MooseX::Types::Structured 0.24 qw/Dict/;
use Parse::Method::Signatures::Types qw/Param/;
use if MooseX::Types->VERSION >= 0.42, 'namespace::autoclean';
subtype Injections,
as ArrayRef[Str];
subtype PrototypeInjections,
as Dict[declarator => Str, injections => Injections];
subtype Params,
as ArrayRef[Param];
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Method::Signatures::Types - (DEPRECATED) Provides common MooseX::Types used by MooseX::Method::Signatures
=head1 VERSION
version 0.49
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Method-Signatures>
(or L<bug-MooseX-Method-Signatures@rt.cpan.org|mailto:bug-MooseX-Method-Signatures@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
irc://irc.perl.org/#moose.
I am also usually active on irc, as 'ether' at C<irc.perl.org>.
=head1 AUTHOR
Florian Ragwitz <rafl@debian.org>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2008 by Florian Ragwitz.
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

View File

@@ -0,0 +1,195 @@
package MooseX::NonMoose;
BEGIN {
$MooseX::NonMoose::AUTHORITY = 'cpan:DOY';
}
{
$MooseX::NonMoose::VERSION = '0.26';
}
use Moose::Exporter;
use Moose::Util;
# ABSTRACT: easy subclassing of non-Moose classes
my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods(
class_metaroles => {
class => ['MooseX::NonMoose::Meta::Role::Class'],
constructor => ['MooseX::NonMoose::Meta::Role::Constructor'],
},
install => [qw(import unimport)],
);
sub init_meta {
my $package = shift;
my %options = @_;
my $meta = Moose::Util::find_meta($options{for_class});
Carp::cluck('Roles have no use for MooseX::NonMoose')
if $meta && $meta->isa('Moose::Meta::Role');
$package->$init_meta(@_);
}
1;
__END__
=pod
=head1 NAME
MooseX::NonMoose - easy subclassing of non-Moose classes
=head1 VERSION
version 0.26
=head1 SYNOPSIS
package Term::VT102::NBased;
use Moose;
use MooseX::NonMoose;
extends 'Term::VT102';
has [qw/x_base y_base/] => (
is => 'ro',
isa => 'Int',
default => 1,
);
around x => sub {
my $orig = shift;
my $self = shift;
$self->$orig(@_) + $self->x_base - 1;
};
# ... (wrap other methods)
no Moose;
# no need to fiddle with inline_constructor here
__PACKAGE__->meta->make_immutable;
my $vt = Term::VT102::NBased->new(x_base => 0, y_base => 0);
=head1 DESCRIPTION
C<MooseX::NonMoose> allows for easily subclassing non-Moose classes with Moose,
taking care of the annoying details connected with doing this, such as setting
up proper inheritance from L<Moose::Object> and installing (and inlining, at
C<make_immutable> time) a constructor that makes sure things like C<BUILD>
methods are called. It tries to be as non-intrusive as possible - when this
module is used, inheriting from non-Moose classes and inheriting from Moose
classes should work identically, aside from the few caveats mentioned below.
One of the goals of this module is that including it in a
L<Moose::Exporter>-based package used across an entire application should be
possible, without interfering with classes that only inherit from Moose
modules, or even classes that don't inherit from anything at all.
There are several ways to use this module. The most straightforward is to just
C<use MooseX::NonMoose;> in your class; this should set up everything necessary
for extending non-Moose modules. L<MooseX::NonMoose::Meta::Role::Class> and
L<MooseX::NonMoose::Meta::Role::Constructor> can also be applied to your
metaclasses manually, either by passing a C<-traits> option to your C<use
Moose;> line, or by applying them using L<Moose::Util::MetaRole> in a
L<Moose::Exporter>-based package. L<MooseX::NonMoose::Meta::Role::Class> is the
part that provides the main functionality of this module; if you don't care
about inlining, this is all you need to worry about. Applying
L<MooseX::NonMoose::Meta::Role::Constructor> as well will provide an inlined
constructor when you immutabilize your class.
C<MooseX::NonMoose> allows you to manipulate the argument list that gets passed
to the superclass constructor by defining a C<FOREIGNBUILDARGS> method. This is
called with the same argument list as the C<BUILDARGS> method, but should
return a list of arguments to pass to the superclass constructor. This allows
C<MooseX::NonMoose> to support superclasses whose constructors would get
confused by the extra arguments that Moose requires (for attributes, etc.)
Not all non-Moose classes use C<new> as the name of their constructor. This
module allows you to extend these classes by explicitly stating which method is
the constructor, during the call to C<extends>. The syntax looks like this:
extends 'Foo' => { -constructor_name => 'create' };
similar to how you can already pass C<-version> in the C<extends> call in a
similar way.
=head1 BUGS/CAVEATS
=over 4
=item * The reference that the non-Moose class uses as its instance type
B<must> match the instance type that Moose is using. Moose's default instance
type is a hashref, but other modules exist to make Moose use other instance
types. L<MooseX::InsideOut> is the most general solution - it should work with
any class. For globref-based classes in particular, L<MooseX::GlobRef> will
also allow Moose to work. For more information, see the C<032-moosex-insideout>
and C<033-moosex-globref> tests bundled with this dist.
=item * Modifying your class' C<@ISA> after an initial C<extends> call will potentially
cause problems if any of those new entries in the C<@ISA> override the constructor.
C<MooseX::NonMoose> wraps the nearest C<new()> method at the time C<extends>
is called and will not see any other C<new()> methods in the @ISA hierarchy.
=item * Completely overriding the constructor in a class using
C<MooseX::NonMoose> (i.e. using C<sub new { ... }>) currently doesn't work,
although using method modifiers on the constructor should work identically to
normal Moose classes.
=back
Please report any bugs to GitHub Issues at
L<https://github.com/doy/moosex-nonmoose/issues>.
=head1 SEE ALSO
=over 4
=item * L<Moose::Manual::FAQ/How do I make non-Moose constructors work with Moose?>
=item * L<MooseX::Alien>
serves the same purpose, but with a radically different (and far more hackish)
implementation.
=back
=head1 SUPPORT
You can find this documentation for this module with the perldoc command.
perldoc MooseX::NonMoose
You can also look for information at:
=over 4
=item * MetaCPAN
L<https://metacpan.org/release/MooseX-NonMoose>
=item * Github
L<https://github.com/doy/moosex-nonmoose>
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MooseX-NonMoose>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/MooseX-NonMoose>
=back
=for Pod::Coverage init_meta
=head1 AUTHOR
Jesse Luehrs <doy@tozt.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Jesse Luehrs.
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

View File

@@ -0,0 +1,87 @@
package MooseX::NonMoose::InsideOut;
BEGIN {
$MooseX::NonMoose::InsideOut::AUTHORITY = 'cpan:DOY';
}
{
$MooseX::NonMoose::InsideOut::VERSION = '0.26';
}
use Moose::Exporter;
# ABSTRACT: easy subclassing of non-Moose non-hashref classes
my ($import, $unimport, $init_meta) = Moose::Exporter->build_import_methods(
class_metaroles => {
class => ['MooseX::NonMoose::Meta::Role::Class'],
constructor => ['MooseX::NonMoose::Meta::Role::Constructor'],
instance => ['MooseX::InsideOut::Role::Meta::Instance'],
},
install => [qw(import unimport)],
);
sub init_meta {
my $package = shift;
my %options = @_;
my $meta = Moose::Util::find_meta($options{for_class});
Carp::cluck('Roles have no use for MooseX::NonMoose')
if $meta && $meta->isa('Moose::Meta::Role');
$package->$init_meta(@_);
}
1;
__END__
=pod
=head1 NAME
MooseX::NonMoose::InsideOut - easy subclassing of non-Moose non-hashref classes
=head1 VERSION
version 0.26
=head1 SYNOPSIS
package Term::VT102::NBased;
use Moose;
use MooseX::NonMoose::InsideOut;
extends 'Term::VT102';
has [qw/x_base y_base/] => (
is => 'ro',
isa => 'Int',
default => 1,
);
around x => sub {
my $orig = shift;
my $self = shift;
$self->$orig(@_) + $self->x_base - 1;
};
# ... (wrap other methods)
no Moose;
# no need to fiddle with inline_constructor here
__PACKAGE__->meta->make_immutable;
my $vt = Term::VT102::NBased->new(x_base => 0, y_base => 0);
=head1 DESCRIPTION
=for Pod::Coverage init_meta
=head1 AUTHOR
Jesse Luehrs <doy@tozt.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Jesse Luehrs.
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

View File

@@ -0,0 +1,416 @@
package MooseX::NonMoose::Meta::Role::Class;
BEGIN {
$MooseX::NonMoose::Meta::Role::Class::AUTHORITY = 'cpan:DOY';
}
{
$MooseX::NonMoose::Meta::Role::Class::VERSION = '0.26';
}
use Moose::Role;
# ABSTRACT: metaclass trait for L<MooseX::NonMoose>
use List::MoreUtils qw(any);
use Module::Runtime qw(use_package_optimistically);
use Try::Tiny;
has has_nonmoose_constructor => (
is => 'rw',
isa => 'Bool',
default => 0,
);
has has_nonmoose_destructor => (
is => 'rw',
isa => 'Bool',
default => 0,
);
# overrides the constructor_name attr that already exists
has constructor_name => (
is => 'rw',
isa => 'Str',
lazy => 1,
default => sub { shift->throw_error("No constructor name has been set") },
);
# XXX ugh, really need to fix this in moose
around reinitialize => sub {
my $orig = shift;
my $class = shift;
my ($pkg) = @_;
my $meta = blessed($pkg) ? $pkg : Moose::Util::find_meta($pkg);
$class->$orig(
@_,
(map { $_->init_arg => $_->get_value($meta) }
grep { $_->has_value($meta) }
map { $meta->meta->find_attribute_by_name($_) }
qw(has_nonmoose_constructor
has_nonmoose_destructor
constructor_name)),
);
};
sub _determine_constructor_options {
my $self = shift;
my @options = @_;
# if we're using just the metaclass trait, but not the constructor trait,
# then suppress the warning about not inlining a constructor
my $cc_meta = Moose::Util::find_meta($self->constructor_class);
return (@options, inline_constructor => 0)
unless $cc_meta->can('does_role')
&& $cc_meta->does_role('MooseX::NonMoose::Meta::Role::Constructor');
# do nothing if we explicitly ask for the constructor to not be inlined
my %options = @options;
return @options if !$options{inline_constructor};
my $constructor_name = $self->constructor_name;
my $local_constructor = $self->get_method($constructor_name);
if (!defined($local_constructor)) {
warn "Not inlining a constructor for " . $self->name . " since "
. "its parent " . ($self->superclasses)[0] . " doesn't contain a "
. "constructor named '$constructor_name'. "
. "If you are certain you don't need to inline your"
. " constructor, specify inline_constructor => 0 in your"
. " call to " . $self->name . "->meta->make_immutable\n";
return @options;
}
# do nothing if extends was called, but we then added a method modifier to
# the constructor (this will warn, but that's okay)
# XXX: this is a fairly big hack, but it should cover most of the cases
# that actually show up in practice... it would be nice to do this properly
# though
return @options
if $local_constructor->isa('Class::MOP::Method::Wrapped');
# otherwise, explicitly ask for the constructor to be replaced (to suppress
# the warning message), since this is the expected usage, and shouldn't
# cause a warning
return (replace_constructor => 1, @options);
}
sub _determine_destructor_options {
my $self = shift;
my @options = @_;
return (@options, inline_destructor => 0);
}
around _immutable_options => sub {
my $orig = shift;
my $self = shift;
my @options = $self->$orig(@_);
# do nothing if extends was never called
return @options if !$self->has_nonmoose_constructor
&& !$self->has_nonmoose_destructor;
@options = $self->_determine_constructor_options(@options);
@options = $self->_determine_destructor_options(@options);
return @options;
};
sub _check_superclass_constructor {
my $self = shift;
# if the current class defined a custom new method (since subs happen at
# BEGIN time), don't try to override it
return if $self->has_method($self->constructor_name);
# we need to get the non-moose constructor from the superclass
# of the class where this method actually exists, regardless of what class
# we're calling it on
my $super_new = $self->find_next_method_by_name($self->constructor_name);
# if we're trying to extend a (non-immutable) moose class, just do nothing
return if $super_new->package_name eq 'Moose::Object';
if ($super_new->associated_metaclass->can('constructor_class')) {
my $constructor_class_meta = Class::MOP::Class->initialize(
$super_new->associated_metaclass->constructor_class
);
# if the constructor we're inheriting is already one of ours, there's
# no reason to install a new one
return if $constructor_class_meta->can('does_role')
&& $constructor_class_meta->does_role('MooseX::NonMoose::Meta::Role::Constructor');
# if the constructor we're inheriting is an inlined version of the
# default moose constructor, don't do anything either
return if any { $_->isa($constructor_class_meta->name) }
$super_new->associated_metaclass->_inlined_methods;
}
$self->add_method($self->constructor_name => sub {
my $class = shift;
my $params = $class->BUILDARGS(@_);
my @foreign_params = $class->can('FOREIGNBUILDARGS')
? $class->FOREIGNBUILDARGS(@_)
: @_;
my $instance = $super_new->execute($class, @foreign_params);
if (!blessed($instance)) {
confess "The constructor for "
. $super_new->associated_metaclass->name
. " did not return a blessed instance";
}
elsif (!$instance->isa($class)) {
if (!$class->isa(blessed($instance))) {
confess "The constructor for "
. $super_new->associated_metaclass->name
. " returned an object whose class is not a parent of "
. $class;
}
else {
bless $instance, $class;
}
}
return Class::MOP::Class->initialize($class)->new_object(
__INSTANCE__ => $instance,
%$params,
);
});
$self->has_nonmoose_constructor(1);
}
sub _check_superclass_destructor {
my $self = shift;
# if the current class defined a custom DESTROY method (since subs happen
# at BEGIN time), don't try to override it
return if $self->has_method('DESTROY');
# we need to get the non-moose destructor from the superclass
# of the class where this method actually exists, regardless of what class
# we're calling it on
my $super_DESTROY = $self->find_next_method_by_name('DESTROY');
# if we're trying to extend a (non-immutable) moose class, just do nothing
return if $super_DESTROY->package_name eq 'Moose::Object';
if ($super_DESTROY->associated_metaclass->can('destructor_class')
&& $super_DESTROY->associated_metaclass->destructor_class) {
my $destructor_class_meta = Class::MOP::Class->initialize(
$super_DESTROY->associated_metaclass->destructor_class
);
# if the destructor we're inheriting is an inlined version of the
# default moose destructor, don't do anything
return if any { $_->isa($destructor_class_meta->name) }
$super_DESTROY->associated_metaclass->_inlined_methods;
}
$self->add_method(DESTROY => sub {
my $self = shift;
local $?;
Try::Tiny::try {
$super_DESTROY->execute($self);
$self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction);
}
Try::Tiny::catch {
# Without this, Perl will warn "\t(in cleanup)$@" because of some
# bizarre fucked-up logic deep in the internals.
no warnings 'misc';
die $_;
};
return;
});
$self->has_nonmoose_destructor(1);
}
around superclasses => sub {
my $orig = shift;
my $self = shift;
return $self->$orig unless @_;
# XXX lots of duplication between here and MMC::superclasses
my ($constructor_name, $constructor_class);
for my $super (@{ Data::OptList::mkopt(\@_) }) {
my ($name, $opts) = @{ $super };
my $cur_constructor_name = delete $opts->{'-constructor_name'};
if (defined($constructor_name) && defined($cur_constructor_name)) {
$self->throw_error(
"You have already specified "
. "${constructor_class}::${constructor_name} as the parent "
. "constructor; ${name}::${cur_constructor_name} cannot also be "
. "the constructor"
);
}
if ($opts && exists($opts->{-version})) {
use_package_optimistically($name, $opts->{-version});
}
else {
use_package_optimistically($name);
}
if (defined($cur_constructor_name)) {
my $meta = Moose::Util::find_meta($name);
$self->throw_error(
"You specified '$cur_constructor_name' as the constructor for "
. "$name, but $name has no method by that name"
) unless $meta
? $meta->find_method_by_name($cur_constructor_name)
: $name->can($cur_constructor_name);
}
if (!defined($constructor_name)) {
$constructor_name = $cur_constructor_name;
$constructor_class = $name;
}
delete $opts->{'-constructor_name'};
}
$self->constructor_name(
defined($constructor_name) ? $constructor_name : 'new'
);
my @superclasses = @_;
push @superclasses, 'Moose::Object'
unless grep { !ref($_) && $_->isa('Moose::Object') } @superclasses;
my @ret = $self->$orig(@superclasses);
$self->_check_superclass_constructor;
$self->_check_superclass_destructor;
return @ret;
};
sub _generate_fallback_constructor {
my $self = shift;
my ($class_var) = @_;
my $new = $self->constructor_name;
my $super_new_class = $self->_find_next_nonmoose_constructor_package;
my $arglist = $self->find_method_by_name('FOREIGNBUILDARGS')
? "${class_var}->FOREIGNBUILDARGS(\@_)"
: '@_';
my $instance = "${class_var}->${super_new_class}::$new($arglist)";
# XXX: the "my $__DUMMY = " part is because "return do" triggers a weird
# bug in pre-5.12 perls (it ends up returning undef)
return '(my $__DUMMY = do { '
. 'if (ref($_[0]) eq \'HASH\') { '
. '$_[0]->{__INSTANCE__} = ' . $instance . ' '
. 'unless exists $_[0]->{__INSTANCE__}; '
. '} '
. 'else { '
. 'unshift @_, __INSTANCE__ => ' . $instance . '; '
. '} '
. $class_var . '->Moose::Object::new(@_); '
. '})';
}
sub _inline_generate_instance {
my $self = shift;
my ($var, $class_var) = @_;
my $new = $self->constructor_name;
my $super_new_class = $self->_find_next_nonmoose_constructor_package;
my $arglist = $self->find_method_by_name('FOREIGNBUILDARGS')
? "${class_var}->FOREIGNBUILDARGS(\@_)"
: '@_';
my $instance = "${class_var}->${super_new_class}::$new($arglist)";
return (
'my ' . $var . ' = ' . $instance . ';',
'if (!Scalar::Util::blessed(' . $var . ')) {',
$self->_inline_throw_error(
'"The constructor for ' . $super_new_class . ' did not return a blessed instance"',
) . ';',
'}',
'elsif (!' . $var . '->isa(' . $class_var . ')) {',
'if (!' . $class_var . '->isa(Scalar::Util::blessed(' . $var . '))) {',
$self->_inline_throw_error(
'"The constructor for ' . $super_new_class . ' returned an object whose class is not a parent of ' . $class_var . '"',
) . ';',
'}',
'else {',
$self->_inline_rebless_instance($var, $class_var) . ';',
'}',
'}',
);
}
sub _find_next_nonmoose_constructor_package {
my $self = shift;
my $new = $self->constructor_name;
for my $method (map { $_->{code} } $self->find_all_methods_by_name($new)) {
next if $method->associated_metaclass->meta->can('does_role')
&& $method->associated_metaclass->meta->does_role('MooseX::NonMoose::Meta::Role::Class');
return $method->package_name;
}
# this should never happen (it should find Moose::Object at least)
$self->throw_error("Couldn't find a non-Moose constructor for " . $self->name);
}
no Moose::Role;
1;
__END__
=pod
=head1 NAME
MooseX::NonMoose::Meta::Role::Class - metaclass trait for L<MooseX::NonMoose>
=head1 VERSION
version 0.26
=head1 SYNOPSIS
package Foo;
use Moose -traits => 'MooseX::NonMoose::Meta::Role::Class';
# or
package My::Moose;
use Moose ();
use Moose::Exporter;
Moose::Exporter->setup_import_methods;
sub init_meta {
shift;
my %options = @_;
Moose->init_meta(%options);
Moose::Util::MetaRole::apply_metaclass_roles(
for_class => $options{for_class},
metaclass_roles => ['MooseX::NonMoose::Meta::Role::Class'],
);
return Moose::Util::find_meta($options{for_class});
}
=head1 DESCRIPTION
This trait implements everything involved with extending non-Moose classes,
other than doing the actual inlining at C<make_immutable> time. See
L<MooseX::NonMoose> for more details.
=head1 AUTHOR
Jesse Luehrs <doy@tozt.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Jesse Luehrs.
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

View File

@@ -0,0 +1,81 @@
package MooseX::NonMoose::Meta::Role::Constructor;
BEGIN {
$MooseX::NonMoose::Meta::Role::Constructor::AUTHORITY = 'cpan:DOY';
}
{
$MooseX::NonMoose::Meta::Role::Constructor::VERSION = '0.26';
}
use Moose::Role 2.0000;
# ABSTRACT: constructor method trait for L<MooseX::NonMoose>
around can_be_inlined => sub {
my $orig = shift;
my $self = shift;
my $meta = $self->associated_metaclass;
my $super_new = $meta->find_method_by_name($self->name);
my $super_meta = $super_new->associated_metaclass;
if (Moose::Util::find_meta($super_meta)->can('does_role')
&& Moose::Util::find_meta($super_meta)->does_role('MooseX::NonMoose::Meta::Role::Class')) {
return 1;
}
return $self->$orig(@_);
};
no Moose::Role;
1;
__END__
=pod
=head1 NAME
MooseX::NonMoose::Meta::Role::Constructor - constructor method trait for L<MooseX::NonMoose>
=head1 VERSION
version 0.26
=head1 SYNOPSIS
package My::Moose;
use Moose ();
use Moose::Exporter;
Moose::Exporter->setup_import_methods;
sub init_meta {
shift;
my %options = @_;
Moose->init_meta(%options);
Moose::Util::MetaRole::apply_metaclass_roles(
for_class => $options{for_class},
metaclass_roles => ['MooseX::NonMoose::Meta::Role::Class'],
constructor_class_roles =>
['MooseX::NonMoose::Meta::Role::Constructor'],
);
return Moose::Util::find_meta($options{for_class});
}
=head1 DESCRIPTION
This trait implements inlining of the constructor for classes using the
L<MooseX::NonMoose::Meta::Role::Class> metaclass trait; it has no effect unless
that trait is also used. See those docs and the docs for L<MooseX::NonMoose>
for more information.
=head1 AUTHOR
Jesse Luehrs <doy@tozt.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Jesse Luehrs.
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

View File

@@ -0,0 +1,50 @@
use strict;
use warnings;
package MooseX::Role::Parameterised;
# vim: set ts=8 sts=4 sw=4 tw=115 et :
# ABSTRACT: Moose roles with composition parameters
our $VERSION = '1.11';
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterised - Moose roles with composition parameters
=head1 VERSION
version 1.11
=head1 SYNOPSIS
See L<MooseX::Role::Parameterized>; this module is just a stub to help the
civilised Perl users find this distribution with search engines. :)
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,298 @@
package MooseX::Role::Parameterized; # git description: v1.10-8-g9de4ac3
# ABSTRACT: Moose roles with composition parameters
# KEYWORDS: moose extension parameter role arguments dynamic parameterised parameterizable parameterisable
our $VERSION = '1.11';
use 5.008001;
use Moose 2.0300 ();
use Moose::Exporter;
use Carp 'confess';
use Moose::Util 'find_meta';
use namespace::clean 0.19;
use MooseX::Role::Parameterized::Meta::Trait::Parameterizable;
our $CURRENT_METACLASS;
sub current_metaclass { $CURRENT_METACLASS }
my $meta_lookup = sub {
my $for = shift;
current_metaclass() || find_meta($for);
};
Moose::Exporter->setup_import_methods(
also => 'Moose::Role',
with_caller => [ 'parameter', 'role' ],
with_meta => [ 'method', 'with' ],
meta_lookup => $meta_lookup,
role_metaroles => {
role => ['MooseX::Role::Parameterized::Meta::Trait::Parameterizable'],
},
);
sub parameter {
my $caller = shift;
confess "'parameter' may not be used inside of the role block"
if current_metaclass && current_metaclass->genitor->name eq $caller;
my $meta = find_meta($caller);
my $names = shift;
$names = [$names] if !ref($names);
for my $name (@$names) {
$meta->add_parameter($name => (
is => 'ro',
@_,
));
}
}
sub role (&) {
my $caller = shift;
my $role_generator = shift;
confess "'role' may not be used inside of the role block"
if current_metaclass && current_metaclass->genitor->name eq $caller;
find_meta($caller)->role_generator($role_generator);
}
sub method {
my $meta = shift;
my $name = shift;
my $body = shift;
my $method = $meta->method_metaclass->wrap(
package_name => $meta->name,
name => $name,
body => $body,
);
$meta->add_method($name => $method);
}
sub with {
local $CURRENT_METACLASS = undef;
Moose::Role::with(@_);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterized - Moose roles with composition parameters
=head1 VERSION
version 1.11
=head1 SYNOPSIS
package Counter;
use MooseX::Role::Parameterized;
parameter name => (
isa => 'Str',
required => 1,
);
role {
my $p = shift;
my $name = $p->name;
has $name => (
is => 'rw',
isa => 'Int',
default => 0,
);
method "increment_$name" => sub {
my $self = shift;
$self->$name($self->$name + 1);
};
method "reset_$name" => sub {
my $self = shift;
$self->$name(0);
};
};
package MyGame::Weapon;
use Moose;
with Counter => { name => 'enchantment' };
package MyGame::Wand;
use Moose;
with Counter => { name => 'zapped' };
=head1 DESCRIPTION
Your parameterized role consists of two new things: parameter declarations
and a C<role> block.
Parameters are declared using the L</parameter> keyword which very much
resembles L<Moose/has>. You can use any option that L<Moose/has> accepts. The
default value for the C<is> option is C<ro> as that's a very common case. Use
C<< is => 'bare' >> if you want no accessor. These parameters will get their
values when the consuming class (or role) uses L<Moose/with>. A parameter
object will be constructed with these values, and passed to the C<role> block.
The C<role> block then uses the usual L<Moose::Role> keywords to build up a
role. You can shift off the parameter object to inspect what the consuming
class provided as parameters. You use the parameters to customize your
role however you wish.
There are many possible implementations for parameterized roles (hopefully with
a consistent enough API); I believe this to be the easiest and most flexible
design. Coincidentally, Pugs originally had an eerily similar design.
See L<MooseX::Role::Parameterized::Extending> for some tips on how to extend
this module.
=head2 Why a parameters object?
I've been asked several times "Why use a parameter I<object> and not just a
parameter I<hashref>? That would eliminate the need to explicitly declare your
parameters."
The benefits of using an object are similar to the benefits of using Moose. You
get an easy way to specify lazy defaults, type constraint, delegation, and so
on. You get to use MooseX modules.
=for Pod::Coverage current_metaclass method parameter role with
=head1 L<MooseX::Role::Parameterized::Tutorial>
B<Stop!> If you're new here, please read
L<MooseX::Role::Parameterized::Tutorial> for a much gentler introduction.
=for stopwords metaobject
You also get the usual introspective and intercessory abilities that come
standard with the metaobject protocol. Ambitious users should be able to add
traits to the parameters metaclass to further customize behavior. Please let
me know if you're doing anything viciously complicated with this extension. :)
=head1 CAVEATS
You must use this syntax to declare methods in the role block:
C<< method NAME => sub { ... }; >>. This is due to a limitation in Perl. In
return though you can use parameters I<in your methods>!
=head1 SEE ALSO
L<http://sartak.org/2009/01/parametric-roles-in-perl-5.html>
L<http://sartak.org/2009/05/the-design-of-parameterized-roles.html>
L<http://stevan-little.blogspot.com/2009/07/thoughts-on-parameterized-roles.html>
L<http://perldition.org/articles/Parameterized%20Roles%20with%20MooseX::Declare.pod>
L<http://www.modernperlbooks.com/mt/2011/01/the-parametric-role-of-my-mvc-plugin-system.html>
L<http://jjnapiorkowski.typepad.com/modern-perl/2010/08/parameterized-roles-and-method-traits-redo.html>
L<http://sartak.org/talks/yapc-asia-2009/(parameterized)-roles/>
=for stopwords Joose
L<https://github.com/SamuraiJack/JooseX-Role-Parameterized> - this extension ported to JavaScript's Joose
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Dave Rolsky Jesse Luehrs Oliver Charles Yuval Kogman Robert 'phaylon' Sedlacek Florian Ragwitz Mark Fowler Chris Weyl Csson Andy Jack Ricardo Signes Todd Hepler
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Dave Rolsky <autarch@urth.org>
=item *
Jesse Luehrs <doy@tozt.net>
=item *
Oliver Charles <oliver.g.charles@googlemail.com>
=item *
Yuval Kogman <nothingmuch@woobling.org>
=item *
Robert 'phaylon' Sedlacek <rs@474.at>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Mark Fowler <mark@twoshortplanks.com>
=item *
Chris Weyl <cweyl@alumni.drew.edu>
=item *
Csson <erik.carlsson@live.com>
=item *
Andy Jack <github@veracity.ca>
=item *
Ricardo Signes <rjbs@cpan.org>
=item *
Todd Hepler <thepler@employees.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,87 @@
# PODNAME: MooseX::Role::Parameterized::Extending
# ABSTRACT: extending MooseX::Role::Parameterized roles
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterized::Extending - extending MooseX::Role::Parameterized roles
=head1 VERSION
version 1.11
=head1 DESCRIPTION
There are heaps of useful modules in the C<MooseX> namespace that you can use
to make your roles more powerful. However, they do not always work out of the
box with L<MooseX::Role::Parameterized>, but it's fairly straight-forward to
achieve the functionality you desire.
L<MooseX::Role::Parameterized> was designed to be as extensible as the rest of
L<Moose>, and as such it is possible to apply custom traits to both the
parameterizable role or the ordinary roles they generate. In this example, we
will look at applying the fake trait C<MooseX::MagicRole> to a parameterizable
role.
First we need to define a new metaclass for our parameterizable role.
package MyApp::Meta::Role::Parameterizable;
use Moose;
extends 'MooseX::Role::Parameterized::Meta::Role::Parameterizable';
with 'MooseX::MagicRole';
This is a class (observe that it uses L<Moose>, not L<Moose::Role>) which
extends the class which governs parameterizable roles.
L<MooseX::Role::Parameterized::Meta::Role::Parameterizable> is the metaclass
that packages using L<MooseX::Role::Parameterized> receive by default.
Note that the class we are extending,
L<MooseX::Role::Parameterized::Meta::Role::ParameterizB<I<able>>|MooseX::Role::Parameterized::Meta::Role::Parameterizable>,
is entirely distinct from the similarly-named class which governs the
ordinary roles that parameterized roles generate. An instance of
L<MooseX::Role::Parameterized::Meta::Role::ParameterizB<I<ed>>|MooseX::Role::Parameterized>
represents a role with its parameters already bound.
Now we can take advantage of our new subclass by specifying that we want to use
C<MyApp::Meta::Role::Parameterizable> as our metaclass when importing
L<MooseX::Role::Parameterized>:
package MyApp::Role;
use MooseX::Role::Parameterized -metaclass => 'MyApp::Meta::Role::Parameterizable';
role {
...
}
And there you go! C<MyApp::Role> now has the C<MooseX::MagicRole> trait applied.
=head1 NAME
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,57 @@
package MooseX::Role::Parameterized::Meta::Role::Parameterized;
# ABSTRACT: metaclass for parameterized roles
our $VERSION = '1.11';
use Moose;
extends 'Moose::Meta::Role';
with 'MooseX::Role::Parameterized::Meta::Trait::Parameterized';
__PACKAGE__->meta->make_immutable;
no Moose;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterized::Meta::Role::Parameterized - metaclass for parameterized roles
=head1 VERSION
version 1.11
=head1 DESCRIPTION
This is the metaclass for parameterized roles; that is, parameterizable roles
with their parameters bound. See
L<MooseX::Role::Parameterized::Meta::Trait::Parameterized> which has all the guts.
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,262 @@
package MooseX::Role::Parameterized::Meta::Trait::Parameterizable;
# ABSTRACT: trait for parameterizable roles
our $VERSION = '1.11';
use Moose::Role;
use MooseX::Role::Parameterized::Meta::Role::Parameterized;
use MooseX::Role::Parameterized::Parameters;
use Module::Runtime 'use_module';
use namespace::autoclean;
has parameterized_role_metaclass => (
is => 'ro',
isa => 'ClassName',
default => 'MooseX::Role::Parameterized::Meta::Role::Parameterized',
);
has parameters_class => (
is => 'ro',
isa => 'ClassName',
default => 'MooseX::Role::Parameterized::Parameters',
);
has parameters_metaclass => (
is => 'rw',
isa => 'Moose::Meta::Class',
lazy => 1,
builder => '_build_parameters_metaclass',
handles => {
has_parameter => 'has_attribute',
add_parameter => 'add_attribute',
construct_parameters => 'new_object',
},
predicate => '_has_parameters_metaclass',
);
has role_generator => (
is => 'rw',
isa => 'CodeRef',
predicate => 'has_role_generator',
);
sub _build_parameters_metaclass {
my $self = shift;
return $self->parameters_class->meta->create_anon_class(
superclasses => [$self->parameters_class],
);
}
my $package_counter = 0;
sub generate_role {
my $self = shift;
my %args = @_;
my $parameters = blessed($args{parameters})
? $args{parameters}
: $self->construct_parameters(%{ $args{parameters} });
confess "A role generator is required to apply parameterized roles (did you forget the 'role { ... }' block in your parameterized role '".$self->name."'?)"
unless $self->has_role_generator;
my $parameterized_role_metaclass = $self->parameterized_role_metaclass;
use_module($parameterized_role_metaclass);
my $package = $args{package};
unless ($package) {
$package_counter++;
$package = $self->name . '::__ANON__::SERIAL::' . $package_counter;
}
my $role = $parameterized_role_metaclass->create(
$package,
genitor => $self,
parameters => $parameters,
);
local $MooseX::Role::Parameterized::CURRENT_METACLASS = $role;
# The generate_role method is being called directly by things like
# MooseX::ClassCompositor. We don't want to force such modules to pass
# this arg so we default to something sane.
my $orig_apply = $args{orig_apply} || Moose::Meta::Role->can('apply');
$self->$orig_apply($role);
$self->role_generator->($parameters,
operating_on => $role,
consumer => $args{consumer},
);
# don't just return $role here, because it might have been changed when
# metaroles are applied
return $MooseX::Role::Parameterized::CURRENT_METACLASS;
}
sub _role_for_combination {
my $self = shift;
my $parameters = shift;
return $self->generate_role(
parameters => $parameters,
);
}
around apply => sub {
my $orig = shift;
my $self = shift;
my $consumer = shift;
my %args = @_;
my $role = $self->generate_role(
consumer => $consumer,
parameters => \%args,
orig_apply => $orig,
);
$role->apply($consumer, %args);
};
around reinitialize => sub {
my $orig = shift;
my $class = shift;
my ($pkg) = @_;
my $meta = blessed($pkg) ? $pkg : find_meta($pkg);
my $meta_meta = $meta->meta;
my %p;
if ( $meta_meta->can('does_role') && $meta_meta->does_role(__PACKAGE__) ) {
%p = map { $_ => $meta->$_ }
qw( parameterized_role_metaclass parameters_class );
$p{parameters_metaclass} = $meta->parameters_metaclass
if $meta->_has_parameters_metaclass;
$p{role_generator} = $meta->role_generator
if $meta->has_role_generator;
}
my $new = $class->$orig(
@_,
%p,
);
return $new;
};
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterized::Meta::Trait::Parameterizable - trait for parameterizable roles
=head1 VERSION
version 1.11
=head1 DESCRIPTION
This is the trait that is applied to the metaclass for parameterizable roles,
roles that have their parameters currently unbound. These are the roles that
you use L<Moose/with>, but instead of composing the parameterizable role, we
construct a new parameterized role
(L<MooseX::Role::Parameterized::Meta::Role::Parameterized>) and use that new
parameterized role instead.
=head1 ATTRIBUTES
=head2 parameterized_role_metaclass
The name of the class that will be used to construct the parameterized role.
=head2 parameters_class
The name of the class that will be used to construct the parameters object.
=head2 parameters_metaclass
A metaclass representing this role's parameters. It will be an anonymous
subclass of L</parameters_class>. Each call to
L<MooseX::Role::Parameters/parameter> adds an attribute to this metaclass.
When this role is consumed, the parameters object will be instantiated using
this metaclass.
=head2 role_generator
A code reference that is used to generate a role based on the parameters
provided by the consumer. The user usually specifies it using the
L<MooseX::Role::Parameterized/role> keyword.
=head1 METHODS
=head2 add_parameter $name, %options
Delegates to L<Moose::Meta::Class/add_attribute> on the
L</parameters_metaclass> object.
=head2 construct_parameters %arguments
Creates a new L<MooseX::Role::Parameterized::Parameters> object using metaclass
L</parameters_metaclass>.
The arguments are those specified by the consumer as parameter values.
=head2 generate_role %arguments
This method generates and returns a new instance of
L</parameterized_role_metaclass>. It can take any combination of
three named arguments:
=over 4
=item parameters
A hashref of parameters for the role, same as would be passed in at a "with"
statement.
=item package
A package name that, if present, we will use for the generated role; if not,
we generate an anonymous role.
=item consumer
=for stopwords metaobject
A consumer metaobject, if available.
=back
=head2 apply
Overrides L<Moose::Meta::Role/apply> to automatically generate the
parameterized role.
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,101 @@
package MooseX::Role::Parameterized::Meta::Trait::Parameterized;
# ABSTRACT: trait for parameterized roles
our $VERSION = '1.11';
use Moose::Role;
use MooseX::Role::Parameterized::Parameters;
use Moose::Util 'find_meta';
use namespace::autoclean;
has genitor => (
is => 'ro',
does => 'MooseX::Role::Parameterized::Meta::Trait::Parameterizable',
required => 1,
);
has parameters => (
is => 'rw',
isa => 'MooseX::Role::Parameterized::Parameters',
);
around reinitialize => sub {
my $orig = shift;
my $class = shift;
my ($pkg) = @_;
my $meta = blessed($pkg) ? $pkg : find_meta($pkg);
my $genitor = $meta->genitor;
my $parameters = $meta->parameters;
my $new = $class->$orig(
@_,
(defined($genitor) ? (genitor => $genitor) : ()),
(defined($parameters) ? (parameters => $parameters) : ()),
);
# in case the role metaclass was reinitialized
$MooseX::Role::Parameterized::CURRENT_METACLASS = $new;
return $new;
};
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterized::Meta::Trait::Parameterized - trait for parameterized roles
=head1 VERSION
version 1.11
=head1 DESCRIPTION
This is the trait for parameterized roles; that is, parameterizable roles with
their parameters bound. All this actually provides is a place to store the
L<MooseX::Role::Parameterized::Parameters> object as well as the
L<MooseX::Role::Parameterized::Meta::Role::Parameterizable> object that
generated this role object.
=head1 ATTRIBUTES
=for stopwords genitor metaobject
=head2 genitor
Returns the L<MooseX::Role::Parameterized::Meta::Role::Parameterizable>
metaobject that generated this role.
=head2 parameters
Returns the L<MooseX::Role::Parameterized::Parameters> object that represents
the specific parameter values for this parameterized role.
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,60 @@
package MooseX::Role::Parameterized::Parameters;
# ABSTRACT: base class for parameters
our $VERSION = '1.11';
use Moose;
__PACKAGE__->meta->make_immutable;
no Moose;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterized::Parameters - base class for parameters
=head1 VERSION
version 1.11
=head1 DESCRIPTION
This is the base class for parameter objects. Currently empty, but I reserve
the right to add things here.
Each parameterizable role gets their own anonymous subclass of this;
L<MooseX::Role::Parameterized/parameter> actually operates on these anonymous
subclasses.
Each parameterized role gets their own instance of the anonymous subclass
(owned by the parameterizable role).
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,248 @@
# PODNAME: MooseX::Role::Parameterized::Tutorial
# ABSTRACT: why and how
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Role::Parameterized::Tutorial - why and how
=head1 VERSION
version 1.11
=head1 MOTIVATION
Roles are composable units of behavior. They are useful for factoring out
functionality common to many classes from any part of your class hierarchy. See
L<Moose::Cookbook::Roles::Comparable_CodeReuse> for an introduction to L<Moose::Role>.
While combining roles affords you a great deal of flexibility, individual roles
have very little in the way of configurability. Core Moose provides C<-alias>
for renaming methods and C<-excludes> for ignoring methods. These options are
primarily for resolving role conflicts. Depending on how much of a purist you are,
these options are I<solely> for resolving role conflicts. See
L<Moose::Cookbook::Roles::Restartable_AdvancedComposition> for more about C<-alias> and C<-excludes>.
Because roles serve many different masters, they usually provide only the least
common denominator of functionality. To empower roles further, more
configurability than C<-alias> and C<-excludes> is required. Perhaps your role
needs to know which method to call when it is done processing. Or what default
value to use for its C<url> attribute.
Parameterized roles offer a solution to these (and other) kinds of problems.
=head1 USAGE
=head2 C<with>
The syntax of a class consuming a parameterized role has not changed
from the standard C<with>. You pass in parameters just like you
pass in C<-alias> and C<-excludes> to ordinary roles (though your
custom parameters do not get hyphens, since these are not core Moose
composition parameters):
with 'MyRole::InstrumentMethod' => {
method_name => 'dbh_do',
log_to => 'query.log',
};
You can still combine parameterized roles. You just need to specify parameters
immediately after the role they belong to:
with (
'My::Parameterized::Role' => {
needs_better_example => 1,
},
'My::Other::Role',
);
We, like Moose itself, use L<Data::OptList> to make sure that a list of role
names and associated parameters is handled correctly.
=head2 C<parameter>
Inside your parameterized role, you specify a set of parameters. This is
exactly like specifying the attributes of a class. Instead of L<Moose/has> you
use the keyword C<parameter>, but your parameters can use any options to
C<has>.
parameter 'delegation' => (
isa => 'HashRef|ArrayRef|RegexpRef',
predicate => 'has_delegation',
);
You do have to declare what parameters you accept, just like you have to
declare what attributes you accept for regular Moose objects.
One departure from C<has> is that we create a reader accessor for you by
default. In other words, we assume C<< is => 'ro' >>. We create this reader for
convenience because generally the parameterized role is the only consumer of
the parameters object, so data hiding is not as important than in the general
case of L<Moose/has>. If you do not want an accessor, you can use
C<< is => 'bare' >>.
=head2 C<role>
C<role> takes a block of code that will be used to generate your role with its
parameters bound. Here is where you declare components that depend on
parameters. You can declare attributes, methods, modifiers, etc. The first
argument to the C<role> is an object containing the parameters specified by
C<with>. You can access the parameters just like regular attributes on that
object.
Each time you compose this parameterized role, the C<role {}> block will be
executed. It will receive a new parameter object and produce an entirely new
role. That's the whole point, after all.
Due to limitations inherent in Perl, you must declare methods with
C<< method name => sub { ... } >> instead of the usual C<sub name { ... }>.
Your methods may, of course, close over the parameter object. This means that
your methods may use parameters however they wish!
=head1 USES
Ideally these will become fully-explained examples in something resembling
L<Moose::Cookbook>. But for now, only a brain dump.
=over 4
=item Configure a role's attributes
You can rename methods with core Moose, but now you can rename attributes. You
can now also choose type, default value, whether it's required, B<traits>, etc.
parameter traits => (
isa => 'ArrayRef',
default => sub { [] },
);
parameter type => (
isa => 'Str',
default => 'Any',
);
role {
my $p = shift;
has action => (
traits => $p->traits,
isa => $p->type,
...
);
};
=item Inform a role of your class' attributes and methods
Core roles can only require methods with specific names chosen by the role. Now
your roles can demand that the class specifies a method name you wish the role to
instrument, or which attributes to dump to a file.
parameter instrument_method => (
isa => 'Str',
required => 1,
);
role {
my $p = shift;
around $p->instrument_method => sub { ... };
};
=item Arbitrary execution choices
Your role may be able to provide configuration in how the role's methods
operate. For example, you can tell the role whether to save intermediate
states.
parameter save_intermediate => (
isa => 'Bool',
default => 0,
);
role {
my $p = shift;
method process => sub {
...
if ($p->save_intermediate) { ... }
...
};
};
=item Deciding a backend
Your role may be able to freeze and thaw your instances using L<YAML>, L<JSON>,
L<Storable>. Which backend to use can be a parameter.
parameter format => (
isa => (enum ['Storable', 'YAML', 'JSON']),
default => 'Storable',
);
role {
my $p = shift;
if ($p->format eq 'Storable') {
method freeze => \&Storable::freeze;
method thaw => \&Storable::thaw;
}
elsif ($p->format eq 'YAML') {
method freeze => \&YAML::Dump;
method thaw => \&YAML::Load;
}
...
};
=item Additional validation
Ordinary roles can require that its consumers have a particular list of method
names. Since parameterized roles have direct access to its consumer, you can inspect it and throw errors if the consumer does not meet your needs.
role {
my $p = shift;
my %args = @_;
my $consumer = $args{consumer};
$consumer->find_attribute_by_name('stack')
or confess "You must have a 'stack' attribute";
my $push = $consumer->find_method_by_name('push')
or confess "You must have a 'push' method";
my $params = $push->parsed_signature->positional_params->params;
@$params == 1
or confess "Your push method must take a single parameter";
$params->[0]->sigil eq '$'
or confess "Your push parameter must be a scalar";
...
};
=back
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Role-Parameterized>
(or L<bug-MooseX-Role-Parameterized@rt.cpan.org|mailto:bug-MooseX-Role-Parameterized@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Shawn M Moore <code@sartak.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Shawn M Moore.
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

View File

@@ -0,0 +1,264 @@
package MooseX::Traits; # git description: v0.12-22-g1b6e7ce
# ABSTRACT: Automatically apply roles at object creation time
our $VERSION = '0.13';
use Moose::Role;
use MooseX::Traits::Util qw(new_class_with_traits);
use warnings;
use warnings::register;
use namespace::autoclean;
has '_trait_namespace' => (
# no accessors or init_arg
init_arg => undef,
isa => 'Str',
is => 'bare',
);
sub with_traits {
my ($class, @traits) = @_;
my $new_class = new_class_with_traits(
$class,
@traits,
);
return $new_class->name;
}
# somewhat deprecated, but use if you want to
sub new_with_traits {
my $class = shift;
my ($hashref, %args) = 0;
if (ref($_[0]) eq 'HASH') {
%args = %{ +shift };
$hashref = 1;
} else {
%args = @_;
}
my $traits = delete $args{traits} || [];
my $new_class = $class->with_traits(ref $traits ? @$traits : $traits );
my $constructor = $new_class->meta->constructor_name;
confess "$class ($new_class) does not have a constructor defined via the MOP?"
if !$constructor;
return $new_class->$constructor($hashref ? \%args : %args);
}
# this code is broken and should never have been added. i probably
# won't delete it, but it is definitely not up-to-date with respect to
# other features, and never will be.
#
# runtime role application is fundamentally broken. if you really
# need it, write it yourself, but consider applying the roles before
# you create an instance.
#pod =for Pod::Coverage apply_traits
#pod
#pod =cut
sub apply_traits {
my ($self, $traits, $rebless_params) = @_;
# disable this warning with "use MooseX::Traits; no warnings 'MooseX::Traits'"
warnings::warnif('apply_traits is deprecated due to being fundamentally broken. '.
q{disable this warning with "no warnings 'MooseX::Traits'"});
# arrayify
my @traits = $traits;
@traits = @$traits if ref $traits;
if (@traits) {
@traits = MooseX::Traits::Util::resolve_traits(
$self, @traits,
);
for my $trait (@traits){
$trait->meta->apply($self, rebless_params => $rebless_params || {});
}
}
}
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Traits - Automatically apply roles at object creation time
=head1 VERSION
version 0.13
=head1 SYNOPSIS
Given some roles:
package Role;
use Moose::Role;
has foo => ( is => 'ro', isa => 'Int' required => 1 );
And a class:
package Class;
use Moose;
with 'MooseX::Traits';
Apply the roles to the class at C<new> time:
my $class = Class->with_traits('Role')->new( foo => 42 );
Then use your customized class:
$class->isa('Class'); # true
$class->does('Role'); # true
$class->foo; # 42
=head1 DESCRIPTION
Often you want to create components that can be added to a class
arbitrarily. This module makes it easy for the end user to use these
components. Instead of requiring the user to create a named class
with the desired roles applied, or apply roles to the instance
one-by-one, he can just create a new class from yours with
C<with_traits>, and then instantiate that.
There is also C<new_with_traits>, which exists for compatibility
reasons. It accepts a C<traits> parameter, creates a new class with
those traits, and then instantiates it.
Class->new_with_traits( traits => [qw/Foo Bar/], foo => 42, bar => 1 )
returns exactly the same object as
Class->with_traits(qw/Foo Bar/)->new( foo => 42, bar => 1 )
would. But you can also store the result of C<with_traits>, and call
other methods:
my $c = Class->with_traits(qw/Foo Bar/);
$c->new( foo => 42 );
$c->whatever( foo => 1234 );
And so on.
=for Pod::Coverage apply_traits
=head1 METHODS
=over 4
=item B<< $class->with_traits( @traits ) >>
Return a new class with the traits applied. Use like:
=item B<< $class->new_with_traits(%args, traits => \@traits) >>
C<new_with_traits> can also take a hashref, e.g.:
my $instance = $class->new_with_traits({ traits => \@traits, foo => 'bar' });
=back
=head1 ATTRIBUTES YOUR CLASS GETS
This role will add the following attributes to the consuming class.
=head2 _trait_namespace
You can override the value of this attribute with C<default> to
automatically prepend a namespace to the supplied traits. (This can
be overridden by prefixing the trait name with C<+>.)
Example:
package Another::Trait;
use Moose::Role;
has 'bar' => (
is => 'ro',
isa => 'Str',
required => 1,
);
package Another::Class;
use Moose;
with 'MooseX::Traits';
has '+_trait_namespace' => ( default => 'Another' );
my $instance = Another::Class->new_with_traits(
traits => ['Trait'], # "Another::Trait", not "Trait"
bar => 'bar',
);
$instance->does('Trait') # false
$instance->does('Another::Trait') # true
my $instance2 = Another::Class->new_with_traits(
traits => ['+Trait'], # "Trait", not "Another::Trait"
);
$instance2->does('Trait') # true
$instance2->does('Another::Trait') # false
=head1 AUTHOR
Jonathan Rockway <jrockway@cpan.org>
=head1 CONTRIBUTORS
=for stopwords Karen Etheridge Florian Ragwitz Tomas Doran Hans Dieter Pearcey Rafael Kitover Stevan Little Alexander Hartmaier
=over 4
=item *
Karen Etheridge <ether@cpan.org>
=item *
Florian Ragwitz <rafl@debian.org>
=item *
Tomas Doran <bobtfish@bobtfish.net>
=item *
Hans Dieter Pearcey <hdp@weftsoar.net>
=item *
Rafael Kitover <rkitover@cpan.org>
=item *
Stevan Little <stevan.little@iinteractive.com>
=item *
Alexander Hartmaier <abraxxa@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2008 by Infinity Interactive, Inc. http://www.iinteractive.com.
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

View File

@@ -0,0 +1,87 @@
package MooseX::Traits::Util;
use strict;
use warnings;
our $VERSION = '0.13';
use Sub::Exporter -setup => {
exports => ['new_class_with_traits'],
};
use Class::Load ();
use Carp ();
# note: "$class" throughout is "class name" or "instance of class
# name"
sub check_class {
my $class = shift;
Carp::confess "We can't interact with traits for a class ($class) ".
"that does not do MooseX::Traits" unless $class->does('MooseX::Traits');
}
sub transform_trait {
my ($class, $name) = @_;
return $1 if $name =~ /^[+](.+)$/;
check_class($class);
my $namespace = $class->meta->find_attribute_by_name('_trait_namespace');
my $base;
if($namespace->has_default){
$base = $namespace->default;
if(ref $base eq 'CODE'){
$base = $base->();
}
}
return $name unless $base;
return join '::', $base, $name;
}
sub resolve_traits {
my ($class, @traits) = @_;
check_class($class);
return map {
my $orig = $_;
if(!ref $orig){
my $transformed = transform_trait($class, $orig);
Class::Load::load_class($transformed);
$transformed;
}
else {
$orig;
}
} @traits;
}
my $anon_serial = 0;
sub new_class_with_traits {
my ($class, @traits) = @_;
check_class($class);
my $meta;
@traits = resolve_traits($class, @traits);
if (@traits) {
$meta = $class->meta->create(
join(q{::} => 'MooseX::Traits::__ANON__::SERIAL', ++$anon_serial),
superclasses => [ $class->meta->name ],
roles => \@traits,
cache => 1,
);
}
# if no traits were given just return the class meta
return $meta ? $meta : $class->meta;
}
1;
=for Pod::Coverage check_class new_class_with_traits resolve_traits transform_trait
=cut

1049
database/perl/vendor/lib/MooseX/Types.pm vendored Normal file

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,390 @@
package MooseX::Types::Base;
# ABSTRACT: Type library base class
our $VERSION = '0.50';
use Moose;
use Carp::Clan qw( ^MooseX::Types );
use Sub::Exporter qw( build_exporter );
use Moose::Util::TypeConstraints qw( find_type_constraint );
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod You normally won't need to interact with this class by yourself. It is
#pod merely a collection of functionality that type libraries need to
#pod interact with moose and the rest of the L<MooseX::Types> module.
#pod
#pod =cut
my $UndefMsg = q{Unable to find type '%s' in library '%s'};
#pod =head1 METHODS
#pod
#pod =cut
#pod =head2 import
#pod
#pod Provides the import mechanism for your library. See
#pod L<MooseX::Types/"LIBRARY USAGE"> for syntax details on this.
#pod
#pod =cut
sub import {
my ($class, @args) = @_;
# filter or create options hash for S:E
my $options = (@args and (ref($args[0]) eq 'HASH')) ? $args[0] : undef;
# preserve additional options, to ensure types are installed into the type library's namespace
my %ex_spec = %{ $options || {} };
delete @ex_spec{ qw(-wrapper -into -full) };
unless ($options) {
$options = {};
unshift @args, $options;
}
# all types known to us
my @types = $class->type_names;
# determine the wrapper, -into is supported for compatibility reasons
my $wrapper = $options->{ -wrapper } || 'MooseX::Types';
$args[0]->{into} = $options->{ -into }
if exists $options->{ -into };
my %ex_util;
TYPE:
for my $type_short (@types) {
# find type name and object, create undefined message
my $type_full = $class->get_type($type_short)
or croak "No fully qualified type name stored for '$type_short'";
my $type_cons = find_type_constraint($type_full);
my $undef_msg = sprintf($UndefMsg, $type_short, $class);
# the type itself
push @{ $ex_spec{exports} },
$type_short,
sub {
bless $wrapper->type_export_generator($type_short, $type_full),
'MooseX::Types::EXPORTED_TYPE_CONSTRAINT';
};
# the check helper
my $check_name = "is_${type_short}";
push @{ $ex_spec{exports} },
$check_name,
sub { $wrapper->check_export_generator($type_short, $type_full, $undef_msg) };
# only export coercion helper if full (for libraries) or coercion is defined
next TYPE
unless $options->{ -full }
or ($type_cons and $type_cons->has_coercion);
my $coercion_name = "to_${type_short}";
push @{ $ex_spec{exports} },
$coercion_name,
sub { $wrapper->coercion_export_generator($type_short, $type_full, $undef_msg) };
$ex_util{ $type_short }{to}++; # shortcut to remember this exists
}
# create S:E exporter and increase export level unless specified explicitly
my $exporter = build_exporter \%ex_spec;
$options->{into_level}++
unless $options->{into};
# remember requested symbols to determine what helpers to auto-export
my %was_requested =
map { ($_ => 1) }
grep { not ref }
@args;
# determine which additional symbols (helpers) to export along
my %add;
EXPORT:
for my $type (grep { exists $was_requested{ $_ } } @types) {
$add{ "is_$type" }++
unless $was_requested{ "is_$type" };
next EXPORT
unless exists $ex_util{ $type }{to};
$add{ "to_$type" }++
unless $was_requested{ "to_$type" };
}
# and on to the real exporter
my @new_args = (@args, keys %add);
return $class->$exporter(@new_args);
}
#pod =head2 get_type
#pod
#pod This returns a type from the library's store by its name.
#pod
#pod =cut
sub get_type {
my ($class, $type) = @_;
# useful message if the type couldn't be found
croak "Unknown type '$type' in library '$class'"
unless $class->has_type($type);
# return real name of the type
return $class->type_storage->{ $type };
}
#pod =head2 type_names
#pod
#pod Returns a list of all known types by their name.
#pod
#pod =cut
sub type_names {
my ($class) = @_;
# return short names of all stored types
return keys %{ $class->type_storage };
}
#pod =head2 add_type
#pod
#pod Adds a new type to the library.
#pod
#pod =cut
sub add_type {
my ($class, $type) = @_;
# store type with library prefix as real name
$class->type_storage->{ $type } = "${class}::${type}";
}
#pod =head2 has_type
#pod
#pod Returns true or false depending on if this library knows a type by that
#pod name.
#pod
#pod =cut
sub has_type {
my ($class, $type) = @_;
# check if we stored a type under that name
return ! ! $class->type_storage->{ $type };
}
#pod =head2 type_storage
#pod
#pod Returns the library's type storage hash reference. You shouldn't use this
#pod method directly unless you know what you are doing. It is not an internal
#pod method because overriding it makes virtual libraries very easy.
#pod
#pod =cut
sub type_storage {
my ($class) = @_;
# return a reference to the storage in ourself
{ no strict 'refs';
return \%{ $class . '::__MOOSEX_TYPELIBRARY_STORAGE' };
}
}
#pod =head2 registered_class_types
#pod
#pod Returns the class types registered within this library. Don't use directly.
#pod
#pod =cut
sub registered_class_types {
my ($class) = @_;
{
no strict 'refs';
return \%{ $class . '::__MOOSEX_TYPELIBRARY_CLASS_TYPES' };
}
}
#pod =head2 register_class_type
#pod
#pod Register a C<class_type> for use in this library by class name.
#pod
#pod =cut
sub register_class_type {
my ($class, $type) = @_;
croak "Not a class_type"
unless $type->isa('Moose::Meta::TypeConstraint::Class');
$class->registered_class_types->{$type->class} = $type;
}
#pod =head2 get_registered_class_type
#pod
#pod Get a C<class_type> registered in this library by name.
#pod
#pod =cut
sub get_registered_class_type {
my ($class, $name) = @_;
$class->registered_class_types->{$name};
}
#pod =head2 registered_role_types
#pod
#pod Returns the role types registered within this library. Don't use directly.
#pod
#pod =cut
sub registered_role_types {
my ($class) = @_;
{
no strict 'refs';
return \%{ $class . '::__MOOSEX_TYPELIBRARY_ROLE_TYPES' };
}
}
#pod =head2 register_role_type
#pod
#pod Register a C<role_type> for use in this library by role name.
#pod
#pod =cut
sub register_role_type {
my ($class, $type) = @_;
croak "Not a role_type"
unless $type->isa('Moose::Meta::TypeConstraint::Role');
$class->registered_role_types->{$type->role} = $type;
}
#pod =head2 get_registered_role_type
#pod
#pod Get a C<role_type> registered in this library by role name.
#pod
#pod =cut
sub get_registered_role_type {
my ($class, $name) = @_;
$class->registered_role_types->{$name};
}
#pod =head1 SEE ALSO
#pod
#pod L<MooseX::Types::Moose>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::Base - Type library base class
=head1 VERSION
version 0.50
=head1 DESCRIPTION
You normally won't need to interact with this class by yourself. It is
merely a collection of functionality that type libraries need to
interact with moose and the rest of the L<MooseX::Types> module.
=head1 METHODS
=head2 import
Provides the import mechanism for your library. See
L<MooseX::Types/"LIBRARY USAGE"> for syntax details on this.
=head2 get_type
This returns a type from the library's store by its name.
=head2 type_names
Returns a list of all known types by their name.
=head2 add_type
Adds a new type to the library.
=head2 has_type
Returns true or false depending on if this library knows a type by that
name.
=head2 type_storage
Returns the library's type storage hash reference. You shouldn't use this
method directly unless you know what you are doing. It is not an internal
method because overriding it makes virtual libraries very easy.
=head2 registered_class_types
Returns the class types registered within this library. Don't use directly.
=head2 register_class_type
Register a C<class_type> for use in this library by class name.
=head2 get_registered_class_type
Get a C<class_type> registered in this library by name.
=head2 registered_role_types
Returns the role types registered within this library. Don't use directly.
=head2 register_role_type
Register a C<role_type> for use in this library by role name.
=head2 get_registered_role_type
Get a C<role_type> registered in this library by role name.
=head1 SEE ALSO
L<MooseX::Types::Moose>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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

View File

@@ -0,0 +1,159 @@
package MooseX::Types::CheckedUtilExports;
# ABSTRACT: Wrap L<Moose::Util::TypeConstraints> to be safer for L<MooseX::Types>
our $VERSION = '0.50';
use strict;
use warnings;
use Moose::Util::TypeConstraints ();
use Moose::Exporter;
use Carp 'carp';
use Sub::Install;
use namespace::autoclean;
my $StringFoundMsg =
q{WARNING: String found where Type expected (did you use a => instead of a , ?)};
my @exports = qw/type subtype maybe_type duck_type enum coerce from as/;
#pod =head1 DESCRIPTION
#pod
#pod Prevents errors like:
#pod
#pod subtype Foo =>
#pod ...
#pod
#pod Which should be written as:
#pod
#pod subtype Foo,
#pod ...
#pod
#pod When using L<MooseX::Types>. Exported by that module.
#pod
#pod Exports checked versions of the following subs:
#pod
#pod C<type> C<subtype> C<maybe_type> C<duck_type> C<enum> C<coerce> C<from> C<as>
#pod
#pod While C<class_type> and C<role_type> will also register the type in the library.
#pod
#pod From L<Moose::Util::TypeConstraints>. See that module for syntax.
#pod
#pod =for Pod::Coverage class_type role_type
#pod
#pod =cut
for my $export (@exports) {
no strict 'refs';
Sub::Install::install_sub({
into => __PACKAGE__,
as => $export,
code => sub {
my $caller = shift;
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
carp $StringFoundMsg
unless ref($_[0]) ||
$_[0] =~ /\b::\b/ || # qualified type
$caller->get_registered_class_type($_[0]) ||
$caller->get_registered_role_type($_[0]);
goto &{"Moose::Util::TypeConstraints::$export"};
}
});
}
Moose::Exporter->setup_import_methods(
with_caller => [ @exports, 'class_type', 'role_type' ]
);
sub class_type {
my $caller = shift;
$caller->register_class_type(
Moose::Util::TypeConstraints::class_type(@_)
);
}
sub role_type ($;$) {
my ($caller, $name, $opts) = @_;
$caller->register_role_type(
Moose::Util::TypeConstraints::role_type($name, $opts)
);
}
#pod =head1 SEE ALSO
#pod
#pod L<MooseX::Types>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::CheckedUtilExports - Wrap L<Moose::Util::TypeConstraints> to be safer for L<MooseX::Types>
=head1 VERSION
version 0.50
=head1 DESCRIPTION
Prevents errors like:
subtype Foo =>
...
Which should be written as:
subtype Foo,
...
When using L<MooseX::Types>. Exported by that module.
Exports checked versions of the following subs:
C<type> C<subtype> C<maybe_type> C<duck_type> C<enum> C<coerce> C<from> C<as>
While C<class_type> and C<role_type> will also register the type in the library.
From L<Moose::Util::TypeConstraints>. See that module for syntax.
=for Pod::Coverage class_type role_type
=head1 SEE ALSO
L<MooseX::Types>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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

View File

@@ -0,0 +1,283 @@
use strict;
use warnings;
package MooseX::Types::Combine;
# ABSTRACT: Combine type libraries for exporting
our $VERSION = '0.50';
use Module::Runtime 'use_module';
use namespace::autoclean;
#pod =head1 SYNOPSIS
#pod
#pod package CombinedTypeLib;
#pod
#pod use base 'MooseX::Types::Combine';
#pod
#pod __PACKAGE__->provide_types_from(qw/TypeLib1 TypeLib2/);
#pod
#pod package UserClass;
#pod
#pod use CombinedTypeLib qw/Type1 Type2 ... /;
#pod
#pod =head1 DESCRIPTION
#pod
#pod Allows you to create a single class that will allow you to export types from
#pod multiple type libraries:
#pod
#pod package TransportTypes;
#pod
#pod use base 'MooseX::Types::Combine';
#pod
#pod __PACKAGE__->provide_types_from(qw/ MotorizedTypes UnmotorizedTypes /);
#pod
#pod 1;
#pod
#pod In this example all types defined in C<MotorizedTypes> and C<UnmotorizedTypes>
#pod are available through the C<TransportTypes> combined type library.
#pod
#pod package SkiingTrip;
#pod
#pod use Moose;
#pod
#pod use TransportTypes qw( CarType SkisType );
#pod
#pod has car => ( is => 'ro', isa => CarType, required => 1 );
#pod has ski_rack => ( is => 'ro', isa => ArrayRef[SkisType], required => 1 );
#pod ...
#pod
#pod Libraries on the right end of the list passed to L</provide_types_from> take
#pod precedence over those on the left in case of conflicts. So, in the above
#pod example if both the C<MotorizedTypes> and C<UnmotorizedTypes> libraries provided
#pod a C<Bike> type, you'd get the bicycle from C<UnmotorizedTypes> not the
#pod motorbike from C<MorotizedTypes>.
#pod
#pod You can also further combine combined type libraries with additional type
#pod libraries or other combined type libraries in the same way to provide even
#pod larger type libraries:
#pod
#pod package MeetingTransportTypes;
#pod
#pod use base 'MooseX::Types::Combine';
#pod
#pod __PACKAGE__->provide_types_from(qw/ TransportTypes TelepresenceTypes /);
#pod
#pod 1;
#pod
#pod =cut
sub import {
my ($class, @types) = @_;
my $caller = caller;
my $where_to_import_to = $caller;
if (ref $types[0] eq 'HASH') {
my $extra = shift @types;
$where_to_import_to = $extra->{-into} if exists $extra->{-into};
}
my %types = $class->_provided_types;
if ( grep { $_ eq ':all' } @types ) {
$_->import( { -into => $where_to_import_to }, q{:all} )
for $class->provide_types_from;
return;
}
my %from;
for my $type (@types) {
unless ($types{$type}) {
my @type_libs = $class->provide_types_from;
die
"$caller asked for a type ($type) which is not found in any of the"
. " type libraries (@type_libs) combined by $class\n";
}
push @{ $from{ $types{$type} } }, $type;
}
$_->import({ -into => $where_to_import_to }, @{ $from{ $_ } })
for keys %from;
}
#pod =head1 CLASS METHODS
#pod
#pod =head2 provide_types_from
#pod
#pod Sets or returns a list of type libraries (or combined type libraries) to
#pod re-export from.
#pod
#pod =cut
sub provide_types_from {
my ($class, @libs) = @_;
my $store =
do { no strict 'refs'; \@{ "${class}::__MOOSEX_TYPELIBRARY_LIBRARIES" } };
if (@libs) {
$class->_check_type_lib($_) for @libs;
@$store = @libs;
my %types = map {
my $lib = $_;
map +( $_ => $lib ), $lib->type_names
} @libs;
$class->_provided_types(%types);
}
@$store;
}
sub _check_type_lib {
my ($class, $lib) = @_;
use_module($lib);
die "Cannot use $lib in a combined type library, it does not provide any types"
unless $lib->can('type_names');
}
sub _provided_types {
my ($class, %types) = @_;
my $types =
do { no strict 'refs'; \%{ "${class}::__MOOSEX_TYPELIBRARY_TYPES" } };
%$types = %types
if keys %types;
%$types;
}
#pod =head2 type_names
#pod
#pod Returns a list of all known types by their name.
#pod
#pod =cut
sub type_names {
my ($class) = @_;
my %types = $class->_provided_types();
return keys %types;
}
#pod =head1 SEE ALSO
#pod
#pod L<MooseX::Types>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::Combine - Combine type libraries for exporting
=head1 VERSION
version 0.50
=head1 SYNOPSIS
package CombinedTypeLib;
use base 'MooseX::Types::Combine';
__PACKAGE__->provide_types_from(qw/TypeLib1 TypeLib2/);
package UserClass;
use CombinedTypeLib qw/Type1 Type2 ... /;
=head1 DESCRIPTION
Allows you to create a single class that will allow you to export types from
multiple type libraries:
package TransportTypes;
use base 'MooseX::Types::Combine';
__PACKAGE__->provide_types_from(qw/ MotorizedTypes UnmotorizedTypes /);
1;
In this example all types defined in C<MotorizedTypes> and C<UnmotorizedTypes>
are available through the C<TransportTypes> combined type library.
package SkiingTrip;
use Moose;
use TransportTypes qw( CarType SkisType );
has car => ( is => 'ro', isa => CarType, required => 1 );
has ski_rack => ( is => 'ro', isa => ArrayRef[SkisType], required => 1 );
...
Libraries on the right end of the list passed to L</provide_types_from> take
precedence over those on the left in case of conflicts. So, in the above
example if both the C<MotorizedTypes> and C<UnmotorizedTypes> libraries provided
a C<Bike> type, you'd get the bicycle from C<UnmotorizedTypes> not the
motorbike from C<MorotizedTypes>.
You can also further combine combined type libraries with additional type
libraries or other combined type libraries in the same way to provide even
larger type libraries:
package MeetingTransportTypes;
use base 'MooseX::Types::Combine';
__PACKAGE__->provide_types_from(qw/ TransportTypes TelepresenceTypes /);
1;
=head1 CLASS METHODS
=head2 provide_types_from
Sets or returns a list of type libraries (or combined type libraries) to
re-export from.
=head2 type_names
Returns a list of all known types by their name.
=head1 SEE ALSO
L<MooseX::Types>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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

View File

@@ -0,0 +1,149 @@
use warnings;
use strict;
package MooseX::Types::Moose;
# ABSTRACT: Type exports that match the types shipped with L<Moose>
our $VERSION = '0.50';
use MooseX::Types;
use Moose::Util::TypeConstraints ();
use namespace::autoclean;
#pod =head1 SYNOPSIS
#pod
#pod package Foo;
#pod use Moose;
#pod use MooseX::Types::Moose qw( ArrayRef Int Str );
#pod use Carp qw( croak );
#pod
#pod has 'name',
#pod is => 'rw',
#pod isa => Str;
#pod
#pod has 'ids',
#pod is => 'rw',
#pod isa => ArrayRef[Int];
#pod
#pod sub add {
#pod my ($self, $x, $y) = @_;
#pod croak 'First arg not an Int' unless is_Int($x);
#pod croak 'Second arg not an Int' unless is_Int($y);
#pod return $x + $y;
#pod }
#pod
#pod 1;
#pod
#pod =head1 DESCRIPTION
#pod
#pod This package contains a virtual library for L<MooseX::Types> that
#pod is able to export all types known to L<Moose>. See L<MooseX::Types>
#pod for general usage information.
#pod
#pod =cut
# all available builtin types as short and long name
my %BuiltIn_Storage
= map { ($_) x 2 }
Moose::Util::TypeConstraints->list_all_builtin_type_constraints;
#pod =head1 METHODS
#pod
#pod =head2 type_storage
#pod
#pod Overrides L<MooseX::Types::Base>' C<type_storage> to provide a hash
#pod reference containing all built-in L<Moose> types.
#pod
#pod =cut
# use prepopulated builtin hash as type storage
sub type_storage { \%BuiltIn_Storage }
#pod =head1 SEE ALSO
#pod
#pod L<Moose>,
#pod L<Moose::Util::TypeConstraints>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::Moose - Type exports that match the types shipped with L<Moose>
=head1 VERSION
version 0.50
=head1 SYNOPSIS
package Foo;
use Moose;
use MooseX::Types::Moose qw( ArrayRef Int Str );
use Carp qw( croak );
has 'name',
is => 'rw',
isa => Str;
has 'ids',
is => 'rw',
isa => ArrayRef[Int];
sub add {
my ($self, $x, $y) = @_;
croak 'First arg not an Int' unless is_Int($x);
croak 'Second arg not an Int' unless is_Int($y);
return $x + $y;
}
1;
=head1 DESCRIPTION
This package contains a virtual library for L<MooseX::Types> that
is able to export all types known to L<Moose>. See L<MooseX::Types>
for general usage information.
=head1 METHODS
=head2 type_storage
Overrides L<MooseX::Types::Base>' C<type_storage> to provide a hash
reference containing all built-in L<Moose> types.
=head1 SEE ALSO
L<Moose>,
L<Moose::Util::TypeConstraints>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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

File diff suppressed because it is too large Load Diff

View File

@@ -0,0 +1,45 @@
package ## Hide from PAUSE
MooseX::Types::Structured::MessageStack;
our $VERSION = '0.36';
use Moose;
has 'level' => (
traits => ['Counter'],
is => 'ro',
isa => 'Num',
required => 0,
default => 0,
handles => {
inc_level => 'inc',
dec_level => 'dec',
},
);
has 'messages' => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef[HashRef]',
required => 1,
default => sub { [] },
handles => {
has_messages => 'count',
add_message => 'push',
all_messages => 'elements',
},
);
sub as_string {
my @messages = (shift)->all_messages;
my @flattened_msgs = map {
"\n". (" " x $_->{level}) ."[+] " . $_->{message};
} reverse @messages;
return join("", @flattened_msgs);
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;

View File

@@ -0,0 +1,25 @@
package ## Hide from PAUSE
MooseX::Types::Structured::OverflowHandler;
our $VERSION = '0.36';
use Moose;
use overload '""' => 'name', fallback => 1;
has type_constraint => (
is => 'ro',
isa => 'Moose::Meta::TypeConstraint',
required => 1,
handles => [qw/check/],
);
sub name {
my ($self) = @_;
return 'slurpy(' . $self->type_constraint->name . ')';
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;

View File

@@ -0,0 +1,304 @@
use strict;
use warnings;
package MooseX::Types::TypeDecorator;
# ABSTRACT: Wraps Moose::Meta::TypeConstraint objects with added features
our $VERSION = '0.50';
use Carp::Clan '^MooseX::Types';
use Moose::Util::TypeConstraints ();
use Moose::Meta::TypeConstraint::Union;
use Scalar::Util qw(blessed);
use namespace::autoclean 0.16;
use overload(
'0+' => sub {
my $self = shift @_;
my $tc = $self->{__type_constraint};
return 0+$tc;
},
# workaround for perl 5.8.5 bug
'==' => sub { 0+$_[0] == 0+$_[1] },
'""' => sub {
my $self = shift @_;
if(blessed $self) {
return $self->__type_constraint->name;
} else {
return "$self";
}
},
bool => sub { 1 },
'|' => sub {
## It's kind of ugly that we need to know about Union Types, but this
## is needed for syntax compatibility. Maybe someday we'll all just do
## Or[Str,Str,Int]
my @args = @_[0,1]; ## arg 3 is special, see the overload docs.
my @tc = grep {blessed $_} map {
blessed $_ ? $_ :
Moose::Util::TypeConstraints::find_or_parse_type_constraint($_)
|| __PACKAGE__->_throw_error( "$_ is not a type constraint")
} @args;
( scalar @tc == scalar @args)
|| __PACKAGE__->_throw_error(
"one of your type constraints is bad. Passed: ". join(', ', @args) ." Got: ". join(', ', @tc));
( scalar @tc >= 2 )
|| __PACKAGE__->_throw_error("You must pass in at least 2 type names to make a union");
my $union = Moose::Meta::TypeConstraint::Union->new(type_constraints=>\@tc);
return Moose::Util::TypeConstraints::register_type_constraint($union);
},
fallback => 1,
);
#pod =head1 DESCRIPTION
#pod
#pod This is a decorator object that contains an underlying type constraint. We use
#pod this to control access to the type constraint and to add some features.
#pod
#pod =head1 METHODS
#pod
#pod This class defines the following methods.
#pod
#pod =head2 new
#pod
#pod Old school instantiation
#pod
#pod =cut
sub new {
my $proto = shift;
if (ref($proto)) {
return $proto->_try_delegate('new', @_);
}
my $class = $proto;
if(my $arg = shift @_) {
if(blessed $arg && $arg->isa('Moose::Meta::TypeConstraint')) {
return bless {'__type_constraint'=>$arg}, $class;
} elsif(
blessed $arg &&
$arg->isa('MooseX::Types::UndefinedType')
) {
## stub in case we'll need to handle these types differently
return bless {'__type_constraint'=>$arg}, $class;
} elsif(blessed $arg) {
__PACKAGE__->_throw_error("Argument must be ->isa('Moose::Meta::TypeConstraint') or ->isa('MooseX::Types::UndefinedType'), not ". blessed $arg);
} else {
__PACKAGE__->_throw_error("Argument cannot be '$arg'");
}
} else {
__PACKAGE__->_throw_error("This method [new] requires a single argument.");
}
}
#pod =head2 __type_constraint ($type_constraint)
#pod
#pod Set/Get the type_constraint.
#pod
#pod =cut
sub __type_constraint {
my $self = shift @_;
if(blessed $self) {
if(defined(my $tc = shift @_)) {
$self->{__type_constraint} = $tc;
}
return $self->{__type_constraint};
} else {
__PACKAGE__->_throw_error('cannot call __type_constraint as a class method');
}
}
#pod =head2 C<isa>
#pod
#pod handle C<< $self->isa >> since C<AUTOLOAD> can't - this tries both the type constraint,
#pod and for a class type, the class.
#pod
#pod =cut
sub isa {
my $self = shift;
return
blessed $self
? $self->__type_constraint->isa(@_)
|| $self->_try_delegate( 'isa', @_ )
: $self->SUPER::isa(@_);
}
#pod =head2 can
#pod
#pod handle $self->can since AUTOLOAD can't.
#pod
#pod =cut
sub can {
my $self = shift;
return blessed $self
? $self->_try_delegate( 'can', @_ )
: $self->SUPER::can(@_);
}
#pod =head2 _throw_error
#pod
#pod properly delegate error messages
#pod
#pod =cut
sub _throw_error {
shift;
require Moose;
unshift @_, 'Moose';
goto &Moose::throw_error;
}
#pod =head2 DESTROY
#pod
#pod We might need it later
#pod
#pod =cut
sub DESTROY {
return;
}
#pod =head2 AUTOLOAD
#pod
#pod Delegate to the decorator target, unless this is a class type, in which
#pod case it will try to delegate to the type object, then if that fails try
#pod the class. The method 'new' is special cased to only be permitted on
#pod the class; if there is no class, or it does not provide a new method,
#pod an exception will be thrown.
#pod
#pod =cut
sub AUTOLOAD {
my ($self, @args) = @_;
my ($method) = (our $AUTOLOAD =~ /([^:]+)$/);
## We delegate with this method in an attempt to support a value of
## __type_constraint which is also AUTOLOADing, in particular the class
## MooseX::Types::UndefinedType which AUTOLOADs during autovivication.
$self->_try_delegate($method, @args);
}
sub _try_delegate {
my ($self, $method, @args) = @_;
my $tc = $self->__type_constraint;
my $class;
if ($tc->can('is_subtype_of')) { # Union can't
my $search_tc = $tc;
while (1) {
if ($search_tc->isa('Moose::Meta::TypeConstraint::Class')) {
$class = $search_tc->class;
last;
}
$search_tc = $search_tc->parent;
last unless $search_tc && $search_tc->is_subtype_of('Object');
}
}
my $inv = do {
if ($method eq 'new') {
die "new called on type decorator for non-class-type ".$tc->name
unless $class;
die "new called on class type decorator ".$tc->name."\n"
." for class ${class}\n"
." which does not provide a new method - did you forget to load it?"
unless $class->can('new');
$class
} elsif ($class && !$tc->can($method)) {
$class
} else {
$tc
}
};
$inv->$method(@args);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::TypeDecorator - Wraps Moose::Meta::TypeConstraint objects with added features
=head1 VERSION
version 0.50
=head1 DESCRIPTION
This is a decorator object that contains an underlying type constraint. We use
this to control access to the type constraint and to add some features.
=head1 METHODS
This class defines the following methods.
=head2 new
Old school instantiation
=head2 __type_constraint ($type_constraint)
Set/Get the type_constraint.
=head2 C<isa>
handle C<< $self->isa >> since C<AUTOLOAD> can't - this tries both the type constraint,
and for a class type, the class.
=head2 can
handle $self->can since AUTOLOAD can't.
=head2 _throw_error
properly delegate error messages
=head2 DESTROY
We might need it later
=head2 AUTOLOAD
Delegate to the decorator target, unless this is a class type, in which
case it will try to delegate to the type object, then if that fails try
the class. The method 'new' is special cased to only be permitted on
the class; if there is no class, or it does not provide a new method,
an exception will be thrown.
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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

View File

@@ -0,0 +1,204 @@
use warnings;
use strict;
package MooseX::Types::UndefinedType;
# ABSTRACT: a fallback type for when a type cannot be found
our $VERSION = '0.50';
use Moose::Util::TypeConstraints ();
use Carp::Clan '^MooseX::Types';
use namespace::autoclean 0.16;
use overload '""' => sub { shift->name },
fallback => 1;
#pod =head1 DESCRIPTION
#pod
#pod Whenever a type handle function (e.g. C<Int()> can't find a type
#pod constraint under its full name, it assumes it has not yet been defined.
#pod It will then return an instance of this class, handling only
#pod stringification, name and possible identification of undefined types.
#pod
#pod Later, when you try to use the Undefined Type Constraint, autovivification will
#pod be attempted.
#pod
#pod =head1 METHODS
#pod
#pod =head2 new
#pod
#pod Takes a full type name as argument and returns an instance of this
#pod class.
#pod
#pod =cut
sub new {
return bless { name => $_[1] }, $_[0];
}
#pod =head2 name
#pod
#pod Returns the stored type name.
#pod
#pod =cut
sub name {
return $_[0]->{name};
}
#pod =head2 __autovivify
#pod
#pod Try to see if the type constraint has yet been defined and if so create it.
#pod
#pod =cut
sub __autovivify {
my ($self) = @_;
if(my $tc = $self->{instance}) {
return $tc;
} elsif( my $new_tc = Moose::Util::TypeConstraints::find_type_constraint($self->name)) {
$self->{instance} = $new_tc;
return $new_tc;
} else {
return;
}
}
#pod =head2 can_be_inlined
#pod
#pod Make sure that if a type hasn't been defined yet when Moose wants to inline it,
#pod we don't allow inlining.
#pod
#pod =cut
sub can_be_inlined {
my $self = shift;
if(my $type_constraint = $self->__autovivify) {
return $type_constraint->can_be_inlined;
} else {
return;
}
}
#pod =head2 AUTOLOAD
#pod
#pod Try to autovivify and delegate
#pod
#pod =cut
sub AUTOLOAD {
my ($self, @args) = @_;
my ($method) = our $AUTOLOAD =~ /([^:]+)$/;
if(my $type_constraint = $self->__autovivify) {
return $type_constraint->$method(@args);
} else {
croak "Method '$method' is not supported for " . $self->name;
}
}
#pod =head2 DESTROY
#pod
#pod Moose::Meta::TypeConstraint::Parameterizable complains if this isn't here. TODO
#pod to find out why.
#pod
#pod =cut
sub DESTROY {
return;
}
#pod =head1 SEE ALSO
#pod
#pod L<MooseX::Types::Moose>,
#pod L<Moose::Util::TypeConstraints>,
#pod L<Moose::Meta::TypeConstraint>,
#pod L<Carp::Clan>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::UndefinedType - a fallback type for when a type cannot be found
=head1 VERSION
version 0.50
=head1 DESCRIPTION
Whenever a type handle function (e.g. C<Int()> can't find a type
constraint under its full name, it assumes it has not yet been defined.
It will then return an instance of this class, handling only
stringification, name and possible identification of undefined types.
Later, when you try to use the Undefined Type Constraint, autovivification will
be attempted.
=head1 METHODS
=head2 new
Takes a full type name as argument and returns an instance of this
class.
=head2 name
Returns the stored type name.
=head2 __autovivify
Try to see if the type constraint has yet been defined and if so create it.
=head2 can_be_inlined
Make sure that if a type hasn't been defined yet when Moose wants to inline it,
we don't allow inlining.
=head2 AUTOLOAD
Try to autovivify and delegate
=head2 DESTROY
Moose::Meta::TypeConstraint::Parameterizable complains if this isn't here. TODO
to find out why.
=head1 SEE ALSO
L<MooseX::Types::Moose>,
L<Moose::Util::TypeConstraints>,
L<Moose::Meta::TypeConstraint>,
L<Carp::Clan>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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

View File

@@ -0,0 +1,191 @@
use warnings;
use strict;
package MooseX::Types::Util;
# ABSTRACT: Common utility functions for the distribution
our $VERSION = '0.50';
use Scalar::Util 'blessed';
use base 'Exporter';
use namespace::autoclean;
#pod =head1 DESCRIPTION
#pod
#pod This package the exportable functions that many parts in
#pod L<MooseX::Types> might need.
#pod
#pod =cut
our @EXPORT_OK = qw( filter_tags has_available_type_export );
#pod =head1 FUNCTIONS
#pod
#pod =head2 filter_tags
#pod
#pod Takes a list and returns two references. The first is a hash reference
#pod containing the tags as keys and the number of their appearance as values.
#pod The second is an array reference containing all other elements.
#pod
#pod =cut
sub filter_tags {
my (@list) = @_;
my (%tags, @other);
for (@list) {
if (/^:(.*)$/) {
$tags{ $1 }++;
next;
}
push @other, $_;
}
return \%tags, \@other;
}
#pod =head2 has_available_type_export
#pod
#pod TypeConstraint | Undef = has_available_type_export($package, $name);
#pod
#pod This function allows you to introspect if a given type export is available
#pod I<at this point in time>. This means that the C<$package> must have imported
#pod a type constraint with the name C<$name>, and it must be still in its symbol
#pod table.
#pod
#pod Two arguments are expected:
#pod
#pod =over 4
#pod
#pod =item $package
#pod
#pod The name of the package to introspect.
#pod
#pod =item $name
#pod
#pod The name of the type export to introspect.
#pod
#pod =back
#pod
#pod B<Note> that the C<$name> is the I<exported> name of the type, not the declared
#pod one. This means that if you use L<Sub::Exporter>s functionality to rename an import
#pod like this:
#pod
#pod use MyTypes Str => { -as => 'MyStr' };
#pod
#pod you would have to introspect this type like this:
#pod
#pod has_available_type_export $package, 'MyStr';
#pod
#pod The return value will be either the type constraint that belongs to the export
#pod or an undefined value.
#pod
#pod =cut
sub has_available_type_export {
my ($package, $name) = @_;
my $sub = $package->can($name)
or return undef;
return undef
unless blessed $sub && $sub->isa('MooseX::Types::EXPORTED_TYPE_CONSTRAINT');
return $sub->();
}
#pod =head1 SEE ALSO
#pod
#pod L<MooseX::Types::Moose>, L<Exporter>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::Util - Common utility functions for the distribution
=head1 VERSION
version 0.50
=head1 DESCRIPTION
This package the exportable functions that many parts in
L<MooseX::Types> might need.
=head1 FUNCTIONS
=head2 filter_tags
Takes a list and returns two references. The first is a hash reference
containing the tags as keys and the number of their appearance as values.
The second is an array reference containing all other elements.
=head2 has_available_type_export
TypeConstraint | Undef = has_available_type_export($package, $name);
This function allows you to introspect if a given type export is available
I<at this point in time>. This means that the C<$package> must have imported
a type constraint with the name C<$name>, and it must be still in its symbol
table.
Two arguments are expected:
=over 4
=item $package
The name of the package to introspect.
=item $name
The name of the type export to introspect.
=back
B<Note> that the C<$name> is the I<exported> name of the type, not the declared
one. This means that if you use L<Sub::Exporter>s functionality to rename an import
like this:
use MyTypes Str => { -as => 'MyStr' };
you would have to introspect this type like this:
has_available_type_export $package, 'MyStr';
The return value will be either the type constraint that belongs to the export
or an undefined value.
=head1 SEE ALSO
L<MooseX::Types::Moose>, L<Exporter>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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

View File

@@ -0,0 +1,95 @@
package MooseX::Types::Wrapper;
# ABSTRACT: Wrap exports from a library
our $VERSION = '0.50';
use Moose;
use Carp::Clan qw( ^MooseX::Types );
use Module::Runtime 'use_module';
use namespace::autoclean;
extends 'MooseX::Types';
#pod =head1 DESCRIPTION
#pod
#pod See L<MooseX::Types/SYNOPSIS> for detailed usage.
#pod
#pod =head1 METHODS
#pod
#pod =head2 import
#pod
#pod =cut
sub import {
my ($class, @args) = @_;
my %libraries = @args == 1 ? (Moose => $args[0]) : @args;
for my $l (keys %libraries) {
croak qq($class expects an array reference as import spec)
unless ref $libraries{ $l } eq 'ARRAY';
my $library_class
= ($l eq 'Moose' ? 'MooseX::Types::Moose' : $l );
use_module($library_class);
$library_class->import({
-into => scalar(caller),
-wrapper => $class,
}, @{ $libraries{ $l } });
}
return 1;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
MooseX::Types::Wrapper - Wrap exports from a library
=head1 VERSION
version 0.50
=head1 DESCRIPTION
See L<MooseX::Types/SYNOPSIS> for detailed usage.
=head1 METHODS
=head2 import
=head1 SEE ALSO
L<MooseX::Types>
=head1 SUPPORT
Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=MooseX-Types>
(or L<bug-MooseX-Types@rt.cpan.org|mailto:bug-MooseX-Types@rt.cpan.org>).
There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/moose.html>.
There is also an irc channel available for users of this distribution, at
L<C<#moose> on C<irc.perl.org>|irc://irc.perl.org/#moose>.
=head1 AUTHOR
Robert "phaylon" Sedlacek <rs@474.at>
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2007 by Robert "phaylon" Sedlacek.
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