Initial Commit

database/perl/vendor/lib/DBIx/Class/Relationship/Accessor.pm

@@ -0,0 +1,112 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::Accessor;
+
+use strict;
+use warnings;
+use DBIx::Class::Carp;
+use DBIx::Class::_Util qw(quote_sub perlstring);
+use namespace::clean;
+
+our %_pod_inherit_config =
+  (
+   class_map => { 'DBIx::Class::Relationship::Accessor' => 'DBIx::Class::Relationship' }
+  );
+
+sub register_relationship {
+  my ($class, $rel, $info) = @_;
+  if (my $acc_type = $info->{attrs}{accessor}) {
+    $class->add_relationship_accessor($rel => $acc_type);
+  }
+  $class->next::method($rel => $info);
+}
+
+sub add_relationship_accessor {
+  my ($class, $rel, $acc_type) = @_;
+
+  if ($acc_type eq 'single') {
+    quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel);
+      my $self = shift;
+
+      if (@_) {
+        $self->set_from_related( %1$s => @_ );
+        return $self->{_relationship_data}{%1$s} = $_[0];
+      }
+      elsif (exists $self->{_relationship_data}{%1$s}) {
+        return $self->{_relationship_data}{%1$s};
+      }
+      else {
+        my $relcond = $self->result_source->_resolve_relationship_condition(
+          rel_name => %1$s,
+          foreign_alias => %1$s,
+          self_alias => 'me',
+          self_result_object => $self,
+        );
+
+        return undef if (
+          $relcond->{join_free_condition}
+            and
+          $relcond->{join_free_condition} ne DBIx::Class::_Util::UNRESOLVABLE_CONDITION
+            and
+          scalar grep { not defined $_ } values %%{ $relcond->{join_free_condition} || {} }
+            and
+          $self->result_source->relationship_info(%1$s)->{attrs}{undef_on_null_fk}
+        );
+
+        my $val = $self->search_related( %1$s )->single;
+        return $val unless $val;  # $val instead of undef so that null-objects can go through
+
+        return $self->{_relationship_data}{%1$s} = $val;
+      }
+EOC
+  }
+  elsif ($acc_type eq 'filter') {
+    $class->throw_exception("No such column '$rel' to filter")
+       unless $class->has_column($rel);
+
+    my $f_class = $class->relationship_info($rel)->{class};
+
+    $class->inflate_column($rel, {
+      inflate => sub {
+        my ($val, $self) = @_;
+        return $self->find_or_new_related($rel, {}, {});
+      },
+      deflate => sub {
+        my ($val, $self) = @_;
+        $self->throw_exception("'$val' isn't a $f_class") unless $val->isa($f_class);
+
+        # MASSIVE FIXME - this code assumes we pointed at the PK, but the belongs_to
+        # helper does not check any of this
+        # fixup the code a bit to make things saner, but ideally 'filter' needs to
+        # be deprecated ASAP and removed shortly after
+        # Not doing so before 0.08250 however, too many things in motion already
+        my ($pk_col, @rest) = $val->result_source->_pri_cols_or_die;
+        $self->throw_exception(
+          "Relationship '$rel' of type 'filter' can not work with a multicolumn primary key on source '$f_class'"
+        ) if @rest;
+
+        my $pk_val = $val->get_column($pk_col);
+        carp_unique (
+          "Unable to deflate 'filter'-type relationship '$rel' (related object "
+        . "primary key not retrieved), assuming undef instead"
+        ) if ( ! defined $pk_val and $val->in_storage );
+
+        return $pk_val;
+      },
+    });
+  }
+  elsif ($acc_type eq 'multi') {
+
+    quote_sub "${class}::${rel}_rs", "shift->search_related_rs( $rel => \@_ )";
+    quote_sub "${class}::add_to_${rel}", "shift->create_related( $rel => \@_ )";
+    quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel );
+      DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
+      shift->search_related( %s => @_ )
+EOC
+  }
+  else {
+    $class->throw_exception("No such relationship accessor type '$acc_type'");
+  }
+
+}
+
+1;

database/perl/vendor/lib/DBIx/Class/Relationship/BelongsTo.pm

