Add Moose package

CPAN/Moose/Util/MetaRole.pm

@@ -0,0 +1,329 @@
+package Moose::Util::MetaRole;
+our $VERSION = '2.2207';
+
+use strict;
+use warnings;
+use Scalar::Util 'blessed';
+
+use List::Util 1.33 qw( first all );
+use Moose::Deprecated;
+use Moose::Util 'throw_exception';
+
+sub apply_metaroles {
+    my %args = @_;
+
+    my $for = _metathing_for( $args{for} );
+
+    if ( $for->isa('Moose::Meta::Role') ) {
+        return _make_new_metaclass( $for, $args{role_metaroles}, 'role' );
+    }
+    else {
+        return _make_new_metaclass( $for, $args{class_metaroles}, 'class' );
+    }
+}
+
+sub _metathing_for {
+    my $passed = shift;
+
+    my $found
+        = blessed $passed
+        ? $passed
+        : Class::MOP::class_of($passed);
+
+    return $found
+        if defined $found
+            && blessed $found
+            && (   $found->isa('Moose::Meta::Role')
+                || $found->isa('Moose::Meta::Class') );
+
+    local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+
+    throw_exception( InvalidArgPassedToMooseUtilMetaRole => argument => $passed );
+}
+
+sub _make_new_metaclass {
+    my $for     = shift;
+    my $roles   = shift;
+    my $primary = shift;
+
+    return $for unless keys %{$roles};
+
+    my $new_metaclass
+        = exists $roles->{$primary}
+        ? _make_new_class( ref $for, $roles->{$primary} )
+        : blessed $for;
+
+    my %classes;
+
+    for my $key ( grep { $_ ne $primary } keys %{$roles} ) {
+        my $attr = first {$_}
+            map { $for->meta->find_attribute_by_name($_) } (
+            $key . '_metaclass',
+            $key . '_class'
+        );
+
+        my $reader = $attr->get_read_method;
+
+        $classes{ $attr->init_arg }
+            = _make_new_class( $for->$reader(), $roles->{$key} );
+    }
+
+    my $new_meta = $new_metaclass->reinitialize( $for, %classes );
+
+    return $new_meta;
+}
+
+sub apply_base_class_roles {
+    my %args = @_;
+
+    my $meta = _metathing_for( $args{for} || $args{for_class} );
+    throw_exception( CannotApplyBaseClassRolesToRole => params    => \%args,
+                                                        role_name => $meta->name,
+                   )
+        if $meta->isa('Moose::Meta::Role');
+
+    my $new_base = _make_new_class(
+        $meta->name,
+        $args{roles},
+        [ $meta->superclasses() ],
+    );
+
+    $meta->superclasses($new_base)
+        if $new_base ne $meta->name();
+}
+
+sub _make_new_class {
+    my $existing_class = shift;
+    my $roles          = shift;
+    my $superclasses   = shift || [$existing_class];
+
+    return $existing_class unless $roles;
+
+    my $meta = Class::MOP::Class->initialize($existing_class);
+
+    return $existing_class
+        if $meta->can('does_role') && all  { $meta->does_role($_) }
+                                      grep { !ref $_ } @{$roles};
+
+    return Moose::Meta::Class->create_anon_class(
+        superclasses => $superclasses,
+        roles        => $roles,
+        cache        => 1,
+    )->name();
+}
+
+1;
+
+# ABSTRACT: Apply roles to any metaclass, as well as the object base class
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
+
+=head1 VERSION
+
+version 2.2207
+
+=head1 SYNOPSIS
+
+  package MyApp::Moose;
+
+  use Moose ();
+  use Moose::Exporter;
+  use Moose::Util::MetaRole;
+
+  use MyApp::Role::Meta::Class;
+  use MyApp::Role::Meta::Method::Constructor;
+  use MyApp::Role::Object;
+
+  Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+  sub init_meta {
+      shift;
+      my %args = @_;
+
+      Moose->init_meta(%args);
+
+      Moose::Util::MetaRole::apply_metaroles(
+          for             => $args{for_class},
+          class_metaroles => {
+              class       => ['MyApp::Role::Meta::Class'],
+              constructor => ['MyApp::Role::Meta::Method::Constructor'],
+          },
+      );
+
+      Moose::Util::MetaRole::apply_base_class_roles(
+          for   => $args{for_class},
+          roles => ['MyApp::Role::Object'],
+      );
+
+      return $args{for_class}->meta();
+  }
+
+=head1 DESCRIPTION
+
+This utility module is designed to help authors of Moose extensions
+write extensions that are able to cooperate with other Moose
+extensions. To do this, you must write your extensions as roles, which
+can then be dynamically applied to the caller's metaclasses.
+
+This module makes sure to preserve any existing superclasses and roles
+already set for the meta objects, which means that any number of
+extensions can apply roles in any order.
+
+=head1 USAGE
+
+The easiest way to use this module is through L<Moose::Exporter>, which can
+generate the appropriate C<init_meta> method for you, and make sure it is
+called when imported.
+
+=head1 FUNCTIONS
+
+This module provides two functions.
+
+=head2 apply_metaroles( ... )
+
+This function will apply roles to one or more metaclasses for the specified
+class. It will return a new metaclass object for the class or role passed in
+the "for" parameter.
+
+It accepts the following parameters:
+
+=over 4
+
+=item * for => $name
+
+This specifies the class for which to alter the meta classes. This can be a
+package name, or an appropriate meta-object (a L<Moose::Meta::Class> or
+L<Moose::Meta::Role>).
+
+=item * class_metaroles => \%roles
+
+This is a hash reference specifying which metaroles will be applied to the
+class metaclass and its contained metaclasses and helper classes.
+
+Each key should in turn point to an array reference of role names.
+
+It accepts the following keys:
+
+=over 8
+
+=item class
+
+=item attribute
+
+=item method
+
+=item wrapped_method
+
+=item instance
+
+=item constructor
+
+=item destructor
+
+=item error
+
+=back
+
+=item * role_metaroles => \%roles
+
+This is a hash reference specifying which metaroles will be applied to the
+role metaclass and its contained metaclasses and helper classes.
+
+It accepts the following keys:
+
+=over 8
+
+=item role
+
+=item attribute
+
+=item method
+
+=item required_method
+
+=item conflicting_method
+
+=item application_to_class
+
+=item application_to_role
+
+=item application_to_instance
+
+=item application_role_summation
+
+=item applied_attribute
+
+=back
+
+=back
+
+=head2 apply_base_class_roles( for => $class, roles => \@roles )
+
+This function will apply the specified roles to the object's base class.
+
+=head1 BUGS
+
+See L<Moose/BUGS> for details on reporting bugs.
+
+=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

