File Coverage

blib/lib/ClearPress/model.pm

Criterion	Covered	Total	%
statement	361	449	80.4
branch	79	148	53.3
condition	16	46	34.7
subroutine	47	51	92.1
pod	30	30	100.0
total	533	724	73.6

# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2
#########
# Author: rmp
# Created: 2006-10-31
#
package ClearPress::model;
use strict;
use warnings;
use base qw(Class::Accessor);
use ClearPress::util;
use English qw(-no_match_vars);
use Carp;
use Lingua::EN::Inflect qw(PL);
use Lingua::EN::PluralToSingular qw(to_singular);
use POSIX qw(strftime);
use Readonly;

our $VERSION = q[477.1.4];

Readonly::Scalar our $DBI_CACHE_OVERWRITE => 3;

our $EXPERIMENTAL_PL = 0;

sub fields { return (); }

sub _plfunc {
  my $thing = shift;
  return $EXPERIMENTAL_PL ? PL(to_singular($thing)) : PL($thing);
}

sub primary_key {
  my $self = shift;
  return ($self->fields())[0];
}

sub secondary_key {
}

sub table {
  my $self = shift;
  my $tbl  = (ref $self) || $self;
  if(!$tbl) {
    return;
  }
  ($tbl)   = $tbl =~ /.*::([^:]+)/smx;
  return $tbl;
}

sub init  { }

sub new {
  my ($class, $ref) = @_;
  $ref ||= {};

  my $pk = $class->primary_key();

  if(!ref $ref) {
    if($pk) {
      $ref = {
	      $pk => $ref,
	     };
    } else {
      croak q[Could not set primary key in an object with no fields];
    }
  }

  bless $ref, $class;

  my $sk   = $ref->secondary_key();
  if($sk && $ref->{$sk} &&
     !$ref->{$pk}) {

    my $table = $ref->table;
    my $util  = $ref->util;
    my $dbh   = $util->dbh;
    eval {
      my $id   = $dbh->selectall_arrayref(qq[/* model::new */ SELECT $pk FROM $table WHERE $sk=?], {}, $ref->{$sk})->[0]->[0];
      $ref->{$pk} = $id;
      1;

    } or do {
      carp $EVAL_ERROR;
      return;
    };
  }

  $ref->init($ref);

  return $ref;
}

sub util {
  my ($self, $util) = @_;

  if(!ref $self) {
    #########
    # If we're being accessed as a class method (e.g. for retrieving
    # type dictionaries) Then play nicely and return a util.
    #
    # Note, this currently needs subclassing if you want class-method
    # support in your own namespace.
    #
    return ClearPress::util->new();
  }

  if($util) {
    $self->{util} = $util;
    return $util;
  }

  if($self->{util}) {
    return $self->{util};
  }

  #########
  # attempt to instantiate a util using $self's namespace
  #
  my ($ref) = (ref $self) =~ /^([^:]+)/smx;
  my $nsutil;
  eval {
    my $ns  = "${ref}::util";
    $nsutil = $ns->new();

  } or do {
    carp qq[Failed to construct a util from the current namespace ($ref).];
  };

  if($nsutil) {
    $self->{util} = $nsutil;
    return $self->{util};
  }

  #########
  # ClearPress::driver is now a Class::Singleton so, casually ignoring
  # the state of any open transactions, we should be able to
  # instantiate more copies on demand
  #
  my $cputil    = ClearPress::util->new();
  my $config    = $cputil->config();
  my $namespace = $config->val('application', 'namespace') ||
                  $config->val('application', 'name');
  $util         = "${namespace}::util"->new();
  $self->{util} = $util;
  return $util;
}

sub get {
  my ($self, $field) = @_;

  if(!exists $self->{$field}) {
    $self->read();
  }

  return $self->SUPER::get($field);
}

sub gen_getarray {
  my ($self, $class, $query, @args) = @_;
  my $util = $self->util();

  if(!ref $self) {
    $self = $self->new({
			util => $util,
		       });
  }

  my $res  = [];
  my $sth;

  eval {
    my $dbh = $util->dbh();
    #########
    # statement caching removed as cache conflicts are dangerous
    # and could be easily generated by accident
    $sth = $dbh->prepare($query);
    $sth->execute(@args);
    1; # sth->execute() does not return true!

  } or do {
    $query =~ s/\s+/ /smxg;
    local $LIST_SEPARATOR = q[, ];
    carp qq[GEN_GETARRAY ERROR\nEVAL_ERROR: $EVAL_ERROR\nCaller: @{[q[].caller]}\nQuery:\n$query\nDBH: @{[$util->dbh]}\nUTIL: $util\nParams: @{[map { (defined $_)?$_:'NULL' } @args]}];
    return;
  };

  while(my $ref = $sth->fetchrow_hashref()) {
    $ref->{util} = $util;
    push @{$res}, $class->new($ref);
  }
  $sth->finish();

  return $res;
}

