ClearPress::model - a base class for the data-model of the ClearPress MVC family

 use strict;
 use warning;
 use base qw(ClearPress::model);

 __PACKAGE__->mk_accessors(__PACKAGE__->fields());

 sub fields { return qw(...); }

  my @aFields = $oModel->fields();
  my @aFields = __PACKAGE__->fields();

  my $sPrimaryKey = $oModel->primary_key();

  my $sSecondaryKey = $oModel->secondary_key();

  my $sTableName = $oModel->table();

  my $oInstance = ClearPress::model::subclass->new();

  also supports creation with a hashref of key:values and creation
  with a scalar primary key, e.g.

  my $oInstance = ClearPress::model::subclass->new({id_subclass => 10});

  my $oInstance = ClearPress::model::subclass->new(10);

  my $oUtil = ClearPress::model::subclass->util();

  my $oUtil = $oInstance->util();

 Invokes $self->read() if necessary.

 my $sFieldValue = $oModel->get($sFieldName);

  my $arObjects = $oModel->gen_getarray('ClearPress::model::subclass',
                                        q(SELECT a,b,c FROM x,y WHERE x.d=? AND y.e=?),
                                        @bind_params);

  my $arObjects = $oModel->gen_getall();
  my $arObjects = $oModel->gen_getall('ClearPress::otherclass');

  my $oObj = $self->gen_getobj($sClass);

  my $arObjects = $oModel->gen_getfriends($sClass);
  my $arObjects = $oModel->gen_getfriends($sClass, $sCacheKey);

  my $arObjects = $oModel->gen_getfriends($sClass, $sJoinTable);
  my $arObjects = $oModel->gen_getfriends($sClass, $sJoinTable, $sCacheKey);

  my $oRelative = $oModel->gen_getobj_through($sClass, $sJoinTable);
  my $oRelative = $oModel->gen_getobj_through($sClass, $sJoinTable, $sCacheKey);

  __PACKAGE__->has_a('my::pkg');
  __PACKAGE__->has_a(['my::pkg1', 'my::pkg2']);
  __PACKAGE__->has_a({method => 'my::fieldpkg'});
  __PACKAGE__->has_a([{method_one => 'my::pkg1'},
                      {method_two => 'my::pkg2'});

  __PACKAGE__->has_many('my::pkg');

 If my::pkg has a table of "package" then this creates a method "sub
 packages" in $self, yielding an arrayref of my::pkg objects related
 by the primary_key of $self.

  __PACKAGE__->has_many(['my::pkg1', 'my::pkg2']);

 Define multiple relationships together.




  __PACKAGE__->has_many({method => 'my::fieldpkg'});

 Defines a method "sub methods" in $self yielding an arrayref of
 my::fieldpkg objects related by the primary_key of $self.

  __PACKAGE__->has_many([{method_one => 'my::pkg1'},
                         {method_two => 'my::pkg2'});

 Defines multiple relationships with overridden method names.

  Define a 'users' method in this class which fetches users like so:

    SELECT u.id_user, u.foo, u.bar
    FROM   user f, centre_user t
    WHERE  t.id_this = ?           # the primary_key for $self's class
    AND    t.id_user = f.id_user   # the primary_key for friend 'user'

  __PACKAGE__->has_many_through(['user|centre_user']);

  __PACKAGE__->has_a_through(['user|friend', 'user|enemy']);

  __PACKAGE__->has_all();

  $oModel->create();

  $oModel->load();

  $oModel->update();

  $oModel->delete();

  $oModel->save();

  my $sZuluTime = $oModel->zdate();

  my $sISODate = $oModel->isodate();

  my $sJSON = $oModel->as_json();

  my $oXML = $oModel->as_xml();

#########
# Author:        rmp
# Maintainer:    $Author: zerojinx $
# Created:       2006-10-31
# Last Modified: $Date: 2010-12-01 11:49:57 +0000 (Wed, 01 Dec 2010) $
# Id:            $Id: model.pm 398 2010-12-01 11:49:57Z zerojinx $
# Source:        $Source: /cvsroot/clearpress/clearpress/lib/ClearPress/model.pm,v $
# $HeadURL: https://clearpress.svn.sourceforge.net/svnroot/clearpress/trunk/lib/ClearPress/model.pm $
#
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 POSIX qw(strftime);
use Readonly;

our $VERSION = do { my ($r) = q$Revision: 398 $ =~ /(\d+)/smx; $r; };
Readonly::Scalar our $DBI_CACHE_OVERWRITE => 3;

sub fields { return (); }

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+/\ /ssmxg;
    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   = PL($cachekey);
  }

  if(!$self->{$cachekey}) {
    my $sortk = $self->secondary_key;
    if(!$sortk) {
      $sortk = $self->primary_key;
    }
    my $query = qq[/* model::gen_getall */
                                      SELECT   @{[join q(, ), $class->fields()]}
                                      FROM     @{[$class->table()]}
                                      ORDER BY $sortk];
    $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   = PL($cachekey);
  }

  if(!$self->{$cachekey}) {
    my $link  = $self->primary_key();
    my $query = qq[/* model::gen_getfriends */
                                      SELECT   @{[join q(, ), $class->fields()]}
                                      FROM     @{[$class->table()]}
                                      WHERE    $link=?
                                      ORDER BY $link];
    $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   = PL($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 = qq[/* 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];
    $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 = qq[/* 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]; # there should only ever be one of these
    $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    = PL($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    = PL($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    = PL($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 = qq(INSERT INTO $table (@{[join q(, ), $self->fields()]})
                                  VALUES (@{[join q(, ), map { q(?) } $self->fields()]}));
  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();

  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 = qq[/* model::read */
                                    SELECT @{[join q(, ), $self->fields()]}
                                    FROM   $table
                                    WHERE  $pk=?];
      @args = ($self->{$pk});
    }

    eval {
      my $sth = $self->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();

      for my $f ($self->fields()) {
	$self->{$f} = $ref->{$f};
      }

      $sth->finish();
      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   = qq(UPDATE @{[$self->table()]}
                                      SET    @{[join q(, ),
                                                                    map  { qq[$_ = ?] }
                                                                    @fields]}
                                      WHERE  $pk=?);

  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 = qq(DELETE FROM @{[$self->table()]}
                                  WHERE $pk=?);
  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__