@@ -0,0 +1,104 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::BelongsTo;
+
+# Documentation for these methods can be found in
+# DBIx::Class::Relationship
+
+use strict;
+use warnings;
+use Try::Tiny;
+use namespace::clean;
+
+our %_pod_inherit_config =
+  (
+   class_map => { 'DBIx::Class::Relationship::BelongsTo' => 'DBIx::Class::Relationship' }
+  );
+
+sub belongs_to {
+  my ($class, $rel, $f_class, $cond, $attrs) = @_;
+
+  # assume a foreign key constraint unless defined otherwise
+  $attrs->{is_foreign_key_constraint} = 1
+    if not exists $attrs->{is_foreign_key_constraint};
+  $attrs->{undef_on_null_fk} = 1
+    if not exists $attrs->{undef_on_null_fk};
+
+  # no join condition or just a column name
+  if (!ref $cond) {
+
+    my ($f_key, $guess);
+    if (defined $cond and length $cond) {
+      $f_key = $cond;
+      $guess = "caller specified foreign key '$f_key'";
+    }
+    else {
+      $f_key = $rel;
+      $guess = "using given relationship name '$rel' as foreign key column name";
+    }
+
+    $class->throw_exception(
+      "No such column '$f_key' declared yet on ${class} ($guess)"
+    )  unless $class->has_column($f_key);
+
+    $class->ensure_class_loaded($f_class);
+    my $f_rsrc = try {
+      $f_class->result_source_instance;
+    }
+    catch {
+      $class->throw_exception(
+        "Foreign class '$f_class' does not seem to be a Result class "
+      . "(or it simply did not load entirely due to a circular relation chain)"
+      );
+    };
+
+    my $pri = $f_rsrc->_single_pri_col_or_die;
+
+    $cond = { "foreign.${pri}" => "self.${f_key}" };
+
+  }
+  # explicit join condition
+  else {
+    if (ref $cond eq 'HASH') { # ARRAY is also valid
+      my $cond_rel;
+      # FIXME This loop is ridiculously incomplete and dangerous
+      # staving off changes until implmentation of the swindon consensus
+      for (keys %$cond) {
+        if (m/\./) { # Explicit join condition
+          $cond_rel = $cond;
+          last;
+        }
+        $cond_rel->{"foreign.$_"} = "self.".$cond->{$_};
+      }
+      $cond = $cond_rel;
+    }
+  }
+
+  my $acc_type = (
+    ref $cond eq 'HASH'
+      and
+    keys %$cond == 1
+      and
+    (keys %$cond)[0] =~ /^foreign\./
+      and
+    $class->has_column($rel)
+  ) ? 'filter' : 'single';
+
+  my $fk_columns = ($acc_type eq 'single' and ref $cond eq 'HASH')
+    ? { map { $_ =~ /^self\.(.+)/ ? ( $1 => 1 ) : () } (values %$cond ) }
+    : undef
+  ;
+
+  $class->add_relationship($rel, $f_class,
+    $cond,
+    {
+      is_depends_on => 1,
+      accessor => $acc_type,
+      $fk_columns ? ( fk_columns => $fk_columns ) : (),
+      %{$attrs || {}}
+    }
+  );
+
+  return 1;
+}
+
+1;

database/perl/vendor/lib/DBIx/Class/Relationship/CascadeActions.pm

@@ -0,0 +1,78 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::CascadeActions;
+
+use strict;
+use warnings;
+use DBIx::Class::Carp;
+use namespace::clean;
+
+our %_pod_inherit_config =
+  (
+   class_map => { 'DBIx::Class::Relationship::CascadeActions' => 'DBIx::Class::Relationship' }
+  );
+
+sub delete {
+  my ($self, @rest) = @_;
+  return $self->next::method(@rest) unless ref $self;
+    # I'm just ignoring this for class deletes because hell, the db should
+    # be handling this anyway. Assuming we have joins we probably actually
+    # *could* do them, but I'd rather not.
+
+  my $source = $self->result_source;
+  my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
+  my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels;
+
+  if (@cascade) {
+    my $guard = $source->schema->txn_scope_guard;
+
+    my $ret = $self->next::method(@rest);
+
+    foreach my $rel (@cascade) {
+      if( my $rel_rs = eval{ $self->search_related($rel) } ) {
+        $rel_rs->delete_all;
+      } else {
+        carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema";
+        next;
+      }
+    }
+
+    $guard->commit;
+    return $ret;
+  }
+
+  $self->next::method(@rest);
+}
+
+sub update {
+  my ($self, @rest) = @_;
+  return $self->next::method(@rest) unless ref $self;
+    # Because update cascades on a class *really* don't make sense!
+
+  my $source = $self->result_source;
+  my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
+  my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
+
+  if (@cascade) {
+    my $guard = $source->schema->txn_scope_guard;
+
+    my $ret = $self->next::method(@rest);
+
+    foreach my $rel (@cascade) {
+      next if (
+        $rels{$rel}{attrs}{accessor}
+          &&
+        $rels{$rel}{attrs}{accessor} eq 'single'
+          &&
+        !exists($self->{_relationship_data}{$rel})
+      );
+      $_->update for grep defined, $self->$rel;
+    }
+
+    $guard->commit;
+    return $ret;
+  }
+
+  $self->next::method(@rest);
+}
+
+1;

