Initial Commit

database/perl/vendor/lib/Class/MOP/Method/Accessor.pm

@@ -0,0 +1,404 @@
+package Class::MOP::Method::Accessor;
+our $VERSION = '2.2014';
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
+
+use parent 'Class::MOP::Method::Generated';
+
+sub new {
+    my $class   = shift;
+    my %options = @_;
+
+    (exists $options{attribute})
+        || $class->_throw_exception( MustSupplyAnAttributeToConstructWith => params => \%options,
+                                                                    class  => $class,
+                          );
+
+    (exists $options{accessor_type})
+        || $class->_throw_exception( MustSupplyAnAccessorTypeToConstructWith => params => \%options,
+                                                                       class  => $class,
+                          );
+
+    (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
+        || $class->_throw_exception( MustSupplyAClassMOPAttributeInstance => params => \%options,
+                                                                    class  => $class
+                          );
+
+    ($options{package_name} && $options{name})
+        || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options,
+                                                            class  => $class
+                          );
+
+    my $self = $class->_new(\%options);
+
+    # we don't want this creating
+    # a cycle in the code, if not
+    # needed
+    weaken($self->{'attribute'});
+
+    $self->_initialize_body;
+
+    return $self;
+}
+
+sub _new {
+    my $class = shift;
+
+    return Class::MOP::Class->initialize($class)->new_object(@_)
+        if $class ne __PACKAGE__;
+
+    my $params = @_ == 1 ? $_[0] : {@_};
+
+    return bless {
+        # inherited from Class::MOP::Method
+        body                 => $params->{body},
+        associated_metaclass => $params->{associated_metaclass},
+        package_name         => $params->{package_name},
+        name                 => $params->{name},
+        original_method      => $params->{original_method},
+
+        # inherit from Class::MOP::Generated
+        is_inline            => $params->{is_inline} || 0,
+        definition_context   => $params->{definition_context},
+
+        # defined in this class
+        attribute            => $params->{attribute},
+        accessor_type        => $params->{accessor_type},
+    } => $class;
+}
+
+## accessors
+
+sub associated_attribute { (shift)->{'attribute'}     }
+sub accessor_type        { (shift)->{'accessor_type'} }
+
+## factory
+
+sub _initialize_body {
+    my $self = shift;
+
+    my $method_name = join "_" => (
+        '_generate',
+        $self->accessor_type,
+        'method',
+        ($self->is_inline ? 'inline' : ())
+    );
+
+    $self->{'body'} = $self->$method_name();
+}
+
+## generators
+
+sub _generate_accessor_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        if (@_ >= 2) {
+            $attr->set_value($_[0], $_[1]);
+        }
+        $attr->get_value($_[0]);
+    };
+}
+
+sub _generate_accessor_method_inline {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return try {
+        $self->_compile_code([
+            'sub {',
+                'if (@_ > 1) {',
+                    $attr->_inline_set_value('$_[0]', '$_[1]'),
+                '}',
+                $attr->_inline_get_value('$_[0]'),
+            '}',
+        ]);
+    }
+    catch {
+        $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
+                                                                  error    => $_,
+                                                                  option   => "accessor"
+                       );
+    };
+}
+
+sub _generate_reader_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+    my $class = $attr->associated_class;
+
+    return sub {
+        $self->_throw_exception( CannotAssignValueToReadOnlyAccessor => class_name => $class->name,
+                                                                value      => $_[1],
+                                                                attribute  => $attr
+                       )
+            if @_ > 1;
+        $attr->get_value($_[0]);
+    };
+}
+
+sub _generate_reader_method_inline {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+    my $attr_name = $attr->name;
+
+    return try {
+        $self->_compile_code([
+            'sub {',
+                'if (@_ > 1) {',
+                    $self->_inline_throw_exception( CannotAssignValueToReadOnlyAccessor =>
+                                                    'class_name                          => ref $_[0],'.
+                                                    'value                               => $_[1],'.
+                                                    "attribute_name                      => '".$attr_name."'",
+                    ) . ';',
+                '}',
+                $attr->_inline_get_value('$_[0]'),
+            '}',
+        ]);
+    }
+    catch {
+        $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
+                                                                  error    => $_,
+                                                                  option   => "reader"
+                       );
+    };
+}
+
+sub _generate_writer_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->set_value($_[0], $_[1]);
+    };
+}
+
+sub _generate_writer_method_inline {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return try {
+        $self->_compile_code([
+            'sub {',
+                $attr->_inline_set_value('$_[0]', '$_[1]'),
+            '}',
+        ]);
+    }
+    catch {
+        $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
+                                                                  error    => $_,
+                                                                  option   => "writer"
+                       );
+    };
+}
+
+sub _generate_predicate_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->has_value($_[0])
+    };
+}
+
+sub _generate_predicate_method_inline {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return try {
+        $self->_compile_code([
+            'sub {',
+                $attr->_inline_has_value('$_[0]'),
+            '}',
+        ]);
+    }
+    catch {
+        $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
+                                                                  error    => $_,
+                                                                  option   => "predicate"
+                       );
+    };
+}
+
+sub _generate_clearer_method {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return sub {
+        $attr->clear_value($_[0])
+    };
+}
+
+sub _generate_clearer_method_inline {
+    my $self = shift;
+    my $attr = $self->associated_attribute;
+
+    return try {
+        $self->_compile_code([
+            'sub {',
+                $attr->_inline_clear_value('$_[0]'),
+            '}',
+        ]);
+    }
+    catch {
+        $self->_throw_exception( CouldNotGenerateInlineAttributeMethod => instance => $self,
+                                                                  error    => $_,
+                                                                  option   => "clearer"
+                       );
+    };
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for accessors
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Method::Accessor - Method Meta Object for accessors
+
+=head1 VERSION
+
+version 2.2014
+
+=head1 SYNOPSIS
+
+    use Class::MOP::Method::Accessor;
+
+    my $reader = Class::MOP::Method::Accessor->new(
+        attribute     => $attribute,
+        is_inline     => 1,
+        accessor_type => 'reader',
+    );
+
+    $reader->body->execute($instance); # call the reader method
+
+=head1 DESCRIPTION
+
+This is a subclass of C<Class::MOP::Method> which is used by
+C<Class::MOP::Attribute> to generate accessor code. It handles
+generation of readers, writers, predicates and clearers. For each type
+of method, it can either create a subroutine reference, or actually
+inline code by generating a string and C<eval>'ing it.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Accessor->new(%options) >>
+
+This returns a new C<Class::MOP::Method::Accessor> based on the
+C<%options> provided.
+
+=over 4
+
+=item * attribute
+
+This is the C<Class::MOP::Attribute> for which accessors are being
+generated. This option is required.
+
+=item * accessor_type
+
+This is a string which should be one of "reader", "writer",
+"accessor", "predicate", or "clearer". This is the type of method
+being generated. This option is required.
+
+=item * is_inline
+
+This indicates whether or not the accessor should be inlined. This
+defaults to false.
+
+=item * name
+
+The method name (without a package name). This is required.
+
+=item * package_name
+
+The package name for the method. This is required.
+
+=back
+
+=item B<< $metamethod->accessor_type >>
+
+Returns the accessor type which was passed to C<new>.
+
+=item B<< $metamethod->is_inline >>
+
+Returns a boolean indicating whether or not the accessor is inlined.
+
+=item B<< $metamethod->associated_attribute >>
+
+This returns the L<Class::MOP::Attribute> object which was passed to
+C<new>.
+
+=item B<< $metamethod->body >>
+
+The method itself is I<generated> when the accessor object is
+constructed.
+
+=back
+
+=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

database/perl/vendor/lib/Class/MOP/Method/Constructor.pm

@@ -0,0 +1,251 @@
+package Class::MOP::Method::Constructor;
+our $VERSION = '2.2014';
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed', 'weaken';
+use Try::Tiny;
+
+use parent 'Class::MOP::Method::Inlined';
+
+sub new {
+    my $class   = shift;
+    my %options = @_;
+
+    (blessed $options{metaclass} && $options{metaclass}->isa('Class::MOP::Class'))
+        || $class->_throw_exception( MustSupplyAMetaclass => params => \%options,
+                                                    class  => $class
+                          )
+            if $options{is_inline};
+
+    ($options{package_name} && $options{name})
+        || $class->_throw_exception( MustSupplyPackageNameAndName => params => \%options,
+                                                            class  => $class
+                          );
+
+    my $self = $class->_new(\%options);
+
+    # we don't want this creating
+    # a cycle in the code, if not
+    # needed
+    weaken($self->{'associated_metaclass'});
+
+    $self->_initialize_body;
+
+    return $self;
+}
+
+sub _new {
+    my $class = shift;
+
+    return Class::MOP::Class->initialize($class)->new_object(@_)
+        if $class ne __PACKAGE__;
+
+    my $params = @_ == 1 ? $_[0] : {@_};
+
+    return bless {
+        # inherited from Class::MOP::Method
+        body                 => $params->{body},
+        # associated_metaclass => $params->{associated_metaclass}, # overridden
+        package_name         => $params->{package_name},
+        name                 => $params->{name},
+        original_method      => $params->{original_method},
+
+        # inherited from Class::MOP::Generated
+        is_inline            => $params->{is_inline} || 0,
+        definition_context   => $params->{definition_context},
+
+        # inherited from Class::MOP::Inlined
+        _expected_method_class => $params->{_expected_method_class},
+
+        # defined in this subclass
+        options              => $params->{options} || {},
+        associated_metaclass => $params->{metaclass},
+    }, $class;
+}
+
+## accessors
+
+sub options              { (shift)->{'options'}              }
+sub associated_metaclass { (shift)->{'associated_metaclass'} }
+
+## method
+
+sub _initialize_body {
+    my $self        = shift;
+    my $method_name = '_generate_constructor_method';
+
+    $method_name .= '_inline' if $self->is_inline;
+
+    $self->{'body'} = $self->$method_name;
+}
+
+sub _eval_environment {
+    my $self = shift;
+    return $self->associated_metaclass->_eval_environment;
+}
+
+sub _generate_constructor_method {
+    return sub { Class::MOP::Class->initialize(shift)->new_object(@_) }
+}
+
+sub _generate_constructor_method_inline {
+    my $self = shift;
+
+    my $meta = $self->associated_metaclass;
+
+    my @source = (
+        'sub {',
+            $meta->_inline_new_object,
+        '}',
+    );
+
+    warn join("\n", @source) if $self->options->{debug};
+
+    my $code = try {
+        $self->_compile_code(\@source);
+    }
+    catch {
+        my $source = join("\n", @source);
+        $self->_throw_exception( CouldNotEvalConstructor => constructor_method => $self,
+                                                    source             => $source,
+                                                    error              => $_
+                       );
+    };
+
+    return $code;
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for constructors
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Method::Constructor - Method Meta Object for constructors
+
+=head1 VERSION
+
+version 2.2014
+
+=head1 SYNOPSIS
+
+  use Class::MOP::Method::Constructor;
+
+  my $constructor = Class::MOP::Method::Constructor->new(
+      metaclass => $metaclass,
+      options   => {
+          debug => 1, # this is all for now
+      },
+  );
+
+  # calling the constructor ...
+  $constructor->body->execute($metaclass->name, %params);
+
+=head1 DESCRIPTION
+
+This is a subclass of L<Class::MOP::Method> which generates
+constructor methods.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Constructor->new(%options) >>
+
+This creates a new constructor object. It accepts a hash reference of
+options.
+
+=over 8
+
+=item * metaclass
+
+This should be a L<Class::MOP::Class> object. It is required.
+
+=item * name
+
+The method name (without a package name). This is required.
+
+=item * package_name
+
+The package name for the method. This is required.
+
+=item * is_inline
+
+This indicates whether or not the constructor should be inlined. This
+defaults to false.
+
+=back
+
+=item B<< $metamethod->is_inline >>
+
+Returns a boolean indicating whether or not the constructor is
+inlined.
+
+=item B<< $metamethod->associated_metaclass >>
+
+This returns the L<Class::MOP::Class> object for the method.
+
+=back
+
+=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

database/perl/vendor/lib/Class/MOP/Method/Generated.pm

@@ -0,0 +1,142 @@
+package Class::MOP::Method::Generated;
+our $VERSION = '2.2014';
+
+use strict;
+use warnings;
+
+use Eval::Closure;
+
+use parent 'Class::MOP::Method';
+
+## accessors
+
+sub new {
+    $_[0]->_throw_exception( CannotCallAnAbstractBaseMethod => package_name => __PACKAGE__ );
+}
+
+sub _initialize_body {
+    $_[0]->_throw_exception( NoBodyToInitializeInAnAbstractBaseClass => package_name => __PACKAGE__ );
+}
+
+sub _generate_description {
+    my ( $self, $context ) = @_;
+    $context ||= $self->definition_context;
+
+    my $desc = "generated method";
+    my $origin = "unknown origin";
+
+    if (defined $context) {
+        if (defined $context->{description}) {
+            $desc = $context->{description};
+        }
+
+        if (defined $context->{file} || defined $context->{line}) {
+            $origin = "defined at "
+                    . (defined $context->{file}
+                        ? $context->{file} : "<unknown file>")
+                    . " line "
+                    . (defined $context->{line}
+                        ? $context->{line} : "<unknown line>");
+        }
+    }
+
+    return "$desc ($origin)";
+}
+
+sub _compile_code {
+    my ( $self, @args ) = @_;
+    unshift @args, 'source' if @args % 2;
+    my %args = @args;
+
+    my $context = delete $args{context};
+    my $environment = $self->can('_eval_environment')
+        ? $self->_eval_environment
+        : {};
+
+    return eval_closure(
+        environment => $environment,
+        description => $self->_generate_description($context),
+        %args,
+    );
+}
+
+1;
+
+# ABSTRACT: Abstract base class for generated methods
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Method::Generated - Abstract base class for generated methods
+
+=head1 VERSION
+
+version 2.2014
+
+=head1 DESCRIPTION
+
+This is a C<Class::MOP::Method> subclass which is subclassed by
+C<Class::MOP::Method::Accessor> and
+C<Class::MOP::Method::Constructor>.
+
+It is not intended to be used directly.
+
+=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

database/perl/vendor/lib/Class/MOP/Method/Inlined.pm

@@ -0,0 +1,191 @@
+package Class::MOP::Method::Inlined;
+our $VERSION = '2.2014';
+
+use strict;
+use warnings;
+
+use Scalar::Util 'refaddr';
+
+use parent 'Class::MOP::Method::Generated';
+
+sub _uninlined_body {
+    my $self = shift;
+
+    my $super_method
+        = $self->associated_metaclass->find_next_method_by_name( $self->name )
+        or return;
+
+    if ( $super_method->isa(__PACKAGE__) ) {
+        return $super_method->_uninlined_body;
+    }
+    else {
+        return $super_method->body;
+    }
+}
+
+sub can_be_inlined {
+    my $self      = shift;
+    my $metaclass = $self->associated_metaclass;
+    my $class     = $metaclass->name;
+
+    # If we don't find an inherited method, this is a rather weird
+    # case where we have no method in the inheritance chain even
+    # though we're expecting one to be there
+    my $inherited_method
+        = $metaclass->find_next_method_by_name( $self->name );
+
+    if (   $inherited_method
+        && $inherited_method->isa('Class::MOP::Method::Wrapped') ) {
+        warn "Not inlining '"
+            . $self->name
+            . "' for $class since it "
+            . "has method modifiers which would be lost if it were inlined\n";
+
+        return 0;
+    }
+
+    my $expected_class = $self->_expected_method_class
+        or return 1;
+
+    # if we are shadowing a method we first verify that it is
+    # compatible with the definition we are replacing it with
+    my $expected_method = $expected_class->can( $self->name );
+
+    if ( ! $expected_method ) {
+        warn "Not inlining '"
+            . $self->name
+            . "' for $class since ${expected_class}::"
+            . $self->name
+            . " is not defined\n";
+
+        return 0;
+    }
+
+    my $actual_method = $class->can( $self->name )
+        or return 1;
+
+    # the method is what we wanted (probably Moose::Object::new)
+    return 1
+        if refaddr($expected_method) == refaddr($actual_method);
+
+    # otherwise we have to check that the actual method is an inlined
+    # version of what we're expecting
+    if ( $inherited_method->isa(__PACKAGE__) ) {
+        if ( $inherited_method->_uninlined_body
+             && refaddr( $inherited_method->_uninlined_body )
+             == refaddr($expected_method) ) {
+            return 1;
+        }
+    }
+    elsif ( refaddr( $inherited_method->body )
+            == refaddr($expected_method) ) {
+        return 1;
+    }
+
+    my $warning
+        = "Not inlining '"
+        . $self->name
+        . "' for $class since it is not"
+        . " inheriting the default ${expected_class}::"
+        . $self->name . "\n";
+
+    if ( $self->isa("Class::MOP::Method::Constructor") ) {
+
+        # FIXME kludge, refactor warning generation to a method
+        $warning
+            .= "If you are certain you don't need to inline your"
+            . " constructor, specify inline_constructor => 0 in your"
+            . " call to $class->meta->make_immutable\n";
+    }
+
+    warn $warning;
+
+    return 0;
+}
+
+1;
+
+# ABSTRACT: Method base class for methods which have been inlined
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Method::Inlined - Method base class for methods which have been inlined
+
+=head1 VERSION
+
+version 2.2014
+
+=head1 DESCRIPTION
+
+This is a L<Class::MOP::Method::Generated> subclass for methods which
+can be inlined.
+
+=head1 METHODS
+
+=head2 $metamethod->can_be_inlined
+
+This method returns true if the method in question can be inlined in
+the associated metaclass.
+
+If it cannot be inlined, it spits out a warning and returns false.
+
+=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

database/perl/vendor/lib/Class/MOP/Method/Meta.pm

@@ -0,0 +1,169 @@
+package Class::MOP::Method::Meta;
+our $VERSION = '2.2014';
+
+use strict;
+use warnings;
+
+use Carp         'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+use constant DEBUG_NO_META => $ENV{DEBUG_NO_META} ? 1 : 0;
+
+use parent 'Class::MOP::Method';
+
+sub _is_caller_mop_internal {
+    my $self = shift;
+    my ($caller) = @_;
+    return $caller =~ /^(?:Class::MOP|metaclass)(?:::|$)/;
+}
+
+sub _generate_meta_method {
+    my $method_self = shift;
+    my $metaclass   = shift;
+    weaken($metaclass);
+
+    sub {
+        # this will be compiled out if the env var wasn't set
+        if (DEBUG_NO_META) {
+            confess "'meta' method called by MOP internals"
+                # it's okay to call meta methods on metaclasses, since we
+                # explicitly ask for them
+                if !$_[0]->isa('Class::MOP::Object')
+                && !$_[0]->isa('Class::MOP::Mixin')
+                # it's okay if the test itself calls ->meta, we only care about
+                # if the mop internals call ->meta
+                && $method_self->_is_caller_mop_internal(scalar caller);
+        }
+        # we must re-initialize so that it
+        # works as expected in subclasses,
+        # since metaclass instances are
+        # singletons, this is not really a
+        # big deal anyway.
+        $metaclass->initialize(blessed($_[0]) || $_[0])
+    };
+}
+
+sub wrap {
+    my ($class, @args) = @_;
+
+    unshift @args, 'body' if @args % 2 == 1;
+    my %params = @args;
+    $class->_throw_exception( CannotOverrideBodyOfMetaMethods => params => \%params,
+                                                                     class  => $class
+                                )
+        if $params{body};
+
+    my $metaclass_class = $params{associated_metaclass}->meta;
+    $params{body} = $class->_generate_meta_method($metaclass_class);
+    return $class->SUPER::wrap(%params);
+}
+
+sub _make_compatible_with {
+    my $self = shift;
+    my ($other) = @_;
+
+    # XXX: this is pretty gross. the issue here is that CMOP::Method::Meta
+    # objects are subclasses of CMOP::Method, but when we get to moose, they'll
+    # need to be compatible with Moose::Meta::Method, which isn't possible. the
+    # right solution here is to make ::Meta into a role that gets applied to
+    # whatever the method_metaclass happens to be and get rid of
+    # _meta_method_metaclass entirely, but that's not going to happen until
+    # we ditch cmop and get roles into the bootstrapping, so. i'm not
+    # maintaining the previous behavior of turning them into instances of the
+    # new method_metaclass because that's equally broken, and at least this way
+    # any issues will at least be detectable and potentially fixable. -doy
+    return $self unless $other->_is_compatible_with($self->_real_ref_name);
+
+    return $self->SUPER::_make_compatible_with(@_);
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for C<meta> methods
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Method::Meta - Method Meta Object for C<meta> methods
+
+=head1 VERSION
+
+version 2.2014
+
+=head1 DESCRIPTION
+
+This is a L<Class::MOP::Method> subclass which represents C<meta>
+methods installed into classes by Class::MOP.
+
+=head1 METHODS
+
+=over 4
+
+=item B<< Class::MOP::Method::Wrapped->wrap($metamethod, %options) >>
+
+This is the constructor. It accepts a L<Class::MOP::Method> object and
+a hash of options. The options accepted are identical to the ones
+accepted by L<Class::MOP::Method>, except that C<body> cannot be passed
+(it will be generated automatically).
+
+=back
+
+=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

database/perl/vendor/lib/Class/MOP/Method/Wrapped.pm

@@ -0,0 +1,331 @@
+package Class::MOP::Method::Wrapped;
+our $VERSION = '2.2014';
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed';
+use Sub::Name 'subname';
+
+use parent 'Class::MOP::Method';
+
+# NOTE:
+# this ugly beast is the result of trying
+# to micro optimize this as much as possible
+# while not completely loosing maintainability.
+# At this point it's "fast enough", after all
+# you can't get something for nothing :)
+my $_build_wrapped_method = sub {
+    my $modifier_table = shift;
+    my ($before, $after, $around) = (
+        $modifier_table->{before},
+        $modifier_table->{after},
+        $modifier_table->{around},
+    );
+    if (@$before && @$after) {
+        $modifier_table->{cache} = sub {
+            for my $c (@$before) { $c->(@_) };
+            my @rval;
+            ((defined wantarray) ?
+                ((wantarray) ?
+                    (@rval = $around->{cache}->(@_))
+                    :
+                    ($rval[0] = $around->{cache}->(@_)))
+                :
+                $around->{cache}->(@_));
+            for my $c (@$after) { $c->(@_) };
+            return unless defined wantarray;
+            return wantarray ? @rval : $rval[0];
+        }
+    }
+    elsif (@$before) {
+        $modifier_table->{cache} = sub {
+            for my $c (@$before) { $c->(@_) };
+            return $around->{cache}->(@_);
+        }
+    }
+    elsif (@$after) {
+        $modifier_table->{cache} = sub {
+            my @rval;
+            ((defined wantarray) ?
+                ((wantarray) ?
+                    (@rval = $around->{cache}->(@_))
+                    :
+                    ($rval[0] = $around->{cache}->(@_)))
+                :
+                $around->{cache}->(@_));
+            for my $c (@$after) { $c->(@_) };
+            return unless defined wantarray;
+            return wantarray ? @rval : $rval[0];
+        }
+    }
+    else {
+        $modifier_table->{cache} = $around->{cache};
+    }
+};
+
+sub wrap {
+    my ( $class, $code, %params ) = @_;
+
+    (blessed($code) && $code->isa('Class::MOP::Method'))
+        || $class->_throw_exception( CanOnlyWrapBlessedCode => params => \%params,
+                                                      class  => $class,
+                                                      code   => $code
+                          );
+
+    my $modifier_table = {
+        cache  => undef,
+        orig   => $code->body,
+        before => [],
+        after  => [],
+        around => {
+            cache   => $code->body,
+            methods => [],
+        },
+    };
+    $_build_wrapped_method->($modifier_table);
+
+    # get these from the original unless explicitly overridden
+    my $pkg_name    = $params{package_name} || $code->package_name;
+    my $method_name = $params{name}         || $code->name;
+
+    return $class->SUPER::wrap(
+        sub {
+            my $wrapped = subname "${pkg_name}::_wrapped_${method_name}" => $modifier_table->{cache};
+            return $wrapped->(@_) ;
+        },
+        package_name    => $pkg_name,
+        name            => $method_name,
+        original_method => $code,
+        modifier_table  => $modifier_table,
+    );
+}
+
+sub _new {
+    my $class = shift;
+    return Class::MOP::Class->initialize($class)->new_object(@_)
+        if $class ne __PACKAGE__;
+
+    my $params = @_ == 1 ? $_[0] : {@_};
+
+    return bless {
+        # inherited from Class::MOP::Method
+        'body'                 => $params->{body},
+        'associated_metaclass' => $params->{associated_metaclass},
+        'package_name'         => $params->{package_name},
+        'name'                 => $params->{name},
+        'original_method'      => $params->{original_method},
+
+        # defined in this class
+        'modifier_table'       => $params->{modifier_table}
+    } => $class;
+}
+
+sub get_original_method {
+    my $code = shift;
+    $code->original_method;
+}
+
+sub add_before_modifier {
+    my $code     = shift;
+    my $modifier = shift;
+    unshift @{$code->{'modifier_table'}->{before}} => $modifier;
+    $_build_wrapped_method->($code->{'modifier_table'});
+}
+
+sub before_modifiers {
+    my $code = shift;
+    return @{$code->{'modifier_table'}->{before}};
+}
+
+sub add_after_modifier {
+    my $code     = shift;
+    my $modifier = shift;
+    push @{$code->{'modifier_table'}->{after}} => $modifier;
+    $_build_wrapped_method->($code->{'modifier_table'});
+}
+
+sub after_modifiers {
+    my $code = shift;
+    return @{$code->{'modifier_table'}->{after}};
+}
+
+{
+    # NOTE:
+    # this is another possible candidate for
+    # optimization as well. There is an overhead
+    # associated with the currying that, if
+    # eliminated might make around modifiers
+    # more manageable.
+    my $compile_around_method = sub {{
+        my $f1 = pop;
+        return $f1 unless @_;
+        my $f2 = pop;
+        push @_, sub { $f2->( $f1, @_ ) };
+        redo;
+    }};
+
+    sub add_around_modifier {
+        my $code     = shift;
+        my $modifier = shift;
+        unshift @{$code->{'modifier_table'}->{around}->{methods}} => $modifier;
+        $code->{'modifier_table'}->{around}->{cache} = $compile_around_method->(
+            @{$code->{'modifier_table'}->{around}->{methods}},
+            $code->{'modifier_table'}->{orig}
+        );
+        $_build_wrapped_method->($code->{'modifier_table'});
+    }
+}
+
+sub around_modifiers {
+    my $code = shift;
+    return @{$code->{'modifier_table'}->{around}->{methods}};
+}
+
+sub _make_compatible_with {
+    my $self = shift;
+    my ($other) = @_;
+
+    # XXX: this is pretty gross. the issue here is that CMOP::Method::Wrapped
+    # objects are subclasses of CMOP::Method, but when we get to moose, they'll
+    # need to be compatible with Moose::Meta::Method, which isn't possible. the
+    # right solution here is to make ::Wrapped into a role that gets applied to
+    # whatever the method_metaclass happens to be and get rid of
+    # wrapped_method_metaclass entirely, but that's not going to happen until
+    # we ditch cmop and get roles into the bootstrapping, so. i'm not
+    # maintaining the previous behavior of turning them into instances of the
+    # new method_metaclass because that's equally broken, and at least this way
+    # any issues will at least be detectable and potentially fixable. -doy
+    return $self unless $other->_is_compatible_with($self->_real_ref_name);
+
+    return $self->SUPER::_make_compatible_with(@_);
+}
+
+1;
+
+# ABSTRACT: Method Meta Object for methods with before/after/around modifiers
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::MOP::Method::Wrapped - Method Meta Object for methods with before/after/around modifiers
+
+=head1 VERSION
+
+version 2.2014
+
+=head1 DESCRIPTION
+
+This is a L<Class::MOP::Method> subclass which implements before,
+after, and around method modifiers.
+
+=head1 METHODS
+
+=head2 Class::MOP::Method::Wrapped->wrap($metamethod, %options)
+
+This is the constructor. It accepts a L<Class::MOP::Method> object and
+a hash of options.
+
+The options are:
+
+=over 4
+
+=item * name
+
+The method name (without a package name). This will be taken from the
+provided L<Class::MOP::Method> object if it is not provided.
+
+=item * package_name
+
+The package name for the method. This will be taken from the provided
+L<Class::MOP::Method> object if it is not provided.
+
+=item * associated_metaclass
+
+An optional L<Class::MOP::Class> object. This is the metaclass for the
+method's class.
+
+=back
+
+=head2 $metamethod->get_original_method
+
+This returns the L<Class::MOP::Method> object that was passed to the
+constructor.
+
+=head2 $metamethod->add_before_modifier($code)
+
+=head2 $metamethod->add_after_modifier($code)
+
+=head2 $metamethod->add_around_modifier($code)
+
+These methods all take a subroutine reference and apply it as a
+modifier to the original method.
+
+=head2 $metamethod->before_modifiers
+
+=head2 $metamethod->after_modifiers
+
+=head2 $metamethod->around_modifiers
+
+These methods all return a list of subroutine references which are
+acting as the specified type of modifier.
+
+=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