view release on metacpan or  search on metacpan

lib/DBIx/Simple/Class.pm  view on Meta::CPAN

#conveninece for getting key/vaule arguments
sub _get_args {
  return ref($_[0]) ? $_[0] : (@_ % 2) ? $_[0] : {@_};
}
sub _get_obj_args { return (shift, ref($_[0]) ? $_[0] : (@_ % 2) ? $_[0] : {@_}); }

sub _check {
  my ($self, $key, $value) = @_;
  local $Params::Check::WARNINGS_FATAL = 1;
  local $Params::Check::CALLER_DEPTH   = $Params::Check::CALLER_DEPTH + 1;

  my $args_out =
    Params::Check::check({$key => $self->CHECKS->{$key} || {}}, {$key => $value});
  return $args_out->{$key};
}

#fieldvalues HASHREF
sub data {
  my ($self, $args) = _get_obj_args(@_);
  if (ref $args && keys %$args) {
    for my $field (keys %$args) {
      my $alias = $self->ALIASES->{$field} || $field;
      unless (grep { $field eq $_ } @{$self->_UNQUOTED->{COLUMNS}}) {
        Carp::cluck(
          "There is not such field $field in table " . $self->TABLE . '! Skipping...')
          if $DEBUG;
        next;
      }

      #we may have getters/setters written by the author of the subclass
      # so call each setter separately
      $self->$alias($args->{$field});
    }
  }

  #a key (!ref $args)
  elsif (!ref $args) {
    my $alias = $self->ALIASES->{$args} || $args;
    return $self->$alias;
  }

  #they want all that we touched in $self->{data}
  return $self->{data};
}

sub save {
  my ($self, $data) = _get_obj_args(@_);

  #allow data to be passed directly and overwrite current data
  if (keys %$data) { $self->data($data); }
  local $Carp::MaxArgLen = 0;
  if (!$self->{new_from_dbix_simple}) {
    return $self->{new_from_dbix_simple} = $self->insert();
  }
  else {
    return $self->update();
  }
  return;
}

sub update {
  my ($self) = @_;
  my $pk = $self->PRIMARY_KEY;
  $self->{data}{$pk} || croak('Please define primary key column (\$self->$pk(?))!');
  my $dbh = $self->dbh;
  $self->{SQL_UPDATE} ||= do {
    my $SET =
      join(', ', map { $dbh->quote_identifier($_) . '=? ' } keys %{$self->{data}});
    'UPDATE ' . $self->TABLE . " SET $SET WHERE $pk=?";
  };
  return $dbh->prepare($self->{SQL_UPDATE})
    ->execute(values %{$self->{data}}, $self->{data}{$pk});
}

sub insert {
  my ($self) = @_;
  my ($pk, $class) = ($self->PRIMARY_KEY, ref $self);

  $self->dbh->prepare_cached($SQL_CACHE->{$class}{INSERT} || $class->SQL('INSERT'))
    ->execute(
    map {

      #set expected defaults
      $self->data($_)
    } @{$class->_UNQUOTED->{COLUMNS}}
    );

  #user set the primary key already
  return $self->{data}{$pk}
    ||= $self->dbh->last_insert_id(undef, undef, $self->TABLE, $pk);

}

sub create {
  my $self = shift->new(@_);
  $self->insert;
  return $self;
}

1;

__END__


# If you have pod after  __END__,
#comment __END__ marker so you can generate/use
# additional perl tags using exuberant ctags.

# Example ctags filters to put in your ~/.ctags file:
#--regex-perl=/^\s*?use\s+(\w+[\w\:]*?\w*?)/\1/u,use,uses/
#--regex-perl=/^\s*?require\s+(\w+[\w\:]*?\w*?)/\1/r,require,requires/
#--regex-perl=/^\s*?has\s+['"]?(\w+)['"]?/\1/a,attribute,attributes/
#--regex-perl=/^\s*?\*(\w+)\s*?=/\1/a,aliase,aliases/
#--regex-perl=/->helper\(\s?['"]?(\w+)['"]?/\1/h,helper,helpers/
#--regex-perl=/^\s*?our\s*?[\$@%](\w+)/\1/o,our,ours/
#--regex-perl=/^=head1\s+(.+)/\1/p,pod,Plain Old Documentation/
#--regex-perl=/^=head2\s+(.+)/-- \1/p,pod,Plain Old Documentation/
#--regex-perl=/^=head[3-5]\s+(.+)/---- \1/p,pod,Plain Old Documentation/