CPAN/Moose/Util/TypeConstraints/Builtins.pm

@@ -0,0 +1,305 @@
+package Moose::Util::TypeConstraints::Builtins;
+our $VERSION = '2.2207';
+
+use strict;
+use warnings;
+
+use Class::Load qw( is_class_loaded );
+use List::Util 1.33 ();
+use Scalar::Util qw( blessed );
+
+sub type { goto &Moose::Util::TypeConstraints::type }
+sub subtype { goto &Moose::Util::TypeConstraints::subtype }
+sub as { goto &Moose::Util::TypeConstraints::as }
+sub where (&) { goto &Moose::Util::TypeConstraints::where }
+sub inline_as (&) { goto &Moose::Util::TypeConstraints::inline_as }
+
+sub define_builtins {
+    my $registry = shift;
+
+    type 'Any'    # meta-type including all
+        => where {1}
+        => inline_as { '1' };
+
+    subtype 'Item'  # base type
+        => as 'Any'
+        => inline_as { '1' };
+
+    subtype 'Undef'
+        => as 'Item'
+        => where { !defined($_) }
+        => inline_as {
+            '!defined(' . $_[1] . ')'
+        };
+
+    subtype 'Defined'
+        => as 'Item'
+        => where { defined($_) }
+        => inline_as {
+            'defined(' . $_[1] . ')'
+        };
+
+    subtype 'Bool'
+        => as 'Item'
+        => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }
+        => inline_as {
+            '('
+                . '!defined(' . $_[1] . ') '
+                . '|| ' . $_[1] . ' eq "" '
+                . '|| (' . $_[1] . '."") eq "1" '
+                . '|| (' . $_[1] . '."") eq "0"'
+            . ')'
+        };
+
+    subtype 'Value'
+        => as 'Defined'
+        => where { !ref($_) }
+        => inline_as {
+            $_[0]->parent()->_inline_check($_[1])
+            . ' && !ref(' . $_[1] . ')'
+        };
+
+    subtype 'Ref'
+        => as 'Defined'
+        => where { ref($_) }
+            # no need to call parent - ref also checks for definedness
+        => inline_as { 'ref(' . $_[1] . ')' };
+
+    subtype 'Str'
+        => as 'Value'
+        => where { ref(\$_) eq 'SCALAR' || ref(\(my $val = $_)) eq 'SCALAR' }
+        => inline_as {
+            $_[0]->parent()->_inline_check($_[1])
+            . ' && ('
+                . 'ref(\\' . $_[1] . ') eq "SCALAR"'
+                . ' || ref(\\(my $val = ' . $_[1] . ')) eq "SCALAR"'
+            . ')'
+        };
+
+    my $value_type = Moose::Util::TypeConstraints::find_type_constraint('Value');
+    subtype 'Num'
+        => as 'Str'
+        => where {
+        my $val = $_;
+        ($val =~ /\A[+-]?[0-9]+\z/) ||
+        ( $val =~ /\A(?:[+-]?)              # matches optional +- in the beginning
+        (?=[0-9]|\.[0-9])                   # matches previous +- only if there is something like 3 or .3
+        [0-9]*                              # matches 0-9 zero or more times
+        (?:\.[0-9]+)?                       # matches optional .89 or nothing
+        (?:[Ee](?:[+-]?[0-9]+))?            # matches E1 or e1 or e-1 or e+1 etc
+        \z/x );
+           }
+        => inline_as {
+            # the long Str tests are redundant here
+        #storing $_[1] in a temporary value,
+        #so that $_[1] won't get converted to a string for regex match
+        #see t/attributes/numeric_defaults.t for more details
+        'my $val = '.$_[1].';'.
+        $value_type->_inline_check('$val')
+        .' && ( $val =~ /\A[+-]?[0-9]+\z/ || '
+        . '$val =~ /\A(?:[+-]?)             # matches optional +- in the beginning
+                (?=[0-9]|\.[0-9])           # matches previous +- only if there is something like 3 or .3
+                [0-9]*                      # matches 0-9 zero or more times
+                (?:\.[0-9]+)?               # matches optional .89 or nothing
+                (?:[Ee](?:[+-]?[0-9]+))?    # matches E1 or e1 or e-1 or e+1 etc
+                \z/x ); '
+        };
+
+    subtype 'Int'
+        => as 'Num'
+        => where { (my $val = $_) =~ /\A-?[0-9]+\z/ }
+        => inline_as {
+            $value_type->_inline_check($_[1])
+            . ' && (my $val = ' . $_[1] . ') =~ /\A-?[0-9]+\z/'
+        };
+
+    subtype 'CodeRef'
+        => as 'Ref'
+        => where { ref($_) eq 'CODE' }
+        => inline_as { 'ref(' . $_[1] . ') eq "CODE"' };
+
+    subtype 'RegexpRef'
+        => as 'Ref'
+        => where( \&_RegexpRef )
+        => inline_as {
+            'Moose::Util::TypeConstraints::Builtins::_RegexpRef(' . $_[1] . ')'
+        };
+
+    subtype 'GlobRef'
+        => as 'Ref'
+        => where { ref($_) eq 'GLOB' }
+        => inline_as { 'ref(' . $_[1] . ') eq "GLOB"' };
+
+    # NOTE: scalar filehandles are GLOB refs, but a GLOB ref is not always a
+    # filehandle
+    subtype 'FileHandle'
+        => as 'Ref'
+        => where {
+            (ref($_) eq "GLOB" && Scalar::Util::openhandle($_))
+         || (blessed($_) && $_->isa("IO::Handle"));
+        }
+        => inline_as {
+            '(ref(' . $_[1] . ') eq "GLOB" '
+            . '&& Scalar::Util::openhandle(' . $_[1] . ')) '
+            . '|| (Scalar::Util::blessed(' . $_[1] . ') '
+            . '&& ' . $_[1] . '->isa("IO::Handle"))'
+        };
+
+    subtype 'Object'
+        => as 'Ref'
+        => where { blessed($_) }
+        => inline_as { 'Scalar::Util::blessed(' . $_[1] . ')' };
+
+    subtype 'ClassName'
+        => as 'Str'
+        => where { is_class_loaded($_) }
+            # the long Str tests are redundant here
+        => inline_as { 'Class::Load::is_class_loaded(' . $_[1] . ')' };
+
+    subtype 'RoleName'
+        => as 'ClassName'
+        => where {
+            (Class::MOP::class_of($_) || return)->isa('Moose::Meta::Role');
+        }
+        => inline_as {
+            $_[0]->parent()->_inline_check($_[1])
+            . ' && do {'
+                . 'my $meta = Class::MOP::class_of(' . $_[1] . ');'
+                . '$meta && $meta->isa("Moose::Meta::Role");'
+            . '}'
+        };
+
+    $registry->add_type_constraint(
+        Moose::Meta::TypeConstraint::Parameterizable->new(
+            name               => 'ScalarRef',
+            package_defined_in => __PACKAGE__,
+            parent =>
+                Moose::Util::TypeConstraints::find_type_constraint('Ref'),
+            constraint => sub { ref($_) eq 'SCALAR' || ref($_) eq 'REF' },
+            constraint_generator => sub {
+                my $type_parameter = shift;
+                my $check = $type_parameter->_compiled_type_constraint;
+                return sub {
+                    return $check->( ${$_} );
+                };
+            },
+            inlined => sub {
+                'ref(' . $_[1] . ') eq "SCALAR" '
+                  . '|| ref(' . $_[1] . ') eq "REF"'
+            },
+            inline_generator => sub {
+                my $self           = shift;
+                my $type_parameter = shift;
+                my $val            = shift;
+                '(ref(' . $val . ') eq "SCALAR" || ref(' . $val . ') eq "REF") '
+                  . '&& ' . $type_parameter->_inline_check('${(' . $val . ')}')
+            },
+        )
+    );
+
+    $registry->add_type_constraint(
+        Moose::Meta::TypeConstraint::Parameterizable->new(
+            name               => 'ArrayRef',
+            package_defined_in => __PACKAGE__,
+            parent =>
+                Moose::Util::TypeConstraints::find_type_constraint('Ref'),
+            constraint => sub { ref($_) eq 'ARRAY' },
+            constraint_generator => sub {
+                my $type_parameter = shift;
+                my $check = $type_parameter->_compiled_type_constraint;
+                return sub {
+                    foreach my $x (@$_) {
+                        ( $check->($x) ) || return;
+                    }
+                    1;
+                    }
+            },
+            inlined          => sub { 'ref(' . $_[1] . ') eq "ARRAY"' },
+            inline_generator => sub {
+                my $self           = shift;
+                my $type_parameter = shift;
+                my $val            = shift;
+
+                'do {'
+                    . 'my $check = ' . $val . ';'
+                    . 'ref($check) eq "ARRAY" '
+                        . '&& &List::Util::all('
+                            . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
+                            . '@{$check}'
+                        . ')'
+                . '}';
+            },
+        )
+    );
+
+    $registry->add_type_constraint(
+        Moose::Meta::TypeConstraint::Parameterizable->new(
+            name               => 'HashRef',
+            package_defined_in => __PACKAGE__,
+            parent =>
+                Moose::Util::TypeConstraints::find_type_constraint('Ref'),
+            constraint => sub { ref($_) eq 'HASH' },
+            constraint_generator => sub {
+                my $type_parameter = shift;
+                my $check = $type_parameter->_compiled_type_constraint;
+                return sub {
+                    foreach my $x ( values %$_ ) {
+                        ( $check->($x) ) || return;
+                    }
+                    1;
+                    }
+            },
+            inlined          => sub { 'ref(' . $_[1] . ') eq "HASH"' },
+            inline_generator => sub {
+                my $self           = shift;
+                my $type_parameter = shift;
+                my $val            = shift;
+
+                'do {'
+                    . 'my $check = ' . $val . ';'
+                    . 'ref($check) eq "HASH" '
+                        . '&& &List::Util::all('
+                            . 'sub { ' . $type_parameter->_inline_check('$_') . ' }, '
+                            . 'values %{$check}'
+                        . ')'
+                . '}';
+            },
+        )
+    );
+
+    $registry->add_type_constraint(
+        Moose::Meta::TypeConstraint::Parameterizable->new(
+            name               => 'Maybe',
+            package_defined_in => __PACKAGE__,
+            parent =>
+                Moose::Util::TypeConstraints::find_type_constraint('Item'),
+            constraint           => sub {1},
+            constraint_generator => sub {
+                my $type_parameter = shift;
+                my $check = $type_parameter->_compiled_type_constraint;
+                return sub {
+                    return 1 if not( defined($_) ) || $check->($_);
+                    return;
+                    }
+            },
+            inlined          => sub {'1'},
+            inline_generator => sub {
+                my $self           = shift;
+                my $type_parameter = shift;
+                my $val            = shift;
+                '!defined(' . $val . ') '
+                  . '|| (' . $type_parameter->_inline_check($val) . ')'
+            },
+        )
+    );
+}
+
+1;
+
+__END__
+
+=pod
+
+=for pod_coverage_needs_some_pod
+
+=cut