database/perl/vendor/lib/DBIx/Class/Relationship/HasMany.pm

@@ -0,0 +1,54 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::HasMany;
+
+use strict;
+use warnings;
+use Try::Tiny;
+use namespace::clean;
+
+our %_pod_inherit_config =
+  (
+   class_map => { 'DBIx::Class::Relationship::HasMany' => 'DBIx::Class::Relationship' }
+  );
+
+sub has_many {
+  my ($class, $rel, $f_class, $cond, $attrs) = @_;
+
+  unless (ref $cond) {
+
+    my $pri = $class->result_source_instance->_single_pri_col_or_die;
+
+    my ($f_key,$guess);
+    if (defined $cond && length $cond) {
+      $f_key = $cond;
+      $guess = "caller specified foreign key '$f_key'";
+    } else {
+      $class =~ /([^\:]+)$/;  # match is safe - $class can't be ''
+      $f_key = lc $1; # go ahead and guess; best we can do
+      $guess = "using our class name '$class' as foreign key source";
+    }
+
+# FIXME - this check needs to be moved to schema-composition time...
+#    # only perform checks if the far side appears already loaded
+#    if (my $f_rsrc = try { $f_class->result_source_instance } ) {
+#      $class->throw_exception(
+#        "No such column '$f_key' on foreign class ${f_class} ($guess)"
+#      ) if !$f_rsrc->has_column($f_key);
+#    }
+
+    $cond = { "foreign.${f_key}" => "self.${pri}" };
+  }
+
+  my $default_cascade = ref $cond eq 'CODE' ? 0 : 1;
+
+  $class->add_relationship($rel, $f_class, $cond, {
+    accessor => 'multi',
+    join_type => 'LEFT',
+    cascade_delete => $default_cascade,
+    cascade_copy => $default_cascade,
+    is_depends_on => 0,
+    %{$attrs||{}}
+  });
+}
+
+1;

database/perl/vendor/lib/DBIx/Class/Relationship/HasOne.pm

@@ -0,0 +1,108 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::HasOne;
+
+use strict;
+use warnings;
+use DBIx::Class::Carp;
+use Try::Tiny;
+use namespace::clean;
+
+our %_pod_inherit_config =
+  (
+   class_map => { 'DBIx::Class::Relationship::HasOne' => 'DBIx::Class::Relationship' }
+  );
+
+sub might_have {
+  shift->_has_one('LEFT' => @_);
+}
+
+sub has_one {
+  shift->_has_one(undef() => @_);
+}
+
+sub _has_one {
+  my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_;
+  unless (ref $cond) {
+    my $pri = $class->result_source_instance->_single_pri_col_or_die;
+
+    my ($f_key,$guess,$f_rsrc);
+    if (defined $cond && length $cond) {
+      $f_key = $cond;
+      $guess = "caller specified foreign key '$f_key'";
+    }
+    else {
+      # at this point we need to load the foreigner, expensive or not
+      $class->ensure_class_loaded($f_class);
+
+      $f_rsrc = try {
+        my $r = $f_class->result_source_instance;
+        die "There got to be some columns by now... (exception caught and rewritten by catch below)"
+          unless $r->columns;
+        $r;
+      }
+      catch {
+        $class->throw_exception(
+          "Foreign class '$f_class' does not seem to be a Result class "
+        . "(or it simply did not load entirely due to a circular relation chain)"
+        );
+      };
+
+      if ($f_rsrc->has_column($rel)) {
+        $f_key = $rel;
+        $guess = "using given relationship name '$rel' as foreign key column name";
+      }
+      else {
+        $f_key = $f_rsrc->_single_pri_col_or_die;
+        $guess = "using primary key of foreign class for foreign key";
+      }
+    }
+
+# FIXME - this check needs to be moved to schema-composition time...
+#    # only perform checks if the far side was not preloaded above *AND*
+#    # appears to have been loaded by something else (has a rsrc_instance)
+#    if (! $f_rsrc and $f_rsrc = try { $f_class->result_source_instance }) {
+#      $class->throw_exception(
+#        "No such column '$f_key' on foreign class ${f_class} ($guess)"
+#      ) if !$f_rsrc->has_column($f_key);
+#    }
+
+    $cond = { "foreign.${f_key}" => "self.${pri}" };
+  }
+  $class->_validate_has_one_condition($cond);
+
+  my $default_cascade = ref $cond eq 'CODE' ? 0 : 1;
+
+  $class->add_relationship($rel, $f_class,
+   $cond,
+   { accessor => 'single',
+     cascade_update => $default_cascade,
+     cascade_delete => $default_cascade,
+     is_depends_on => 0,
+     ($join_type ? ('join_type' => $join_type) : ()),
+     %{$attrs || {}} });
+  1;
+}
+
+sub _validate_has_one_condition {
+  my ($class, $cond )  = @_;
+
+  return if $ENV{DBIC_DONT_VALIDATE_RELS};
+  return unless 'HASH' eq ref $cond;
+  foreach my $foreign_id ( keys %$cond ) {
+    my $self_id = $cond->{$foreign_id};
+
+    # we can ignore a bad $self_id because add_relationship handles this
+    # exception
+    return unless $self_id =~ /^self\.(.*)$/;
+
+    my $key = $1;
+    $class->throw_exception("Defining rel on ${class} that includes '$key' but no such column defined here yet")
+        unless $class->has_column($key);
+    my $column_info = $class->column_info($key);
+    if ( $column_info->{is_nullable} ) {
+      carp(qq'"might_have/has_one" must not be on columns with is_nullable set to true ($class/$key). This might indicate an incorrect use of those relationship helpers instead of belongs_to.');
+    }
+  }
+}
+
+1;