sub gen_getall {
  my ($self, $class, $cachekey) = @_;
  $class ||= ref $self;

  if(!$cachekey) {
    ($cachekey) = $class =~ /([^:]+)$/smx;
    $cachekey   = _plfunc($cachekey);
  }

  if(!$self->{$cachekey}) {
    my $sortk = $self->secondary_key;
    if(!$sortk) {
      $sortk = $self->primary_key;
    }
    my $query = <<"EOT";
/* model::gen_getall */
SELECT   @{[join q(, ), $class->fields()]}
FROM     @{[$class->table()]}
ORDER BY $sortk
EOT
    $self->{$cachekey} = $self->gen_getarray($class, $query);
  }

  return $self->{$cachekey};
}

sub gen_getfriends {
  my ($self, $class, $cachekey) = @_;
  $class ||= ref $self;

  if(!$cachekey) {
    ($cachekey) = $class =~ /([^:]+)$/smx;
    $cachekey   = _plfunc($cachekey);
  }

  if(!$self->{$cachekey}) {
    my $link  = $self->primary_key();
    my $query = <<"EOT";
/* model::gen_getfriends */
SELECT   @{[join q(, ), $class->fields()]}
FROM     @{[$class->table()]}
WHERE    $link=?
ORDER BY $link
EOT
    $self->{$cachekey} = $self->gen_getarray($class, $query, $self->$link());
  }

  return $self->{$cachekey};
}

sub gen_getfriends_through {
  my ($self, $class, $through, $cachekey) = @_;
  $class ||= ref $self;

  if(!$cachekey) {
    ($cachekey) = $class =~ /([^:]+)$/smx;
    $cachekey   = _plfunc($cachekey);
  }

  if(!$self->{$cachekey}) {
    my ($through_pkg) = (ref $self) =~ /^(.*::)[^:]+$/smx;
    $through_pkg     .= $through;
    my $through_key   = $self->primary_key();
    my $friend_key    = $class->primary_key();
    my $query         = <<"EOT";
/* model::gen_getfriends_through */
SELECT @{[join q(, ),
               (map { "f.$_" } $class->fields()),
               (map { "t.$_" } $through_pkg->fields())]}
FROM   @{[$class->table()]} f,
       $through             t
WHERE  t.$through_key = ?
AND    t.$friend_key  = f.$friend_key
EOT
    $self->{$cachekey} = $self->gen_getarray($class, $query, $self->$through_key());
  }

  return $self->{$cachekey};
}

sub gen_getobj {
  my ($self, $class)   = @_;
  $class             ||= ref $self;
  my $pk               = $class->primary_key();
  my ($cachekey)       = $class =~ /([^:]+)$/smx;
  $self->{$cachekey} ||= $class->new({
				      util => $self->util(),
				      $pk  => $self->$pk(),
				     });
  return $self->{$cachekey};
}

sub gen_getobj_through {
  my ($self, $class, $through, $cachekey) = @_;
  $class ||= ref $self;

  if(!$cachekey) {
    ($cachekey) = $class =~ /([^:]+)$/smx;
  }

  if(!$self->{$cachekey}) {
    # todo: use $through class to determine $through_key
    #       - but $through class may not always be implemented
    my $through_key = q(id_).$through;
    my $friend_key  = $class->primary_key();
    my $query       = <<"EOT";
/* model::gen_getobj_through */
SELECT @{[join q(, ), map { "f.$_" } $class->fields()]}
FROM   @{[$class->table()]} f,
       $through            t
WHERE  t.$through_key = ?
AND    t.$friend_key  = f.$friend_key
EOT

    $self->{$cachekey} = $self->gen_getarray($class, $query, $self->$through_key())->[0];
  }

  return $self->{$cachekey};
}

sub belongs_to {
  my ($class, @args) = @_;
  return $class->has_a(@args);
}

sub hasa {
  my ($class, @args) = @_;
  carp q[hasa is deprecated. Use has_a];
  return $class->has_a(@args);
}

