view release on metacpan or  search on metacpan

lib/DBIx/DataModel/Source/Table.pm  view on Meta::CPAN

        # an arrayref which is an array of values or a "bind value with type"
        # -- see L<DBIx::Class::ResultSet/"DBIC BIND VALUES">
        (does($v, 'ARRAY') && ($sqla->{array_datatypes} ||
                                 $sqla->is_bind_value_with_type($v)))
        ||
        # literal SQL in the form $k => \ ["FUNC(?)", $v]
        (ref $v eq 'REF' && does($$v, 'ARRAY'))
       ){
        # do nothing (pass the ref to SQL::Abstract::More)
      }

      # otherwise it is probably wrong data
      else {
        carp "unexpected reference $k in record, deleted";
        delete $self->{$k};
      }
    }
  }

  return keys %subrecords ? \%subrecords : undef;
}



sub _insert_subtrees {
  my ($self, $subrecords, %options) = @_;
  my $class = ref $self;
  my %results;

  while (my ($role, $arrayref) = each %$subrecords) {
    does $arrayref, 'ARRAY'
      or croak "Expected an arrayref for component role $role in $class";
    next if not @$arrayref;

    # insert via the "insert_into_..." method
    my $meth = "insert_into_$role";
    $results{$role} = [$self->$meth(@$arrayref, %options)];

    # also reinject in memory into source object
    $self->{$role} = $arrayref; 
  }

  return \%results;
}


#------------------------------------------------------------
# delete
#------------------------------------------------------------

my $delete_spec = {
  -where => {type => HASHREF, optional => 0},
};


sub _parse_delete_args {
  my $self = shift;

  my @pk_cols = $self->metadm->primary_key;
  my $where;
  my @cascaded;

  if ($self->_is_called_as_class_method) {
    # parse arguments
    @_ or croak "delete() as class method: not enough arguments";

    my $uses_named_args = ! ref $_[0] && $_[0] =~ /^-/;
    if ($uses_named_args) {
      my %args = validate_with(params      => \@_,
                               spec        => $delete_spec,
                               allow_extra => 0);
      $where = $args{-where};
    }
    else { # uses positional args
      if (does $_[0], 'HASH') { # called as: delete({fields})
        my $hash = shift;
        @{$where}{@pk_cols} = @{$hash}{@pk_cols};
        !@_ or croak "delete() : too many arguments";
      }
      else { # called as: delete(@primary_key)
        my ($n_vals, $n_keys) = (scalar(@_), scalar(@pk_cols));
        $n_vals == $n_keys
          or croak "delete(): got $n_vals cols in primary key, expected $n_keys";
        @{$where}{@pk_cols} = @_;
      }
      my $missing = join ", ", grep {!defined $where->{$_}} @pk_cols;
      croak "delete(): missing value for $missing" if $missing;
    }
  }
  else { # called as instance method

    # build $where from primary key
    @{$where}{@pk_cols} = @{$self}{@pk_cols};

    # cascaded delete
  COMPONENT_NAME:
    foreach my $component_name ($self->metadm->components) {
      my $components = $self->{$component_name} or next COMPONENT_NAME;
      does($components, 'ARRAY')
        or croak "delete() : component $component_name is not an arrayref";
      push @cascaded, @$components;
    }
  }

  return ($where, \@cascaded);
}


sub delete {
  my $self = shift;

  my $schema             = $self->schema;
  my ($where, $cascaded) = $self->_parse_delete_args(@_);

  # perform cascaded deletes for components within $self
  $_->delete foreach @$cascaded;

  # perform this delete
  my ($sql, @bind) = $schema->sql_abstract->delete(
    -from  => $self->db_from,
    -where => $where,
   );
  $schema->_debug($sql . " / " . CORE::join(", ", @bind) );
  my $method = $schema->dbi_prepare_method;
  my $sth    = $schema->dbh->$method($sql);
  $sth->execute(@bind);
}


#------------------------------------------------------------
# update
#------------------------------------------------------------

my $update_spec = {
  -set   => {type => HASHREF, optional => 0},
  -where => {type => HASHREF, optional => 0},
};


sub _parse_update_args  { # returns ($schema, $to_set, $where)
  my $self = shift;

  my ($to_set, $where);

  if ($self->_is_called_as_class_method) {
    @_
      or croak "update() as class method: not enough arguments";

    my $uses_named_args = ! ref $_[0] && $_[0] =~ /^-/;
    if ($uses_named_args) {
      my %args = validate_with(params      => \@_,
                               spec        => $update_spec,
                               allow_extra => 0);
      ($to_set, $where) = @args{qw/-set -where/};
    }
    else { # uses positional args: update([@primary_key], {fields_to_update})
      does $_[-1], 'HASH'
        or croak "update(): expected a hashref as last argument";
      $to_set = { %{pop @_} };  # shallow copy
      my @pk_cols = $self->metadm->primary_key;
      if (@_) {
        my ($n_vals, $n_keys) = (scalar(@_), scalar(@pk_cols));
        $n_vals == $n_keys
          or croak "update(): got $n_vals cols in primary key, expected $n_keys";
        @{$where}{@pk_cols} = @_;
      }
      else {
        # extract primary key from hashref
        @{$where}{@pk_cols} = delete @{$to_set}{@pk_cols};
      }
    }
  }
  else { # called as instance method
    my %clone = %$self;

    # extract primary key from object