database/perl/vendor/lib/DBIx/Class/Relationship/Helpers.pm

@@ -0,0 +1,16 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::Helpers;
+
+use strict;
+use warnings;
+
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/
+    Relationship::HasMany
+    Relationship::HasOne
+    Relationship::BelongsTo
+    Relationship::ManyToMany
+/);
+
+1;

database/perl/vendor/lib/DBIx/Class/Relationship/ManyToMany.pm

@@ -0,0 +1,151 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::ManyToMany;
+
+use strict;
+use warnings;
+
+use DBIx::Class::Carp;
+use Sub::Name 'subname';
+use Scalar::Util 'blessed';
+use DBIx::Class::_Util 'fail_on_internal_wantarray';
+use namespace::clean;
+
+our %_pod_inherit_config =
+  (
+   class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
+  );
+
+sub many_to_many {
+  my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
+
+  $class->throw_exception(
+    "missing relation in many-to-many"
+  ) unless $rel;
+
+  $class->throw_exception(
+    "missing foreign relation in many-to-many"
+  ) unless $f_rel;
+
+  {
+    no strict 'refs';
+    no warnings 'redefine';
+
+    my $add_meth = "add_to_${meth}";
+    my $remove_meth = "remove_from_${meth}";
+    my $set_meth = "set_${meth}";
+    my $rs_meth = "${meth}_rs";
+
+    for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
+      if ( $class->can ($_) ) {
+        carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK};
+
+***************************************************************************
+The many-to-many relationship '$meth' is trying to create a utility method
+called $_.
+This will completely overwrite one such already existing method on class
+$class.
+
+You almost certainly want to rename your method or the many-to-many
+relationship, as the functionality of the original method will not be
+accessible anymore.
+
+To disable this warning set to a true value the environment variable
+DBIC_OVERWRITE_HELPER_METHODS_OK
+
+***************************************************************************
+EOW
+      }
+    }
+
+    $rel_attrs->{alias} ||= $f_rel;
+
+    my $rs_meth_name = join '::', $class, $rs_meth;
+    *$rs_meth_name = subname $rs_meth_name, sub {
+      my $self = shift;
+      my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
+      my $rs = $self->search_related($rel)->search_related(
+        $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
+      );
+      return $rs;
+    };
+
+    my $meth_name = join '::', $class, $meth;
+    *$meth_name = subname $meth_name, sub {
+      DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray;
+      my $self = shift;
+      my $rs = $self->$rs_meth( @_ );
+      return (wantarray ? $rs->all : $rs);
+    };
+
+    my $add_meth_name = join '::', $class, $add_meth;
+    *$add_meth_name = subname $add_meth_name, sub {
+      my $self = shift;
+      @_ > 0 or $self->throw_exception(
+        "${add_meth} needs an object or hashref"
+      );
+      my $source = $self->result_source;
+      my $schema = $source->schema;
+      my $rel_source_name = $source->relationship_info($rel)->{source};
+      my $rel_source = $schema->resultset($rel_source_name)->result_source;
+      my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source};
+      my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{});
+
+      my $obj;
+      if (ref $_[0]) {
+        if (ref $_[0] eq 'HASH') {
+          $obj = $f_rel_rs->find_or_create($_[0]);
+        } else {
+          $obj = $_[0];
+        }
+      } else {
+        $obj = $f_rel_rs->find_or_create({@_});
+      }
+
+      my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
+      my $link = $self->search_related($rel)->new_result($link_vals);
+      $link->set_from_related($f_rel, $obj);
+      $link->insert();
+      return $obj;
+    };
+
+    my $set_meth_name = join '::', $class, $set_meth;
+    *$set_meth_name = subname $set_meth_name, sub {
+      my $self = shift;
+      @_ > 0 or $self->throw_exception(
+        "{$set_meth} needs a list of objects or hashrefs"
+      );
+      my @to_set = (ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_);
+      # if there is a where clause in the attributes, ensure we only delete
+      # rows that are within the where restriction
+      if ($rel_attrs && $rel_attrs->{where}) {
+        $self->search_related( $rel, $rel_attrs->{where},{join => $f_rel})->delete;
+      } else {
+        $self->search_related( $rel, {} )->delete;
+      }
+      # add in the set rel objects
+      $self->$add_meth($_, ref($_[1]) ? $_[1] : {}) for (@to_set);
+    };
+
+    my $remove_meth_name = join '::', $class, $remove_meth;
+    *$remove_meth_name = subname $remove_meth_name, sub {
+      my ($self, $obj) = @_;
+      $self->throw_exception("${remove_meth} needs an object")
+        unless blessed ($obj);
+      my $rel_source = $self->search_related($rel)->result_source;
+      my $cond = $rel_source->relationship_info($f_rel)->{cond};
+      my ($link_cond, $crosstable) = $rel_source->_resolve_condition(
+        $cond, $obj, $f_rel, $f_rel
+      );
+
+      $self->throw_exception(
+        "Relationship '$rel' does not resolve to a join-free condition, "
+       ."unable to use with the ManyToMany helper '$f_rel'"
+      ) if $crosstable;
+
+      $self->search_related($rel, $link_cond)->delete;
+    };
+
+  }
+}
+
+1;