sub has_a {
  my ($class, $attr) = @_;

  if(ref $attr ne 'ARRAY') {
    $attr = [$attr];
  }

  for my $single (@{$attr}) {
    my $pkg = $single;

    if(ref $single eq 'HASH') {
      ($pkg)    = values %{$single};
      ($single) = keys %{$single};
    }

    my $namespace = "${class}::$pkg";
    my $yield     = $class;
    if($yield !~ /model/smx) {
      croak qq[$pkg is not under a model:: namespace. Friend relationships will not work.];
    }

    $yield =~ s/^(.*model::).*$/$1$pkg/smx;

    if (defined &{$namespace}) {
      next;
    }

    no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
    *{$namespace} = sub {
      my $self = shift;
      return $self->gen_getobj($yield);
    };
  }

  return;
}

sub hasmany {
  my ($class, @args) = @_;
  carp q[hasmany is deprecated. Use has_many];
  return $class->has_many(@args);
}

sub has_many {
  my ($class, $attr) = @_;

  if(ref $attr ne 'ARRAY') {
    $attr = [$attr];
  }

  for my $single (@{$attr}) {
    my $pkg = $single;

    if(ref $single eq 'HASH') {
      ($pkg)    = values %{$single};
      ($single) = keys %{$single};
    }

    my $plural    = _plfunc($single);
    my $namespace = "${class}::$plural";
    my $yield     = $class;
    $yield        =~ s/^(.*model::).*$/$1$pkg/smx;

    if($yield !~ /model/smx) {
      croak qq[$pkg is not under a model:: namespace. Friend relationships will not work.];
    }

    if (defined &{$namespace}) {
      next;
    }

    no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
    *{$namespace} = sub {
      my $self = shift;
      return $self->gen_getfriends($yield, $plural);
    };
  }

  return;
}

sub belongs_to_through {
  my ($class, @args) = @_;
  return $class->has_a_through(@args);
}

sub has_a_through {
  my ($class, $attr) = @_;

  if(ref $attr ne 'ARRAY') {
    $attr = [$attr];
  }

  for my $single (@{$attr}) {
    my $pkg = $single;

    if(ref $single eq 'HASH') {
      ($pkg)    = values %{$single};
      ($single) = keys %{$single};
    }
    $pkg =~ s/[|].*//smx;

    my $through;
    ($single, $through) = split /[|]/smx, $single;

    if(!$through) {
      croak qq(Cannot build belongs_to_through for $single);
    }

    my $namespace = "${class}::$pkg";
    my $yield     = $class;
    $yield        =~ s/^(.*model::).*$/$1$pkg/smx;

    if($yield !~ /model/smx) {
      croak qq[$pkg is not under a model:: namespace. Friend relationships will not work.];
    }

    if (defined &{$namespace}) {
      next;
    }

    no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
    *{$namespace} = sub {
      my $self = shift;
      return $self->gen_getobj_through($yield, $through);
    };
  }

  return;
}

sub has_many_through {
  my ($class, $attr) = @_;

  if(ref $attr ne 'ARRAY') {
    $attr = [$attr];
  }

  for my $single (@{$attr}) {
    my $pkg = $single;

    if(ref $single eq 'HASH') {
      ($pkg)    = values %{$single};
      ($single) = keys %{$single};
    }
    $pkg =~ s/[|].*//smx;

    my $through;
    ($single, $through) = split /[|]/smx, $single;

    if(!$through) {
      croak qq(Cannot build has_many_through for $single);
    }

    my $plural    = _plfunc($single);
    my $namespace = "${class}::$plural";
    my $yield     = $class;
    $yield        =~ s/^(.*model::).*$/$1$pkg/smx;

    if($yield !~ /model/smx) {
      croak qq[$pkg is not under a model:: namespace. Friend relationships will not work.];
    }

    if (defined &{$namespace}) {
      next;
    }

    no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
    *{$namespace} = sub {
      my $self = shift;

      return $self->gen_getfriends_through($yield, $through, $plural);
    };
  }

  return;
}

sub has_all {
  my ($class) = @_;

  my ($single)  = $class =~ /([^:]+)$/smx;
  my $plural    = _plfunc($single);
  my $namespace = "${class}::$plural";

  if (defined &{$namespace}) {
    return;
  }

  no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
  *{$namespace} = sub {
    my $self = shift;
    return $self->gen_getall();
  };

  return 1;
}

sub create {
  my $self     = shift;
  my $util     = $self->util();
  my $dbh      = $util->dbh();
  my $pk       = $self->primary_key();
  my $tr_state = $util->transactions();
  my $table    = $self->table();

  if(!$table) {
    croak q(No table defined);
  }

  #########
  # disallow saving against zero
  #
  if(!$self->$pk()) {
    delete $self->{$pk};
  }

  my $query = <<"EOT";
INSERT INTO $table (@{[join q(, ), $self->fields()]})
VALUES (@{[join q(, ), map { q(?) } $self->fields()]})
EOT

  my @args = map { $self->{$_} } $self->fields();
  eval {
    my $drv = $util->driver();
    my $id  = $drv->create($query, @args);
    $self->$pk($id);

  } or do {
    $tr_state and $dbh->rollback();
    carp qq[CREATE Query was:\n$query\n\nParams: @{[map { (defined $_)?$_:'NULL' } @args]}];
    croak $EVAL_ERROR;
  };

  eval {
    $tr_state and $dbh->commit();
    1;

  } or do {
    $tr_state and $dbh->rollback();
    croak $EVAL_ERROR;
  };

  return 1;
}

