Initial Commit

database/perl/vendor/lib/MooseX/NonMoose/Meta/Role/Class.pm

@@ -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

database/perl/vendor/lib/MooseX/NonMoose/Meta/Role/Constructor.pm

@@ -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