Initial Commit

database/perl/vendor/lib/Method/Generate/Accessor.pm

@@ -0,0 +1,697 @@
+package Method::Generate::Accessor;
+
+use Moo::_strictures;
+use Moo::_Utils qw(_load_module _maybe_load_module _install_coderef _module_name_rx);
+use Moo::Object ();
+BEGIN { our @ISA = qw(Moo::Object) }
+use Sub::Quote qw(quote_sub quoted_from_sub quotify sanitize_identifier);
+use Scalar::Util 'blessed';
+use Carp qw(croak);
+BEGIN { our @CARP_NOT = qw(Moo::_Utils) }
+BEGIN {
+  *_CAN_WEAKEN_READONLY = (
+    "$]" < 5.008_003 or $ENV{MOO_TEST_PRE_583}
+  ) ? sub(){0} : sub(){1};
+  our $CAN_HAZ_XS =
+    !$ENV{MOO_XS_DISABLE}
+      &&
+    _maybe_load_module('Class::XSAccessor')
+      &&
+    (eval { Class::XSAccessor->VERSION('1.07') })
+  ;
+  our $CAN_HAZ_XS_PRED =
+    $CAN_HAZ_XS &&
+    (eval { Class::XSAccessor->VERSION('1.17') })
+  ;
+}
+BEGIN {
+  package
+    Method::Generate::Accessor::_Generated;
+  $Carp::Internal{+__PACKAGE__} = 1;
+}
+
+sub _die_overwrite {
+  my ($pkg, $method, $type) = @_;
+  croak "You cannot overwrite a locally defined method ($method) with "
+    . ( $type || 'an accessor' );
+}
+
+sub generate_method {
+  my ($self, $into, $name, $spec, $quote_opts) = @_;
+  $quote_opts = {
+    no_defer => 1,
+    package => 'Method::Generate::Accessor::_Generated',
+    %{ $quote_opts||{} },
+  };
+  $spec->{allow_overwrite}++ if $name =~ s/^\+//;
+  croak "Must have an is" unless my $is = $spec->{is};
+  if ($is eq 'ro') {
+    $spec->{reader} = $name unless exists $spec->{reader};
+  } elsif ($is eq 'rw') {
+    $spec->{accessor} = $name unless exists $spec->{accessor}
+      or ( $spec->{reader} and $spec->{writer} );
+  } elsif ($is eq 'lazy') {
+    $spec->{reader} = $name unless exists $spec->{reader};
+    $spec->{lazy} = 1;
+    $spec->{builder} ||= '_build_'.$name unless exists $spec->{default};
+  } elsif ($is eq 'rwp') {
+    $spec->{reader} = $name unless exists $spec->{reader};
+    $spec->{writer} = "_set_${name}" unless exists $spec->{writer};
+  } elsif ($is ne 'bare') {
+    croak "Unknown is ${is}";
+  }
+  if (exists $spec->{builder}) {
+    if(ref $spec->{builder}) {
+      $self->_validate_codulatable('builder', $spec->{builder},
+        "$into->$name", 'or a method name');
+      $spec->{builder_sub} = $spec->{builder};
+      $spec->{builder} = 1;
+    }
+    $spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
+    croak "Invalid builder for $into->$name - not a valid method name"
+      if $spec->{builder} !~ _module_name_rx;
+  }
+  if (($spec->{predicate}||0) eq 1) {
+    $spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
+  }
+  if (($spec->{clearer}||0) eq 1) {
+    $spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}";
+  }
+  if (($spec->{trigger}||0) eq 1) {
+    $spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
+  }
+  if (($spec->{coerce}||0) eq 1) {
+    my $isa = $spec->{isa};
+    if (blessed $isa and $isa->can('coercion')) {
+      $spec->{coerce} = $isa->coercion;
+    } elsif (blessed $isa and $isa->can('coerce')) {
+      $spec->{coerce} = sub { $isa->coerce(@_) };
+    } else {
+      croak "Invalid coercion for $into->$name - no appropriate type constraint";
+    }
+  }
+
+  foreach my $setting (qw( isa coerce )) {
+    next if !exists $spec->{$setting};
+    $self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name");
+  }
+
+  if (exists $spec->{default}) {
+    if (ref $spec->{default}) {
+      $self->_validate_codulatable('default', $spec->{default}, "$into->$name",
+        'or a non-ref');
+    }
+  }
+
+  if (exists $spec->{moosify}) {
+    if (ref $spec->{moosify} ne 'ARRAY') {
+      $spec->{moosify} = [$spec->{moosify}];
+    }
+
+    foreach my $spec (@{$spec->{moosify}}) {
+      $self->_validate_codulatable('moosify', $spec, "$into->$name");
+    }
+  }
+
+  my %methods;
+  if (my $reader = $spec->{reader}) {
+    _die_overwrite($into, $reader, 'a reader')
+      if !$spec->{allow_overwrite} && defined &{"${into}::${reader}"};
+    if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
+      $methods{$reader} = $self->_generate_xs(
+        getters => $into, $reader, $name, $spec
+      );
+    } else {
+      $self->{captures} = {};
+      $methods{$reader} =
+        quote_sub "${into}::${reader}"
+          => '    Carp::croak("'.$reader.' is a read-only accessor") if @_ > 1;'."\n"
+             .$self->_generate_get($name, $spec)
+          => delete $self->{captures}
+          => $quote_opts
+        ;
+    }
+  }
+  if (my $accessor = $spec->{accessor}) {
+    _die_overwrite($into, $accessor, 'an accessor')
+      if !$spec->{allow_overwrite} && defined &{"${into}::${accessor}"};
+    if (
+      our $CAN_HAZ_XS
+      && $self->is_simple_get($name, $spec)
+      && $self->is_simple_set($name, $spec)
+    ) {
+      $methods{$accessor} = $self->_generate_xs(
+        accessors => $into, $accessor, $name, $spec
+      );
+    } else {
+      $self->{captures} = {};
+      $methods{$accessor} =
+        quote_sub "${into}::${accessor}"
+          => $self->_generate_getset($name, $spec)
+          => delete $self->{captures}
+          => $quote_opts
+        ;
+    }
+  }
+  if (my $writer = $spec->{writer}) {
+    _die_overwrite($into, $writer, 'a writer')
+      if !$spec->{allow_overwrite} && defined &{"${into}::${writer}"};
+    if (
+      our $CAN_HAZ_XS
+      && $self->is_simple_set($name, $spec)
+    ) {
+      $methods{$writer} = $self->_generate_xs(
+        setters => $into, $writer, $name, $spec
+      );
+    } else {
+      $self->{captures} = {};
+      $methods{$writer} =
+        quote_sub "${into}::${writer}"
+          => $self->_generate_set($name, $spec)
+          => delete $self->{captures}
+          => $quote_opts
+        ;
+    }
+  }
+  if (my $pred = $spec->{predicate}) {
+    _die_overwrite($into, $pred, 'a predicate')
+      if !$spec->{allow_overwrite} && defined &{"${into}::${pred}"};
+    if (our $CAN_HAZ_XS && our $CAN_HAZ_XS_PRED) {
+      $methods{$pred} = $self->_generate_xs(
+        exists_predicates => $into, $pred, $name, $spec
+      );
+    } else {
+      $self->{captures} = {};
+      $methods{$pred} =
+        quote_sub "${into}::${pred}"
+          => $self->_generate_simple_has('$_[0]', $name, $spec)."\n"
+          => delete $self->{captures}
+          => $quote_opts
+        ;
+    }
+  }
+  if (my $builder = delete $spec->{builder_sub}) {
+    _install_coderef( "${into}::$spec->{builder}" => $builder );
+  }
+  if (my $cl = $spec->{clearer}) {
+    _die_overwrite($into, $cl, 'a clearer')
+      if !$spec->{allow_overwrite} && defined &{"${into}::${cl}"};
+    $self->{captures} = {};
+    $methods{$cl} =
+      quote_sub "${into}::${cl}"
+        => $self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
+        => delete $self->{captures}
+        => $quote_opts
+      ;
+  }
+  if (my $hspec = $spec->{handles}) {
+    my $asserter = $spec->{asserter} ||= '_assert_'.$name;
+    my @specs = do {
+      if (ref($hspec) eq 'ARRAY') {
+        map [ $_ => $_ ], @$hspec;
+      } elsif (ref($hspec) eq 'HASH') {
+        map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
+          keys %$hspec;
+      } elsif (!ref($hspec)) {
+        require Moo::Role;
+        _load_module $hspec;
+        map [ $_ => $_ ], Moo::Role->methods_provided_by($hspec)
+      } else {
+        croak "You gave me a handles of ${hspec} and I have no idea why";
+      }
+    };
+    foreach my $delegation_spec (@specs) {
+      my ($proxy, $target, @args) = @$delegation_spec;
+      _die_overwrite($into, $proxy, 'a delegation')
+        if !$spec->{allow_overwrite} && defined &{"${into}::${proxy}"};
+      $self->{captures} = {};
+      $methods{$proxy} =
+        quote_sub "${into}::${proxy}"
+          => $self->_generate_delegation($asserter, $target, \@args)
+          => delete $self->{captures}
+          => $quote_opts
+        ;
+    }
+  }
+  if (my $asserter = $spec->{asserter}) {
+    _die_overwrite($into, $asserter, 'an asserter')
+      if !$spec->{allow_overwrite} && defined &{"${into}::${asserter}"};
+    local $self->{captures} = {};
+    $methods{$asserter} =
+      quote_sub "${into}::${asserter}"
+        => $self->_generate_asserter($name, $spec)
+        => delete $self->{captures}
+        => $quote_opts
+      ;
+  }
+  \%methods;
+}
+
+sub merge_specs {
+  my ($self, @specs) = @_;
+  my $spec = shift @specs;
+  for my $old_spec (@specs) {
+    foreach my $key (keys %$old_spec) {
+      if ($key eq 'handles') {
+      }
+      elsif ($key eq 'moosify') {
+        $spec->{$key} = [
+          map { ref $_ eq 'ARRAY' ? @$_ : $_ }
+          grep defined,
+          ($old_spec->{$key}, $spec->{$key})
+        ];
+      }
+      elsif ($key eq 'builder' || $key eq 'default') {
+        $spec->{$key} = $old_spec->{$key}
+          if !(exists $spec->{builder} || exists $spec->{default});
+      }
+      elsif (!exists $spec->{$key}) {
+        $spec->{$key} = $old_spec->{$key};
+      }
+    }
+  }
+  $spec;
+}
+
+sub is_simple_attribute {
+  my ($self, $name, $spec) = @_;
+  # clearer doesn't have to be listed because it doesn't
+  # affect whether defined/exists makes a difference
+  !grep $spec->{$_},
+    qw(lazy default builder coerce isa trigger predicate weak_ref);
+}
+
+sub is_simple_get {
+  my ($self, $name, $spec) = @_;
+  !($spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
+}
+
+sub is_simple_set {
+  my ($self, $name, $spec) = @_;
+  !grep $spec->{$_}, qw(coerce isa trigger weak_ref);
+}
+
+sub has_default {
+  my ($self, $name, $spec) = @_;
+  $spec->{builder} or exists $spec->{default} or (($spec->{is}||'') eq 'lazy');
+}
+
+sub has_eager_default {
+  my ($self, $name, $spec) = @_;
+  (!$spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
+}
+
+sub _generate_get {
+  my ($self, $name, $spec) = @_;
+  my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
+  if ($self->is_simple_get($name, $spec)) {
+    $simple;
+  } else {
+    $self->_generate_use_default(
+      '$_[0]', $name, $spec,
+      $self->_generate_simple_has('$_[0]', $name, $spec),
+    );
+  }
+}
+
+sub generate_simple_has {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_simple_has(@_);
+  ($code, delete $self->{captures});
+}
+
+sub _generate_simple_has {
+  my ($self, $me, $name) = @_;
+  "exists ${me}->{${\quotify $name}}";
+}
+
+sub _generate_simple_clear {
+  my ($self, $me, $name) = @_;
+  "    delete ${me}->{${\quotify $name}}\n"
+}
+
+sub generate_get_default {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_get_default(@_);
+  ($code, delete $self->{captures});
+}
+
+sub generate_use_default {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_use_default(@_);
+  ($code, delete $self->{captures});
+}
+
+sub _generate_use_default {
+  my ($self, $me, $name, $spec, $test) = @_;
+  my $get_value = $self->_generate_get_default($me, $name, $spec);
+  if ($spec->{coerce}) {
+    $get_value = $self->_generate_coerce(
+      $name, $get_value,
+      $spec->{coerce}
+    )
+  }
+  $test." ? \n"
+  .$self->_generate_simple_get($me, $name, $spec)."\n:"
+  .($spec->{isa} ?
+       "    do {\n      my \$value = ".$get_value.";\n"
+      ."      ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n"
+      ."      ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n"
+      ."    }\n"
+    : '    ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n"
+  );
+}
+
+sub _generate_get_default {
+  my ($self, $me, $name, $spec) = @_;
+  if (exists $spec->{default}) {
+    ref $spec->{default}
+      ? $self->_generate_call_code($name, 'default', $me, $spec->{default})
+    : quotify $spec->{default};
+  }
+  else {
+    "${me}->${\$spec->{builder}}"
+  }
+}
+
+sub generate_simple_get {
+  my ($self, @args) = @_;
+  $self->{captures} = {};
+  my $code = $self->_generate_simple_get(@args);
+  ($code, delete $self->{captures});
+}
+
+sub _generate_simple_get {
+  my ($self, $me, $name) = @_;
+  my $name_str = quotify $name;
+  "${me}->{${name_str}}";
+}
+
+sub _generate_set {
+  my ($self, $name, $spec) = @_;
+  my ($me, $source) = ('$_[0]', '$_[1]');
+  if ($self->is_simple_set($name, $spec)) {
+    return $self->_generate_simple_set($me, $name, $spec, $source);
+  }
+
+  my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
+  if ($coerce) {
+    $source = $self->_generate_coerce($name, $source, $coerce);
+  }
+  if ($isa_check) {
+    'scalar do { my $value = '.$source.";\n"
+    .'  ('.$self->_generate_isa_check($name, '$value', $isa_check)."),\n"
+    .'  ('.$self->_generate_simple_set($me, $name, $spec, '$value')."),\n"
+    .($trigger
+      ? '('.$self->_generate_trigger($name, $me, '$value', $trigger)."),\n"
+      : '')
+    .'  ('.$self->_generate_simple_get($me, $name, $spec)."),\n"
+    ."}";
+  }
+  elsif ($trigger) {
+    my $set = $self->_generate_simple_set($me, $name, $spec, $source);
+    "scalar (\n"
+    . '  ('.$self->_generate_trigger($name, $me, "($set)", $trigger)."),\n"
+    . '  ('.$self->_generate_simple_get($me, $name, $spec)."),\n"
+    . ")";
+  }
+  else {
+    '('.$self->_generate_simple_set($me, $name, $spec, $source).')';
+  }
+}
+
+sub generate_coerce {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_coerce(@_);
+  ($code, delete $self->{captures});
+}
+
+sub _attr_desc {
+  my ($name, $init_arg) = @_;
+  return quotify($name) if !defined($init_arg) or $init_arg eq $name;
+  return quotify($name).' (constructor argument: '.quotify($init_arg).')';
+}
+
+sub _generate_coerce {
+  my ($self, $name, $value, $coerce, $init_arg) = @_;
+  $self->_wrap_attr_exception(
+    $name,
+    "coercion",
+    $init_arg,
+    $self->_generate_call_code($name, 'coerce', "${value}", $coerce),
+    1,
+  );
+}
+
+sub generate_trigger {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_trigger(@_);
+  ($code, delete $self->{captures});
+}
+
+sub _generate_trigger {
+  my ($self, $name, $obj, $value, $trigger) = @_;
+  $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
+}
+
+sub generate_isa_check {
+  my ($self, @args) = @_;
+  $self->{captures} = {};
+  my $code = $self->_generate_isa_check(@args);
+  ($code, delete $self->{captures});
+}
+
+sub _wrap_attr_exception {
+  my ($self, $name, $step, $arg, $code, $want_return) = @_;
+  my $prefix = quotify("${step} for "._attr_desc($name, $arg).' failed: ');
+  "do {\n"
+  .'  local $Method::Generate::Accessor::CurrentAttribute = {'."\n"
+  .'    init_arg => '.quotify($arg).",\n"
+  .'    name     => '.quotify($name).",\n"
+  .'    step     => '.quotify($step).",\n"
+  ."  };\n"
+  .($want_return ? '  (my $_return),'."\n" : '')
+  .'  (my $_error), (my $_old_error = $@);'."\n"
+  ."  (eval {\n"
+  .'    ($@ = $_old_error),'."\n"
+  .'    ('
+  .($want_return ? '$_return ='."\n" : '')
+  .$code."),\n"
+  ."    1\n"
+  ."  } or\n"
+  .'    $_error = CORE::ref $@ ? $@ : '.$prefix.'.$@);'."\n"
+  .'  ($@ = $_old_error),'."\n"
+  .'  (defined $_error and CORE::die $_error);'."\n"
+  .($want_return ? '  $_return;'."\n" : '')
+  ."}\n"
+}
+
+sub _generate_isa_check {
+  my ($self, $name, $value, $check, $init_arg) = @_;
+  $self->_wrap_attr_exception(
+    $name,
+    "isa check",
+    $init_arg,
+    $self->_generate_call_code($name, 'isa_check', $value, $check)
+  );
+}
+
+sub _generate_call_code {
+  my ($self, $name, $type, $values, $sub) = @_;
+  $sub = \&{$sub} if blessed($sub);  # coderef if blessed
+  if (my $quoted = quoted_from_sub($sub)) {
+    my $local = 1;
+    if ($values eq '@_' || $values eq '$_[0]') {
+      $local = 0;
+      $values = '@_';
+    }
+    my $code = $quoted->[1];
+    if (my $captures = $quoted->[2]) {
+      my $cap_name = qq{\$${type}_captures_for_}.sanitize_identifier($name);
+      $self->{captures}->{$cap_name} = \$captures;
+      Sub::Quote::inlinify($code, $values,
+        Sub::Quote::capture_unroll($cap_name, $captures, 6), $local);
+    } else {
+      Sub::Quote::inlinify($code, $values, undef, $local);
+    }
+  } else {
+    my $cap_name = qq{\$${type}_for_}.sanitize_identifier($name);
+    $self->{captures}->{$cap_name} = \$sub;
+    "${cap_name}->(${values})";
+  }
+}
+
+sub _sanitize_name { sanitize_identifier($_[1]) }
+
+sub generate_populate_set {
+  my $self = shift;
+  $self->{captures} = {};
+  my $code = $self->_generate_populate_set(@_);
+  ($code, delete $self->{captures});
+}
+
+sub _generate_populate_set {
+  my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_;
+
+  my $has_default = $self->has_eager_default($name, $spec);
+  if (!($has_default || $test)) {
+    return '';
+  }
+  if ($has_default) {
+    my $get_default = $self->_generate_get_default($me, $name, $spec);
+    $source =
+      $test
+        ? "(\n  ${test}\n"
+            ."   ? ${source}\n   : "
+            .$get_default
+            .")"
+        : $get_default;
+  }
+  if ($spec->{coerce}) {
+    $source = $self->_generate_coerce(
+      $name, $source,
+      $spec->{coerce}, $init_arg
+    )
+  }
+  if ($spec->{isa}) {
+    $source = 'scalar do { my $value = '.$source.";\n"
+    .'  ('.$self->_generate_isa_check(
+        $name, '$value', $spec->{isa}, $init_arg
+      )."),\n"
+    ."  \$value\n"
+    ."}\n";
+  }
+  my $set = $self->_generate_simple_set($me, $name, $spec, $source);
+  my $trigger = $spec->{trigger} ? $self->_generate_trigger(
+    $name, $me, $self->_generate_simple_get($me, $name, $spec),
+    $spec->{trigger}
+  ) : undef;
+  if ($has_default) {
+    "($set)," . ($trigger && $test ? "($test and $trigger)," : '') . "\n";
+  }
+  else {
+    "($test and ($set)" . ($trigger ? ", ($trigger)" : '') . "),\n";
+  }
+}
+
+sub _generate_core_set {
+  my ($self, $me, $name, $spec, $value) = @_;
+  my $name_str = quotify $name;
+  "${me}->{${name_str}} = ${value}";
+}
+
+sub _generate_simple_set {
+  my ($self, $me, $name, $spec, $value) = @_;
+  my $name_str = quotify $name;
+  my $simple = $self->_generate_core_set($me, $name, $spec, $value);
+
+  if ($spec->{weak_ref}) {
+    require Scalar::Util;
+    my $get = $self->_generate_simple_get($me, $name, $spec);
+
+    # Perl < 5.8.3 can't weaken refs to readonly vars
+    # (e.g. string constants). This *can* be solved by:
+    #
+    # &Internals::SvREADONLY($foo, 0);
+    # Scalar::Util::weaken($foo);
+    # &Internals::SvREADONLY($foo, 1);
+    #
+    # but requires Internal functions and is just too damn crazy
+    # so simply throw a better exception
+    my $weak_simple = _CAN_WEAKEN_READONLY
+      ? "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }"
+      : <<"EOC"
+        ( eval { Scalar::Util::weaken($simple); 1 }
+          ? do { no warnings 'void'; $get }
+          : do {
+            if( \$@ =~ /Modification of a read-only value attempted/) {
+              require Carp;
+              Carp::croak( sprintf (
+                'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
+                $name_str,
+              ) );
+            } else {
+              die \$@;
+            }
+          }
+        )
+EOC
+  } else {
+    $simple;
+  }
+}
+
+sub _generate_getset {
+  my ($self, $name, $spec) = @_;
+  q{(@_ > 1}."\n      ? ".$self->_generate_set($name, $spec)
+    ."\n      : ".$self->_generate_get($name, $spec)."\n    )";
+}
+
+sub _generate_asserter {
+  my ($self, $name, $spec) = @_;
+  my $name_str = quotify($name);
+  "do {\n"
+   ."  my \$val = ".$self->_generate_get($name, $spec).";\n"
+   ."  ".$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
+   ."    or Carp::croak(q{Attempted to access '}.${name_str}.q{' but it is not set});\n"
+   ."  \$val;\n"
+   ."}\n";
+}
+sub _generate_delegation {
+  my ($self, $asserter, $target, $args) = @_;
+  my $arg_string = do {
+    if (@$args) {
+      # I could, I reckon, linearise out non-refs here using quotify
+      # plus something to check for numbers but I'm unsure if it's worth it
+      $self->{captures}{'@curries'} = $args;
+      '@curries, @_';
+    } else {
+      '@_';
+    }
+  };
+  "shift->${asserter}->${target}(${arg_string});";
+}
+
+sub _generate_xs {
+  my ($self, $type, $into, $name, $slot) = @_;
+  Class::XSAccessor->import(
+    class => $into,
+    $type => { $name => $slot },
+    replace => 1,
+  );
+  $into->can($name);
+}
+
+sub default_construction_string { '{}' }
+
+sub _validate_codulatable {
+  my ($self, $setting, $value, $into, $appended) = @_;
+
+  my $error;
+
+  if (blessed $value) {
+    local $@;
+    no warnings 'void';
+    eval { \&$value; 1 }
+      and return 1;
+    $error = "could not be converted to a coderef: $@";
+  }
+  elsif (ref $value eq 'CODE') {
+    return 1;
+  }
+  else {
+    $error = 'is not a coderef or code-convertible object';
+  }
+
+  croak "Invalid $setting '"
+    . ($INC{'overload.pm'} ? overload::StrVal($value) : $value)
+    . "' for $into " . $error
+    . ($appended ? " $appended" : '');
+}
+
+1;

database/perl/vendor/lib/Method/Generate/BuildAll.pm

@@ -0,0 +1,42 @@
+package Method::Generate::BuildAll;
+
+use Moo::_strictures;
+use Moo::Object ();
+BEGIN { our @ISA = qw(Moo::Object) }
+use Sub::Quote qw(quote_sub quotify);
+use Moo::_Utils qw(_getglob);
+use Moo::_mro;
+
+sub generate_method {
+  my ($self, $into) = @_;
+  quote_sub "${into}::BUILDALL"
+    => join('',
+      $self->_handle_subbuild($into),
+      qq{    my \$self = shift;\n},
+      $self->buildall_body_for($into, '$self', '@_'),
+      qq{    return \$self\n},
+    )
+    => {}
+    => { no_defer => 1 }
+  ;
+}
+
+sub _handle_subbuild {
+  my ($self, $into) = @_;
+  '    if (ref($_[0]) ne '.quotify($into).') {'."\n".
+  '      return shift->Moo::Object::BUILDALL(@_)'.";\n".
+  '    }'."\n";
+}
+
+sub buildall_body_for {
+  my ($self, $into, $me, $args) = @_;
+  my @builds =
+    grep *{_getglob($_)}{CODE},
+    map "${_}::BUILD",
+    reverse @{mro::get_linear_isa($into)};
+  '    (('.$args.')[0]->{__no_BUILD__} or ('."\n"
+  .join('', map qq{      ${me}->${_}(${args}),\n}, @builds)
+  ."    )),\n";
+}
+
+1;

database/perl/vendor/lib/Method/Generate/Constructor.pm

@@ -0,0 +1,266 @@
+package Method::Generate::Constructor;
+
+use Moo::_strictures;
+use Sub::Quote qw(quote_sub quotify);
+use Sub::Defer;
+use Moo::_Utils qw(_getstash _getglob);
+use Moo::_mro;
+use Scalar::Util qw(weaken);
+use Carp qw(croak);
+use Carp::Heavy ();
+BEGIN { our @CARP_NOT = qw(Sub::Defer) }
+BEGIN {
+  local $Moo::sification::disabled = 1;
+  require Moo;
+  Moo->import;
+}
+
+sub register_attribute_specs {
+  my ($self, @new_specs) = @_;
+  $self->assert_constructor;
+  my $specs = $self->{attribute_specs}||={};
+  my $ag = $self->accessor_generator;
+  while (my ($name, $new_spec) = splice @new_specs, 0, 2) {
+    if ($name =~ s/^\+//) {
+      croak "has '+${name}' given but no ${name} attribute already exists"
+        unless my $old_spec = $specs->{$name};
+      $ag->merge_specs($new_spec, $old_spec);
+    }
+    if ($new_spec->{required}
+      && !(
+        $ag->has_default($name, $new_spec)
+        || !exists $new_spec->{init_arg}
+        || defined $new_spec->{init_arg}
+      )
+    ) {
+      croak "You cannot have a required attribute (${name})"
+        . " without a default, builder, or an init_arg";
+    }
+    $new_spec->{index} = scalar keys %$specs
+      unless defined $new_spec->{index};
+    $specs->{$name} = $new_spec;
+  }
+  $self;
+}
+
+sub all_attribute_specs {
+  $_[0]->{attribute_specs}
+}
+
+sub accessor_generator {
+  $_[0]->{accessor_generator}
+}
+
+sub construction_string {
+  my ($self) = @_;
+  $self->{construction_string}
+    ||= $self->_build_construction_string;
+}
+
+sub buildall_generator {
+  require Method::Generate::BuildAll;
+  Method::Generate::BuildAll->new;
+}
+
+sub _build_construction_string {
+  my ($self) = @_;
+  my $builder = $self->{construction_builder};
+  $builder ? $self->$builder
+    : 'bless('
+    .$self->accessor_generator->default_construction_string
+    .', $class);'
+}
+
+sub install_delayed {
+  my ($self) = @_;
+  $self->assert_constructor;
+  my $package = $self->{package};
+  my (undef, @isa) = @{mro::get_linear_isa($package)};
+  my $isa = join ',', @isa;
+  my (undef, $from_file, $from_line) = caller(Carp::short_error_loc());
+  my $constructor = defer_sub "${package}::new" => sub {
+    my (undef, @new_isa) = @{mro::get_linear_isa($package)};
+    if (join(',', @new_isa) ne $isa) {
+      my ($expected_new) = grep { *{_getglob($_.'::new')}{CODE} } @isa;
+      my ($found_new) = grep { *{_getglob($_.'::new')}{CODE} } @new_isa;
+      if (($found_new||'') ne ($expected_new||'')) {
+        $found_new ||= 'none';
+        $expected_new ||= 'none';
+        croak "Expected parent constructor of $package to be"
+        . " $expected_new, but found $found_new: changing the inheritance"
+        . " chain (\@ISA) at runtime (after $from_file line $from_line) is unsupported";
+      }
+    }
+
+    my $constructor = $self->generate_method(
+      $package, 'new', $self->{attribute_specs}, { no_install => 1, no_defer => 1 }
+    );
+    $self->{inlined} = 1;
+    weaken($self->{constructor} = $constructor);
+    $constructor;
+  };
+  $self->{inlined} = 0;
+  weaken($self->{constructor} = $constructor);
+  $self;
+}
+
+sub current_constructor {
+  my ($self, $package) = @_;
+  return *{_getglob("${package}::new")}{CODE};
+}
+
+sub assert_constructor {
+  my ($self) = @_;
+  my $package = $self->{package} or return 1;
+  my $current = $self->current_constructor($package)
+    or return 1;
+  my $constructor = $self->{constructor}
+    or croak "Unknown constructor for $package already exists";
+  croak "Constructor for $package has been replaced with an unknown sub"
+    if $constructor != $current;
+  croak "Constructor for $package has been inlined and cannot be updated"
+    if $self->{inlined};
+}
+
+sub generate_method {
+  my ($self, $into, $name, $spec, $quote_opts) = @_;
+  $quote_opts = {
+    %{$quote_opts||{}},
+    package => $into,
+  };
+  foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
+    $spec->{$no_init}{init_arg} = $no_init;
+  }
+  local $self->{captures} = {};
+
+  my $into_buildargs = $into->can('BUILDARGS');
+
+  my $body
+    = '    my $invoker = CORE::shift();'."\n"
+    . '    my $class = CORE::ref($invoker) ? CORE::ref($invoker) : $invoker;'."\n"
+    . $self->_handle_subconstructor($into, $name)
+    . ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS
+      ? $self->_generate_args_via_buildargs
+      : $self->_generate_args
+    )
+    . $self->_check_required($spec)
+    . '    my $new = '.$self->construction_string.";\n"
+    . $self->_assign_new($spec)
+    . ( $into->can('BUILD')
+      ? $self->buildall_generator->buildall_body_for( $into, '$new', '$args' )
+      : ''
+    )
+    . '    return $new;'."\n";
+
+  if ($into->can('DEMOLISH')) {
+    require Method::Generate::DemolishAll;
+    Method::Generate::DemolishAll->new->generate_method($into);
+  }
+  quote_sub
+    "${into}::${name}" => $body,
+    $self->{captures}, $quote_opts||{}
+  ;
+}
+
+sub _handle_subconstructor {
+  my ($self, $into, $name) = @_;
+  if (my $gen = $self->{subconstructor_handler}) {
+    '    if ($class ne '.quotify($into).') {'."\n".
+    $gen.
+    '    }'."\n";
+  } else {
+    ''
+  }
+}
+
+sub _cap_call {
+  my ($self, $code, $captures) = @_;
+  @{$self->{captures}}{keys %$captures} = values %$captures if $captures;
+  $code;
+}
+
+sub _generate_args_via_buildargs {
+  my ($self) = @_;
+  q{    my $args = $class->BUILDARGS(@_);}."\n"
+  .q{    Carp::croak("BUILDARGS did not return a hashref") unless CORE::ref($args) eq 'HASH';}
+  ."\n";
+}
+
+# inlined from Moo::Object - update that first.
+sub _generate_args {
+  my ($self) = @_;
+  return <<'_EOA';
+    my $args = scalar @_ == 1
+      ? CORE::ref $_[0] eq 'HASH'
+        ? { %{ $_[0] } }
+        : Carp::croak("Single parameters to new() must be a HASH ref"
+            . " data => ". $_[0])
+      : @_ % 2
+        ? Carp::croak("The new() method for $class expects a hash reference or a"
+            . " key/value list. You passed an odd number of arguments")
+        : {@_}
+    ;
+_EOA
+
+}
+
+sub _assign_new {
+  my ($self, $spec) = @_;
+  my $ag = $self->accessor_generator;
+  my %test;
+  NAME: foreach my $name (sort keys %$spec) {
+    my $attr_spec = $spec->{$name};
+    next NAME unless defined($attr_spec->{init_arg})
+                       or $ag->has_eager_default($name, $attr_spec);
+    $test{$name} = $attr_spec->{init_arg};
+  }
+  join '', map {
+    my $arg = $test{$_};
+    my $arg_key = quotify($arg);
+    my $test = defined $arg ? "exists \$args->{$arg_key}" : undef;
+    my $source = defined $arg ? "\$args->{$arg_key}" : undef;
+    my $attr_spec = $spec->{$_};
+    $self->_cap_call($ag->generate_populate_set(
+      '$new', $_, $attr_spec, $source, $test, $arg,
+    ));
+  } sort keys %test;
+}
+
+sub _check_required {
+  my ($self, $spec) = @_;
+  my @required_init =
+    map $spec->{$_}{init_arg},
+      grep {
+        my $s = $spec->{$_}; # ignore required if default or builder set
+        $s->{required} and not($s->{builder} or exists $s->{default})
+      } sort keys %$spec;
+  return '' unless @required_init;
+  '    if (my @missing = grep !exists $args->{$_}, '
+    .join(', ', map quotify($_), @required_init).') {'."\n"
+    .q{      Carp::croak("Missing required arguments: ".CORE::join(', ', sort @missing));}."\n"
+    ."    }\n";
+}
+
+# bootstrap our own constructor
+sub new {
+  my $class = shift;
+  delete _getstash(__PACKAGE__)->{new};
+  bless $class->BUILDARGS(@_), $class;
+}
+Moo->_constructor_maker_for(__PACKAGE__)
+->register_attribute_specs(
+  attribute_specs => {
+    is => 'ro',
+    reader => 'all_attribute_specs',
+  },
+  accessor_generator => { is => 'ro' },
+  construction_string => { is => 'lazy' },
+  construction_builder => { is => 'bare' },
+  subconstructor_handler => { is => 'ro' },
+  package => { is => 'bare' },
+);
+if ($INC{'Moo/HandleMoose.pm'} && !$Moo::sification::disabled) {
+  Moo::HandleMoose::inject_fake_metaclass_for(__PACKAGE__);
+}
+
+1;

database/perl/vendor/lib/Method/Generate/DemolishAll.pm

@@ -0,0 +1,65 @@
+package Method::Generate::DemolishAll;
+
+use Moo::_strictures;
+use Moo::Object ();
+BEGIN { our @ISA = qw(Moo::Object) }
+use Sub::Quote qw(quote_sub quotify);
+use Moo::_Utils qw(_getglob);
+use Moo::_mro;
+BEGIN {
+  *_USE_DGD = "$]" < 5.014 ? sub(){1} : sub(){0};
+  require Devel::GlobalDestruction
+    if _USE_DGD();
+}
+
+sub generate_method {
+  my ($self, $into) = @_;
+  quote_sub "${into}::DEMOLISHALL", join '',
+    $self->_handle_subdemolish($into),
+    qq{    my \$self = shift;\n},
+    $self->demolishall_body_for($into, '$self', '@_'),
+    qq{    return \$self\n};
+  quote_sub "${into}::DESTROY", join '',
+    q!    my $self = shift;
+    my $e = do {
+      local $?;
+      local $@;!.(_USE_DGD ? q!
+      require Devel::GlobalDestruction;! : '').q!
+      package !.$into.q!;
+      eval {
+        $self->DEMOLISHALL(!.(
+          _USE_DGD
+            ? 'Devel::GlobalDestruction::in_global_destruction()'
+            : q[${^GLOBAL_PHASE} eq 'DESTRUCT']
+        ).q!);
+      };
+      $@;
+    };
+
+    # fatal warnings+die in DESTROY = bad times (perl rt#123398)
+    no warnings FATAL => 'all';
+    use warnings 'all';
+    die $e if $e; # rethrow
+  !;
+}
+
+sub demolishall_body_for {
+  my ($self, $into, $me, $args) = @_;
+  my @demolishers =
+    grep *{_getglob($_)}{CODE},
+    map "${_}::DEMOLISH",
+    @{mro::get_linear_isa($into)};
+  join '',
+    qq{    package $into;\n},
+    map qq{    ${me}->${_}(${args});\n}, @demolishers;
+}
+
+sub _handle_subdemolish {
+  my ($self, $into) = @_;
+  '    if (ref($_[0]) ne '.quotify($into).') {'."\n".
+  "      package $into;\n".
+  '      return shift->Moo::Object::DEMOLISHALL(@_)'.";\n".
+  '    }'."\n";
+}
+
+1;