sub read { ## no critic (homonym)
  my ($self, $query, @args) = @_;
  my $pk   = $self->primary_key();
  my $util = $self->util;

  if(!$query && !$self->{$pk}) {
#    carp q(No primary key);
    return;
  }

  my $table = $self->table();
  if(!$table) {
    croak q(No table defined);
  }

  if(!$self->{_loaded}) {
    if(!$query) {
      $query = <<"EOT";
/* model::read */
SELECT @{[join q(, ), $self->fields()]}
FROM   $table
WHERE  $pk=?
EOT
      @args = ($self->{$pk});
    }

    eval {
      my $sth = $util->dbh->prepare($query);
      $sth->execute(@args);

      my $ref = $sth->fetchrow_hashref();

      if(!$sth->rows()) {
	#########
	# entity not in database
	#
	$sth->finish();
	croak q[missing entity];
      }

      $sth->finish();

      my $warnings = $util->driver->sth_has_warnings($sth);
      if(!$warnings) {
        for my $f ($self->fields()) {
          $self->{$f} = $ref->{$f};
        }

      } else {
        for my $w (@{$warnings}) {
          carp qq[ClearPress::model::read: mysql warning: $w->[2]];
        }
      }

      1;

    } or do {
      if($EVAL_ERROR =~ /missing\sentity/smx) {
	return;
      }
      carp qq[SELECT ERROR\nEVAL_ERROR: $EVAL_ERROR\nQuery:\n$query\n\nParams: @{[map { (defined $_)?$_:'NULL' } @args]}\n];
    };
  }
  $self->{_loaded} = 1;
  return 1;
}

sub update {
  my $self  = shift;
  my $pk    = $self->primary_key();

  if(!$pk || !$self->$pk()) {
    croak q(No primary key);
  }

  my $table = $self->table();
  if(!$table) {
    croak q(No table defined);
  }

  my $util     = $self->util();
  my $tr_state = $util->transactions();
  my $dbh      = $util->dbh();
  my @fields   = grep { exists $self->{$_} }
                 grep { $_ ne $pk }
                 $self->fields();
  my $query   = <<"EOT";
UPDATE @{[$self->table()]}
SET    @{[join q(, ),
               map  { qq[$_ = ?] }
               @fields]}
WHERE  $pk=?
EOT

  eval {
    $dbh->do($query, {}, (map { $self->$_() } @fields), $self->$pk);

  } or do {
    $tr_state and $dbh->rollback();
    croak $EVAL_ERROR.q[ ].$query;
  };

  eval {
    $tr_state and $dbh->commit();
    1;

  } or do {
    croak $EVAL_ERROR;
  };

  return 1;
}

sub delete { ## no critic (homonym)
  my $self     = shift;
  my $util     = $self->util();
  my $tr_state = $util->transactions();
  my $dbh      = $util->dbh();
  my $pk       = $self->primary_key();

  if(!$pk || !$self->$pk()) {
    croak q(No primary key);
  }

  my $query = <<"EOT";
DELETE FROM @{[$self->table()]}
WHERE $pk=?
EOT

  eval {
    $dbh->do($query, {}, $self->$pk());

  } or do {
    $tr_state and $dbh->rollback();
    croak $EVAL_ERROR.$query;
  };

  eval {
    $tr_state and $dbh->commit();
    1;

  } or do {
    croak $EVAL_ERROR;
  };

  return 1;
}

sub save {
  my $self = shift;
  my $pk   = $self->primary_key();

  if($pk && defined $self->{$pk}) {
    return $self->update();
  }

  return $self->create();
}

sub zdate {
  my $self = shift;
  my $date = q[];

  if(scalar grep { $_ eq 'date' } $self->fields()) {
    $date = $self->date() || q[];
    $date =~ s/[ ]/T/smx;
    $date .='Z';
  }

  if(!$date) {
    $date = strftime q(%Y-%m-%dT%H:%M:%SZ), gmtime;
  }

  return $date;
}

sub isodate {
  return strftime q(%Y-%m-%d %H:%M:%S), gmtime;
}

1;
__END__