database/perl/vendor/lib/DBIx/Class/Relationship/ProxyMethods.pm

@@ -0,0 +1,61 @@
+package # hide from PAUSE
+    DBIx::Class::Relationship::ProxyMethods;
+
+use strict;
+use warnings;
+use base 'DBIx::Class';
+use DBIx::Class::_Util 'quote_sub';
+use namespace::clean;
+
+our %_pod_inherit_config =
+  (
+   class_map => { 'DBIx::Class::Relationship::ProxyMethods' => 'DBIx::Class::Relationship' }
+  );
+
+sub register_relationship {
+  my ($class, $rel, $info) = @_;
+  if (my $proxy_args = $info->{attrs}{proxy}) {
+    $class->proxy_to_related($rel, $proxy_args);
+  }
+  $class->next::method($rel, $info);
+}
+
+sub proxy_to_related {
+  my ($class, $rel, $proxy_args) = @_;
+  my %proxy_map = $class->_build_proxy_map_from($proxy_args);
+
+  quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} )
+    my $self = shift;
+    my $relobj = $self->%1$s;
+    if (@_ && !defined $relobj) {
+      $relobj = $self->create_related( %1$s => { %2$s => $_[0] } );
+      @_ = ();
+    }
+    $relobj ? $relobj->%2$s(@_) : undef;
+EOC
+    for keys %proxy_map
+}
+
+sub _build_proxy_map_from {
+  my ( $class, $proxy_arg ) = @_;
+  my $ref = ref $proxy_arg;
+
+  if ($ref eq 'HASH') {
+    return %$proxy_arg;
+  }
+  elsif ($ref eq 'ARRAY') {
+    return map {
+      (ref $_ eq 'HASH')
+        ? (%$_)
+        : ($_ => $_)
+    } @$proxy_arg;
+  }
+  elsif ($ref) {
+    $class->throw_exception("Unable to process the 'proxy' argument $proxy_arg");
+  }
+  else {
+    return ( $proxy_arg => $proxy_arg );
+  }
+}
+
+1;