This commit is contained in:
304
CPAN/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod
Normal file
304
CPAN/Moose/Cookbook/Meta/GlobRef_InstanceMetaclass.pod
Normal file
@@ -0,0 +1,304 @@
|
||||
# PODNAME: Moose::Cookbook::Meta::GlobRef_InstanceMetaclass
|
||||
# ABSTRACT: Creating a glob reference meta-instance class
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Moose::Cookbook::Meta::GlobRef_InstanceMetaclass - Creating a glob reference meta-instance class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.2207
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package My::Meta::Instance;
|
||||
|
||||
use Scalar::Util qw( weaken );
|
||||
use Symbol qw( gensym );
|
||||
|
||||
use Moose::Role;
|
||||
|
||||
sub create_instance {
|
||||
my $self = shift;
|
||||
my $sym = gensym();
|
||||
bless $sym, $self->_class_name;
|
||||
}
|
||||
|
||||
sub clone_instance {
|
||||
my ( $self, $instance ) = @_;
|
||||
|
||||
my $new_sym = gensym();
|
||||
%{*$new_sym} = %{*$instance};
|
||||
|
||||
bless $new_sym, $self->_class_name;
|
||||
}
|
||||
|
||||
sub get_slot_value {
|
||||
my ( $self, $instance, $slot_name ) = @_;
|
||||
return *$instance->{$slot_name};
|
||||
}
|
||||
|
||||
sub set_slot_value {
|
||||
my ( $self, $instance, $slot_name, $value ) = @_;
|
||||
*$instance->{$slot_name} = $value;
|
||||
}
|
||||
|
||||
sub deinitialize_slot {
|
||||
my ( $self, $instance, $slot_name ) = @_;
|
||||
delete *$instance->{$slot_name};
|
||||
}
|
||||
|
||||
sub is_slot_initialized {
|
||||
my ( $self, $instance, $slot_name ) = @_;
|
||||
exists *$instance->{$slot_name};
|
||||
}
|
||||
|
||||
sub weaken_slot_value {
|
||||
my ( $self, $instance, $slot_name ) = @_;
|
||||
weaken *$instance->{$slot_name};
|
||||
}
|
||||
|
||||
sub inline_create_instance {
|
||||
my ( $self, $class_variable ) = @_;
|
||||
return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }';
|
||||
}
|
||||
|
||||
sub inline_slot_access {
|
||||
my ( $self, $instance, $slot_name ) = @_;
|
||||
return '*{' . $instance . '}->{' . $slot_name . '}';
|
||||
}
|
||||
|
||||
package MyApp::User;
|
||||
|
||||
use Moose;
|
||||
Moose::Util::MetaRole::apply_metaroles(
|
||||
for => __PACKAGE__,
|
||||
class_metaroles => {
|
||||
instance => ['My::Meta::Instance'],
|
||||
},
|
||||
);
|
||||
|
||||
has 'name' => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
|
||||
has 'email' => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This recipe shows how to build your own meta-instance. The meta
|
||||
instance is the metaclass that creates object instances and helps
|
||||
manages access to attribute slots.
|
||||
|
||||
In this example, we're creating a meta-instance that is based on a
|
||||
glob reference rather than a hash reference. This example is largely
|
||||
based on the Piotr Roszatycki's L<MooseX::GlobRef> module.
|
||||
|
||||
Our extension is a role which will be applied to L<Moose::Meta::Instance>,
|
||||
which creates hash reference based objects. We need to override all the methods
|
||||
which make assumptions about the object's data structure.
|
||||
|
||||
The first method we override is C<create_instance>:
|
||||
|
||||
sub create_instance {
|
||||
my $self = shift;
|
||||
my $sym = gensym();
|
||||
bless $sym, $self->_class_name;
|
||||
}
|
||||
|
||||
This returns an glob reference which has been blessed into our
|
||||
meta-instance's associated class.
|
||||
|
||||
We also override C<clone_instance> to create a new array reference:
|
||||
|
||||
sub clone_instance {
|
||||
my ( $self, $instance ) = @_;
|
||||
|
||||
my $new_sym = gensym();
|
||||
%{*$new_sym} = %{*$instance};
|
||||
|
||||
bless $new_sym, $self->_class_name;
|
||||
}
|
||||
|
||||
After that, we have a series of methods which mediate access to the
|
||||
object's slots (attributes are stored in "slots"). In the default
|
||||
instance class, these expect the object to be a hash reference, but we
|
||||
need to change this to expect a glob reference instead.
|
||||
|
||||
sub get_slot_value {
|
||||
my ( $self, $instance, $slot_name ) = @_;
|
||||
*$instance->{$slot_name};
|
||||
}
|
||||
|
||||
This level of indirection probably makes our instance class I<slower>
|
||||
than the default. However, when attribute access is inlined, this
|
||||
lookup will be cached:
|
||||
|
||||
sub inline_slot_access {
|
||||
my ( $self, $instance, $slot_name ) = @_;
|
||||
return '*{' . $instance . '}->{' . $slot_name . '}';
|
||||
}
|
||||
|
||||
The code snippet that the C<inline_slot_access> method returns will
|
||||
get C<eval>'d once per attribute.
|
||||
|
||||
Finally, we use this meta-instance in our C<MyApp::User> class:
|
||||
|
||||
Moose::Util::MetaRole::apply_metaroles(
|
||||
for => __PACKAGE__,
|
||||
class_metaroles => {
|
||||
instance => ['My::Meta::Instance'],
|
||||
},
|
||||
);
|
||||
|
||||
We actually don't recommend the use of L<Moose::Util::MetaRole> directly in
|
||||
your class in most cases. Typically, this would be provided by a
|
||||
L<Moose::Exporter>-based module which handles applying the role for you.
|
||||
|
||||
=head1 CONCLUSION
|
||||
|
||||
This recipe shows how to create your own meta-instance class. It's
|
||||
unlikely that you'll need to do this yourself, but it's interesting to
|
||||
take a peek at how Moose works under the hood.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
There are a few meta-instance class extensions on CPAN:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * L<MooseX::Singleton>
|
||||
|
||||
This module extends the instance class in order to ensure that the
|
||||
object is a singleton. The instance it uses is still a blessed hash
|
||||
reference.
|
||||
|
||||
=item * L<MooseX::GlobRef>
|
||||
|
||||
This module makes the instance a blessed glob reference. This lets you
|
||||
use a handle as an object instance.
|
||||
|
||||
=back
|
||||
|
||||
=begin testing
|
||||
|
||||
{
|
||||
package MyApp::Employee;
|
||||
|
||||
use Moose;
|
||||
extends 'MyApp::User';
|
||||
|
||||
has 'employee_number' => ( is => 'rw' );
|
||||
}
|
||||
|
||||
for my $x ( 0 .. 1 ) {
|
||||
MyApp::User->meta->make_immutable if $x;
|
||||
|
||||
my $user = MyApp::User->new(
|
||||
name => 'Faye',
|
||||
email => 'faye@example.com',
|
||||
);
|
||||
|
||||
ok( eval { *{$user} }, 'user object is an glob ref with some values' );
|
||||
|
||||
is( $user->name, 'Faye', 'check name' );
|
||||
is( $user->email, 'faye@example.com', 'check email' );
|
||||
|
||||
$user->name('Ralph');
|
||||
is( $user->name, 'Ralph', 'check name after changing it' );
|
||||
|
||||
$user->email('ralph@example.com');
|
||||
is( $user->email, 'ralph@example.com', 'check email after changing it' );
|
||||
}
|
||||
|
||||
for my $x ( 0 .. 1 ) {
|
||||
MyApp::Employee->meta->make_immutable if $x;
|
||||
|
||||
my $emp = MyApp::Employee->new(
|
||||
name => 'Faye',
|
||||
email => 'faye@example.com',
|
||||
employee_number => $x,
|
||||
);
|
||||
|
||||
ok( eval { *{$emp} }, 'employee object is an glob ref with some values' );
|
||||
|
||||
is( $emp->name, 'Faye', 'check name' );
|
||||
is( $emp->email, 'faye@example.com', 'check email' );
|
||||
is( $emp->employee_number, $x, 'check employee_number' );
|
||||
|
||||
$emp->name('Ralph');
|
||||
is( $emp->name, 'Ralph', 'check name after changing it' );
|
||||
|
||||
$emp->email('ralph@example.com');
|
||||
is( $emp->email, 'ralph@example.com', 'check email after changing it' );
|
||||
|
||||
$emp->employee_number(42);
|
||||
is( $emp->employee_number, 42, 'check employee_number after changing it' );
|
||||
}
|
||||
|
||||
=end testing
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stevan Little <stevan@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shawn M Moore <sartak@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Hans Dieter Pearcey <hdp@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Chris Prather <chris@prather.org>
|
||||
|
||||
=item *
|
||||
|
||||
Matt S Trout <mstrout@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2006 by Infinity Interactive, Inc.
|
||||
|
||||
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
|
||||
325
CPAN/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod
Normal file
325
CPAN/Moose/Cookbook/Meta/Labeled_AttributeTrait.pod
Normal file
@@ -0,0 +1,325 @@
|
||||
# PODNAME: Moose::Cookbook::Meta::Labeled_AttributeTrait
|
||||
# ABSTRACT: Labels implemented via attribute traits
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Moose::Cookbook::Meta::Labeled_AttributeTrait - Labels implemented via attribute traits
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.2207
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyApp::Meta::Attribute::Trait::Labeled;
|
||||
use Moose::Role;
|
||||
Moose::Util::meta_attribute_alias('Labeled');
|
||||
|
||||
has label => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
predicate => 'has_label',
|
||||
);
|
||||
|
||||
package MyApp::Website;
|
||||
use Moose;
|
||||
|
||||
has url => (
|
||||
traits => [qw/Labeled/],
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
label => "The site's URL",
|
||||
);
|
||||
|
||||
has name => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
|
||||
sub dump {
|
||||
my $self = shift;
|
||||
|
||||
my $meta = $self->meta;
|
||||
|
||||
my $dump = '';
|
||||
|
||||
for my $attribute ( map { $meta->get_attribute($_) }
|
||||
sort $meta->get_attribute_list ) {
|
||||
|
||||
if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
|
||||
&& $attribute->has_label ) {
|
||||
$dump .= $attribute->label;
|
||||
}
|
||||
else {
|
||||
$dump .= $attribute->name;
|
||||
}
|
||||
|
||||
my $reader = $attribute->get_read_method;
|
||||
$dump .= ": " . $self->$reader . "\n";
|
||||
}
|
||||
|
||||
return $dump;
|
||||
}
|
||||
|
||||
package main;
|
||||
|
||||
my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
|
||||
|
||||
=head1 SUMMARY
|
||||
|
||||
In this recipe, we begin to delve into the wonder of meta-programming.
|
||||
Some readers may scoff and claim that this is the arena of only the
|
||||
most twisted Moose developers. Absolutely not! Any sufficiently
|
||||
twisted developer can benefit greatly from going more meta.
|
||||
|
||||
Our goal is to allow each attribute to have a human-readable "label"
|
||||
attached to it. Such labels would be used when showing data to an end
|
||||
user. In this recipe we label the C<url> attribute with "The site's
|
||||
URL" and create a simple method showing how to use that label.
|
||||
|
||||
=head1 META-ATTRIBUTE OBJECTS
|
||||
|
||||
All the attributes of a Moose-based object are actually objects themselves.
|
||||
These objects have methods and attributes. Let's look at a concrete example.
|
||||
|
||||
has 'x' => ( isa => 'Int', is => 'ro' );
|
||||
has 'y' => ( isa => 'Int', is => 'rw' );
|
||||
|
||||
Internally, the metaclass for C<Point> has two L<Moose::Meta::Attribute>
|
||||
objects. There are several methods for getting meta-attributes out of a
|
||||
metaclass, one of which is C<get_attribute_list>. This method is called on the
|
||||
metaclass object.
|
||||
|
||||
The C<get_attribute_list> method returns a list of attribute names. You can
|
||||
then use C<get_attribute> to get the L<Moose::Meta::Attribute> object itself.
|
||||
|
||||
Once you have this meta-attribute object, you can call methods on it like
|
||||
this:
|
||||
|
||||
print $point->meta->get_attribute('x')->type_constraint;
|
||||
=> Int
|
||||
|
||||
To add a label to our attributes there are two steps. First, we need a new
|
||||
attribute metaclass trait that can store a label for an attribute. Second, we
|
||||
need to apply that trait to our attributes.
|
||||
|
||||
=head1 TRAITS
|
||||
|
||||
Roles that apply to metaclasses have a special name: traits. Don't let
|
||||
the change in nomenclature fool you, B<traits are just roles>.
|
||||
|
||||
L<Moose/has> allows you to pass a C<traits> parameter for an
|
||||
attribute. This parameter takes a list of trait names which are
|
||||
composed into an anonymous metaclass, and that anonymous metaclass is
|
||||
used for the attribute.
|
||||
|
||||
Yes, we still have lots of metaclasses in the background, but they're
|
||||
managed by Moose for you.
|
||||
|
||||
Traits can do anything roles can do. They can add or refine
|
||||
attributes, wrap methods, provide more methods, define an interface,
|
||||
etc. The only difference is that you're now changing the attribute
|
||||
metaclass instead of a user-level class.
|
||||
|
||||
=head1 DISSECTION
|
||||
|
||||
We start by creating a package for our trait.
|
||||
|
||||
package MyApp::Meta::Attribute::Trait::Labeled;
|
||||
use Moose::Role;
|
||||
|
||||
has label => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
predicate => 'has_label',
|
||||
);
|
||||
|
||||
You can see that a trait is just a L<Moose::Role>. In this case, our role
|
||||
contains a single attribute, C<label>. Any attribute which does this trait
|
||||
will now have a label.
|
||||
|
||||
We also register our trait with Moose:
|
||||
|
||||
Moose::Util::meta_attribute_alias('Labeled');
|
||||
|
||||
This allows Moose to find our trait by the short name C<Labeled> when passed
|
||||
to the C<traits> attribute option, rather than requiring the full package
|
||||
name to be specified.
|
||||
|
||||
Finally, we pass our trait when defining an attribute:
|
||||
|
||||
has url => (
|
||||
traits => [qw/Labeled/],
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
label => "The site's URL",
|
||||
);
|
||||
|
||||
The C<traits> parameter contains a list of trait names. Moose will build an
|
||||
anonymous attribute metaclass from these traits and use it for this
|
||||
attribute.
|
||||
|
||||
The reason that we can pass the name C<Labeled>, instead of
|
||||
C<MyApp::Meta::Attribute::Trait::Labeled>, is because of the
|
||||
C<register_implementation> code we touched on previously.
|
||||
|
||||
When you pass a metaclass to C<has>, it will take the name you provide and
|
||||
prefix it with C<Moose::Meta::Attribute::Custom::Trait::>. Then it calls
|
||||
C<register_implementation> in the package. In this case, that means Moose ends
|
||||
up calling
|
||||
C<Moose::Meta::Attribute::Custom::Trait::Labeled::register_implementation>.
|
||||
|
||||
If this function exists, it should return the I<real> trait's package
|
||||
name. This is exactly what our code does, returning
|
||||
C<MyApp::Meta::Attribute::Trait::Labeled>. This is a little convoluted, and if
|
||||
you don't like it, you can always use the fully-qualified name.
|
||||
|
||||
We can access this meta-attribute and its label like this:
|
||||
|
||||
$website->meta->get_attribute('url')->label()
|
||||
|
||||
MyApp::Website->meta->get_attribute('url')->label()
|
||||
|
||||
We also have a regular attribute, C<name>:
|
||||
|
||||
has name => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
|
||||
Finally, we have a C<dump> method, which creates a human-readable
|
||||
representation of a C<MyApp::Website> object. It will use an attribute's label
|
||||
if it has one.
|
||||
|
||||
sub dump {
|
||||
my $self = shift;
|
||||
|
||||
my $meta = $self->meta;
|
||||
|
||||
my $dump = '';
|
||||
|
||||
for my $attribute ( map { $meta->get_attribute($_) }
|
||||
sort $meta->get_attribute_list ) {
|
||||
|
||||
if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
|
||||
&& $attribute->has_label ) {
|
||||
$dump .= $attribute->label;
|
||||
}
|
||||
|
||||
This is a bit of defensive code. We cannot depend on every meta-attribute
|
||||
having a label. Even if we define one for every attribute in our class, a
|
||||
subclass may neglect to do so. Or a superclass could add an attribute without
|
||||
a label.
|
||||
|
||||
We also check that the attribute has a label using the predicate we
|
||||
defined. We could instead make the label C<required>. If we have a label, we
|
||||
use it, otherwise we use the attribute name:
|
||||
|
||||
else {
|
||||
$dump .= $attribute->name;
|
||||
}
|
||||
|
||||
my $reader = $attribute->get_read_method;
|
||||
$dump .= ": " . $self->$reader . "\n";
|
||||
}
|
||||
|
||||
return $dump;
|
||||
}
|
||||
|
||||
The C<get_read_method> is part of the L<Moose::Meta::Attribute> API. It
|
||||
returns the name of a method that can read the attribute's value, I<when
|
||||
called on the real object> (don't call this on the meta-attribute).
|
||||
|
||||
=head1 CONCLUSION
|
||||
|
||||
You might wonder why you'd bother with all this. You could just hardcode "The
|
||||
Site's URL" in the C<dump> method. But we want to avoid repetition. If you
|
||||
need the label once, you may need it elsewhere, maybe in the C<as_form> method
|
||||
you write next.
|
||||
|
||||
Associating a label with an attribute just makes sense! The label is a piece
|
||||
of information I<about> the attribute.
|
||||
|
||||
It's also important to realize that this was a trivial example. You can make
|
||||
much more powerful metaclasses that I<do> things, as opposed to just storing
|
||||
some more information. For example, you could implement a metaclass that
|
||||
expires attributes after a certain amount of time:
|
||||
|
||||
has site_cache => (
|
||||
traits => ['TimedExpiry'],
|
||||
expires_after => { hours => 1 },
|
||||
refresh_with => sub { get( $_[0]->url ) },
|
||||
isa => 'Str',
|
||||
is => 'ro',
|
||||
);
|
||||
|
||||
The sky's the limit!
|
||||
|
||||
=for testing my $app
|
||||
= MyApp::Website->new( url => 'http://google.com', name => 'Google' );
|
||||
is(
|
||||
$app->dump, q{name: Google
|
||||
The site's URL: http://google.com
|
||||
}, '... got the expected dump value'
|
||||
);
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stevan Little <stevan@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shawn M Moore <sartak@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Hans Dieter Pearcey <hdp@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Chris Prather <chris@prather.org>
|
||||
|
||||
=item *
|
||||
|
||||
Matt S Trout <mstrout@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2006 by Infinity Interactive, Inc.
|
||||
|
||||
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
|
||||
224
CPAN/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod
Normal file
224
CPAN/Moose/Cookbook/Meta/PrivateOrPublic_MethodMetaclass.pod
Normal file
@@ -0,0 +1,224 @@
|
||||
# PODNAME: Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass
|
||||
# ABSTRACT: A method metaclass for marking methods public or private
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Moose::Cookbook::Meta::PrivateOrPublic_MethodMetaclass - A method metaclass for marking methods public or private
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.2207
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyApp::Meta::Method::PrivateOrPublic;
|
||||
|
||||
use Moose;
|
||||
use Moose::Util::TypeConstraints;
|
||||
|
||||
extends 'Moose::Meta::Method';
|
||||
|
||||
has '_policy' => (
|
||||
is => 'ro',
|
||||
isa => enum( [ qw( public private ) ] ),
|
||||
default => 'public',
|
||||
init_arg => 'policy',
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %options = @_;
|
||||
|
||||
my $self = $class->SUPER::wrap(%options);
|
||||
|
||||
$self->{_policy} = $options{policy};
|
||||
|
||||
$self->_add_policy_wrapper;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _add_policy_wrapper {
|
||||
my $self = shift;
|
||||
|
||||
return if $self->is_public;
|
||||
|
||||
my $name = $self->name;
|
||||
my $package = $self->package_name;
|
||||
my $real_body = $self->body;
|
||||
|
||||
my $body = sub {
|
||||
die "The $package\::$name method is private"
|
||||
unless ( scalar caller() ) eq $package;
|
||||
|
||||
goto &{$real_body};
|
||||
};
|
||||
|
||||
$self->{body} = $body;
|
||||
}
|
||||
|
||||
sub is_public { $_[0]->_policy eq 'public' }
|
||||
sub is_private { $_[0]->_policy eq 'private' }
|
||||
|
||||
package MyApp::User;
|
||||
|
||||
use Moose;
|
||||
|
||||
has 'password' => ( is => 'rw' );
|
||||
|
||||
__PACKAGE__->meta()->add_method(
|
||||
'_reset_password',
|
||||
MyApp::Meta::Method::PrivateOrPublic->new(
|
||||
name => '_reset_password',
|
||||
package_name => __PACKAGE__,
|
||||
body => sub { $_[0]->password('reset') },
|
||||
policy => 'private',
|
||||
)
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This example shows a custom method metaclass that models public versus
|
||||
private methods. If a method is defined as private, it adds a wrapper
|
||||
around the method which dies unless it is called from the class where
|
||||
it was defined.
|
||||
|
||||
The way the method is added to the class is rather ugly. If we wanted
|
||||
to make this a real feature, we'd probably want to add some sort of
|
||||
sugar to allow us to declare private methods, but that is beyond the
|
||||
scope of this recipe. See the Extending recipes for more on this
|
||||
topic.
|
||||
|
||||
The core of our custom class is the C<policy> attribute, and
|
||||
C<_add_policy_wrapper> method.
|
||||
|
||||
You'll note that we have to explicitly set the C<policy> attribute in
|
||||
our constructor:
|
||||
|
||||
$self->{_policy} = $options{policy};
|
||||
|
||||
That is necessary because Moose metaclasses do not use the meta API to
|
||||
create objects. Most Moose classes have a custom "inlined" constructor
|
||||
for speed.
|
||||
|
||||
In this particular case, our parent class's constructor is the C<wrap>
|
||||
method. We call that to build our object, but it does not include
|
||||
subclass-specific attributes.
|
||||
|
||||
The C<_add_policy_wrapper> method is where the real work is done. If
|
||||
the method is private, we construct a wrapper around the real
|
||||
subroutine which checks that the caller matches the package in which
|
||||
the subroutine was created.
|
||||
|
||||
If they don't match, it dies. If they do match, the real method is
|
||||
called. We use C<goto> so that the wrapper does not show up in the
|
||||
call stack.
|
||||
|
||||
Finally, we replace the value of C<< $self->{body} >>. This is another
|
||||
case where we have to do something a bit gross because Moose does not
|
||||
use Moose for its own implementation.
|
||||
|
||||
When we pass this method object to the metaclass's C<add_method>
|
||||
method, it will take the method body and make it available in the
|
||||
class.
|
||||
|
||||
Finally, when we retrieve these methods via the introspection API, we
|
||||
can call the C<is_public> and C<is_private> methods on them to get
|
||||
more information about the method.
|
||||
|
||||
=head1 SUMMARY
|
||||
|
||||
A custom method metaclass lets us add both behavior and
|
||||
meta-information to methods. Unfortunately, because the Perl
|
||||
interpreter does not provide easy hooks into method declaration, the
|
||||
API we have for adding these methods is not very pretty.
|
||||
|
||||
That can be improved with custom Moose-like sugar, or even by using a
|
||||
tool like L<Devel::Declare> to create full-blown new keywords in Perl.
|
||||
|
||||
=begin testing
|
||||
|
||||
package main;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::Fatal;
|
||||
|
||||
my $user = MyApp::User->new( password => 'foo!' );
|
||||
|
||||
like( exception { $user->_reset_password },
|
||||
qr/The MyApp::User::_reset_password method is private/,
|
||||
'_reset_password method dies if called outside MyApp::User class');
|
||||
|
||||
{
|
||||
package MyApp::User;
|
||||
|
||||
sub run_reset { $_[0]->_reset_password }
|
||||
}
|
||||
|
||||
$user->run_reset;
|
||||
|
||||
is( $user->password, 'reset', 'password has been reset' );
|
||||
|
||||
=end testing
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stevan Little <stevan@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shawn M Moore <sartak@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Hans Dieter Pearcey <hdp@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Chris Prather <chris@prather.org>
|
||||
|
||||
=item *
|
||||
|
||||
Matt S Trout <mstrout@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2006 by Infinity Interactive, Inc.
|
||||
|
||||
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
|
||||
157
CPAN/Moose/Cookbook/Meta/Table_MetaclassTrait.pod
Normal file
157
CPAN/Moose/Cookbook/Meta/Table_MetaclassTrait.pod
Normal file
@@ -0,0 +1,157 @@
|
||||
# PODNAME: Moose::Cookbook::Meta::Table_MetaclassTrait
|
||||
# ABSTRACT: Adding a "table" attribute as a metaclass trait
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Moose::Cookbook::Meta::Table_MetaclassTrait - Adding a "table" attribute as a metaclass trait
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.2207
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# in lib/MyApp/Meta/Class/Trait/HasTable.pm
|
||||
package MyApp::Meta::Class::Trait::HasTable;
|
||||
use Moose::Role;
|
||||
Moose::Util::meta_class_alias('HasTable');
|
||||
|
||||
has table => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
|
||||
# in lib/MyApp/User.pm
|
||||
package MyApp::User;
|
||||
use Moose -traits => 'HasTable';
|
||||
|
||||
__PACKAGE__->meta->table('User');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
In this recipe, we'll create a class metaclass trait which has a "table"
|
||||
attribute. This trait is for classes associated with a DBMS table, as one
|
||||
might do for an ORM.
|
||||
|
||||
In this example, the table name is just a string, but in a real ORM
|
||||
the table might be an object describing the table.
|
||||
|
||||
=begin testing-SETUP
|
||||
|
||||
BEGIN {
|
||||
package MyApp::Meta::Class::Trait::HasTable;
|
||||
use Moose::Role;
|
||||
Moose::Util::meta_class_alias('HasTable');
|
||||
|
||||
has table => (
|
||||
is => 'rw',
|
||||
isa => 'Str',
|
||||
);
|
||||
}
|
||||
|
||||
=end testing-SETUP
|
||||
|
||||
=head1 THE METACLASS TRAIT
|
||||
|
||||
This really is as simple as the recipe L</SYNOPSIS> shows. The trick is
|
||||
getting your classes to use this metaclass, and providing some sort of sugar
|
||||
for declaring the table. This is covered in
|
||||
L<Moose::Cookbook::Extending::Debugging_BaseClassRole>, which shows how to
|
||||
make a module like C<Moose.pm> itself, with sugar like C<has_table()>.
|
||||
|
||||
=head2 Using this Metaclass Trait in Practice
|
||||
|
||||
Accessing this new C<table> attribute is quite simple. Given a class
|
||||
named C<MyApp::User>, we could simply write the following:
|
||||
|
||||
my $table = MyApp::User->meta->table;
|
||||
|
||||
As long as C<MyApp::User> has arranged to apply the
|
||||
C<MyApp::Meta::Class::Trait::HasTable> to its metaclass, this method call just
|
||||
works. If we want to be more careful, we can check that the class metaclass
|
||||
object has a C<table> method:
|
||||
|
||||
$table = MyApp::User->meta->table
|
||||
if MyApp::User->meta->can('table');
|
||||
|
||||
In theory, this is not entirely correct, since the metaclass might be getting
|
||||
its C<table> method from a I<different> trait. In practice, you are unlikely
|
||||
to encounter this sort of problem.
|
||||
|
||||
=head1 RECIPE CAVEAT
|
||||
|
||||
This recipe doesn't work when you paste it all into a single file. This is
|
||||
because the C<< use Moose -traits => 'HasTable'; >> line ends up being
|
||||
executed before the C<table> attribute is defined.
|
||||
|
||||
When the two packages are separate files, this just works.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Moose::Cookbook::Meta::Labeled_AttributeTrait> - Labels implemented via
|
||||
attribute traits
|
||||
=pod
|
||||
|
||||
=for testing can_ok( MyApp::User->meta, 'table' );
|
||||
is( MyApp::User->meta->table, 'User', 'My::User table is User' );
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stevan Little <stevan@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shawn M Moore <sartak@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Hans Dieter Pearcey <hdp@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Chris Prather <chris@prather.org>
|
||||
|
||||
=item *
|
||||
|
||||
Matt S Trout <mstrout@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2006 by Infinity Interactive, Inc.
|
||||
|
||||
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
|
||||
117
CPAN/Moose/Cookbook/Meta/WhyMeta.pod
Normal file
117
CPAN/Moose/Cookbook/Meta/WhyMeta.pod
Normal file
@@ -0,0 +1,117 @@
|
||||
# PODNAME: Moose::Cookbook::Meta::WhyMeta
|
||||
# ABSTRACT: Welcome to the meta world (Why Go Meta?)
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Moose::Cookbook::Meta::WhyMeta - Welcome to the meta world (Why Go Meta?)
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.2207
|
||||
|
||||
=head1 SUMMARY
|
||||
|
||||
You might want to read L<Moose::Manual::MOP> if you haven't done so
|
||||
yet.
|
||||
|
||||
If you've ever thought "Moose is great, but I wish it did X
|
||||
differently", then you've gone meta. The meta recipes demonstrate how
|
||||
to change and extend the way Moose works by extending and overriding
|
||||
how the meta classes (L<Moose::Meta::Class>,
|
||||
L<Moose::Meta::Attribute>, etc) work.
|
||||
|
||||
The metaclass API is a set of classes that describe classes, roles,
|
||||
attributes, etc. The metaclass API lets you ask questions about a
|
||||
class, like "what attributes does it have?", or "what roles does the
|
||||
class do?"
|
||||
|
||||
The metaclass system also lets you make changes to a class, for
|
||||
example by adding new methods or attributes.
|
||||
|
||||
The interface presented by L<Moose.pm|Moose> (C<has>, C<with>,
|
||||
C<extends>) is just a thin layer of syntactic sugar over the
|
||||
underlying metaclass system.
|
||||
|
||||
By extending and changing how this metaclass system works, you can
|
||||
create your own Moose variant.
|
||||
|
||||
=head2 Examples
|
||||
|
||||
Let's say that you want to add additional properties to
|
||||
attributes. Specifically, we want to add a "label" property to each
|
||||
attribute, so we can write C<<
|
||||
My::Class->meta()->get_attribute('size')->label() >>. The first
|
||||
recipe shows how to do this using an attribute trait.
|
||||
|
||||
You might also want to add additional properties to your
|
||||
metaclass. For example, if you were writing an ORM based on Moose, you
|
||||
could associate a table name with each class via the class's metaclass
|
||||
object, letting you write C<< My::Class->meta()->table_name() >>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Many of the MooseX modules on CPAN implement metaclass extensions. A
|
||||
couple good examples include L<MooseX::Aliases> and
|
||||
L<MooseX::UndefTolerant>. For a more complex example see
|
||||
L<Fey::ORM> or L<Bread::Board::Declare>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Stevan Little <stevan@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=item *
|
||||
|
||||
Jesse Luehrs <doy@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Shawn M Moore <sartak@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
|
||||
|
||||
=item *
|
||||
|
||||
Karen Etheridge <ether@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Florian Ragwitz <rafl@debian.org>
|
||||
|
||||
=item *
|
||||
|
||||
Hans Dieter Pearcey <hdp@cpan.org>
|
||||
|
||||
=item *
|
||||
|
||||
Chris Prather <chris@prather.org>
|
||||
|
||||
=item *
|
||||
|
||||
Matt S Trout <mstrout@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2006 by Infinity Interactive, Inc.
|
||||
|
||||
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
|
||||
Reference in New Issue
Block a user