Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

485 lines (405 sloc) 12.574 kb
package DBIx::Simple::Class;
use 5.010001;
use strict;
use warnings;
use Carp;
use Params::Check;
use DBIx::Simple;
our $VERSION = '1.008';
#CONSTANTS
#defauld debug mode
my $DEBUG = 0;
sub DEBUG { defined $_[1] ? ($DEBUG = $_[1]) : $DEBUG }
#abstract tablename
sub TABLE {
croak("You must define a table-name for your class: sub TABLE {'tablename'}!");
}
#abstract table columns
sub COLUMNS {
croak("You must define fields for your class: sub COLUMNS {['id','name','etc']}!");
}
#Used to validate params to field-setters
#Passed to Params::Check::check()
sub CHECKS {
croak(
"You must define your CHECKS subroutine that returns your private \$_CHECKS HASHREF!"
);
}
sub is_base_class {
no strict 'refs';
return scalar grep { __PACKAGE__ eq $_ } @{"$_[0]\::ISA"};
}
#default where
sub WHERE { {} }
#default primary key
sub PRIMARY_KEY {'id'}
#no default aliases
sub ALIASES { {} }
#should we quote identifiers for a class or not?
sub QUOTE_IDENTIFIERS {
my $class = shift;
state $QUOTE_IDENTIFIERS = {};
return $QUOTE_IDENTIFIERS->{$class} //= shift || '';
}
#Used to store unquoted identifirers as they were before quoting
#See BUILD()
sub _UNQUOTED {
my $class = ref $_[0] || $_[0]; #class
state $UNQUOTED = {};
return $UNQUOTED->{$class} //= {};
}
#for outside modification during tests
my $_attributes_made = {};
sub _attributes_made {$_attributes_made}
#stored generated SQL strings
my $SQL_CACHE = {};
sub _SQL_CACHE {$SQL_CACHE}
my $SQL = {};
$SQL = {
SELECT => sub {
#my $class = shift;
return $SQL_CACHE->{$_[0]}{SELECT} ||= do {
my $where = $_[0]->WHERE;
my $dbh = $_[0]->dbix->dbh;
'SELECT '
. join(',', @{$_[0]->COLUMNS})
. ' FROM '
. $_[0]->TABLE
. (
(keys %$where)
? ' WHERE '
. join(
' AND ', map { "$_=" . $dbh->quote($where->{$_}) }
keys %$where
)
: ''
);
}
},
INSERT => sub {
my $class = $_[0];
#cache this query and return it
return $SQL_CACHE->{$class}{INSERT} ||= do {
my ($pk, $table, @columns) =
($class->PRIMARY_KEY, $class->TABLE, @{$class->COLUMNS});
#return of the do
"INSERT INTO $table ("
. join(',', @columns)
. ') VALUES('
. join(',', map {'?'} @columns) . ')';
};
},
UPDATE => sub {
my $class = $_[0];
#cache this query and return it
return $SQL_CACHE->{$class}{UPDATE} ||= do {
my $pk = $class->PRIMARY_KEY;
#do we always update all columns?!?! Yes, if we always retreive all columns.
my $SET = join(', ', map {qq($/$_=?)} @{$class->COLUMNS});
'UPDATE ' . $class->TABLE . " SET $SET WHERE $pk=%s";
}
},
SELECT_BY_PK => sub {
#my $class = $_[0];
#cache this query and return it
return $SQL_CACHE->{$_[0]}{SELECT_BY_PK} ||= do {
'SELECT '
. join(',', @{$_[0]->COLUMNS})
. ' FROM '
. $_[0]->TABLE
. ' WHERE '
. $_[0]->PRIMARY_KEY . '=?';
};
},
_LIMIT => sub {
#works for MySQL, SQLite, PostgreSQL
#TODO:See SQL::Abstract::Limit for other implementations
#and implement it using this technique.
" LIMIT $_[1]" . ($_[2] ? " OFFSET $_[2] " : '');
},
};
# generate(d) limit clause
sub SQL_LIMIT {
my $_LIMIT = $SQL->{_LIMIT};
return $_LIMIT->(@_);
}
sub SQL {
my ($class, $args) = _get_obj_args(@_); #class
croak('This is a class method. Do not use as object method.') if ref $class;
if (ref $args) { #adding new SQL strings($k=>$v pairs)
return $SQL->{$class} = {%{$SQL->{$class} || $SQL}, %$args};
}
#a key
elsif ($args) {
#do not return hidden keys
croak("Named query '$args' can not be used directly") if $args =~ /^_+/x;
#allow subclasses to override parent sqls and cache produced SQL
my $_SQL =
$SQL_CACHE->{$class}{$args}
|| $SQL->{$class}{$args}
|| $SQL->{$args}
|| $args;
if (ref $_SQL) {
return $_SQL->(@_);
}
else {
return $_SQL;
}
}
#they want all
return $SQL;
}
#ATTRIBUTES
#copy/paste/override this method in your base schema classes
#if you want more instances per application
sub dbix {
# Singleton DBIx::Simple instance
state $DBIx;
return ($_[1] ? ($DBIx = $_[1]) : $DBIx)
|| croak('DBIx::Simple is not instantiated. Please first do '
. $_[0]
. '->dbix(DBIx::Simple->connect($DSN,$u,$p,{...})');
}
sub dbh { $_[0]->dbix->dbh }
#METHODS
sub new {
my ($class, $fields) = _get_obj_args(@_);
local $Params::Check::WARNINGS_FATAL = 1;
local $Params::Check::CALLER_DEPTH = $Params::Check::CALLER_DEPTH + 1;
$fields = Params::Check::check($class->CHECKS, $fields)
|| croak(Params::Check::last_error());
$class->BUILD()
unless $_attributes_made->{$class};
return bless {data => $fields}, $class;
}
sub new_from_dbix_simple {
if (wantarray) {
return (map { bless {data => $_, new_from_dbix_simple => 1}, $_[0]; }
@{$_[1]->{st}->{sth}->fetchall_arrayref({})});
}
return bless {
#$_[1]->hash
data =>
$_[1]->{st}->{sth}->fetchrow_hashref($_[1]->{lc_columns} ? 'NAME_lc' : 'NAME'),
new_from_dbix_simple => 1
},
$_[0];
}
sub select {
my ($class, $where) = _get_obj_args(@_);
$_attributes_made->{$class} || $class->BUILD();
$class->new_from_dbix_simple(
$class->dbix->select($class->TABLE, $class->COLUMNS, {%{$class->WHERE}, %$where}));
}
sub query {
my $class = shift;
$_attributes_made->{$class} || $class->BUILD();
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
return $class->dbix->query(@_) if $class->is_base_class;
$class->new_from_dbix_simple($class->dbix->query(@_));
}
sub select_by_pk {
my ($class, $pk) = @_;
$_attributes_made->{$class} || $class->BUILD();
return $class->new_from_dbix_simple(
$class->dbix->query(
$SQL_CACHE->{$class}{SELECT_BY_PK} || $class->SQL('SELECT_BY_PK'), $pk
)
);
}
{
no warnings qw(once);
*find = \&select_by_pk;
}
sub BUILD {
my $class = shift;
#TODO: Make DEBUG swichable per class
$class->dbh->{Callbacks}{prepare} = sub {
$DEBUG || return;
my ($dbh, $query, $attrs) = @_;
my ($package, $filename, $line, $subroutine) = caller(2);
carp("SQL from $subroutine in $filename:$line :\n$query\n");
return;
};
#
if ($class->is_base_class) {
carp "Nothing more to build. This is the base class: $class" if $DEBUG;
return;
}
(!ref $class)
|| croak("Call this method as $class->BUILD()");
$class->_UNQUOTED->{TABLE} = $class->TABLE;
$class->_UNQUOTED->{WHERE} = {%{$class->WHERE}}; #copy
$class->_UNQUOTED->{COLUMNS} = [@{$class->COLUMNS}]; #copy
my $code = '';
foreach (@{$class->_UNQUOTED->{COLUMNS}}) {
my $alias = $class->ALIASES->{$_} || $_;
croak("You can not use '$alias' as a column name since it is already defined in "
. __PACKAGE__
. '. Please define an \'alias\' for the column to be used as method.')
if __PACKAGE__->can($alias);
next if $class->can($alias); #careful: no redefine
$code = "package $class; use strict;$/use warnings;$/use utf8;$/" unless $code;
$code .= <<"SUB";
sub $alias {
my (\$s,\$v) = \@_;
if(defined \$v){ #setting value
#Not using Params::Check
my \$allow = (\$s->CHECKS->{qq{$_}}?\$s->CHECKS->{qq{$_}}{allow}:'')||'';
if(ref \$allow eq 'CODE'){
\$s->{data}{qq{$_}} = \$allow->(\$v) ? \$v : Carp::croak("$_ is of invalid type");
}
elsif(ref \$allow eq 'Regexp'){
\$s->{data}{qq{$_}} =
\$v =~ \$allow ? \$v : Carp::croak("$_ is of invalid type");
}
elsif(\$allow && !ref \$allow){
\$s->{data}{qq{$_}} =
\$v eq \$allow ? \$v : Carp::croak("$_ is of invalid type");
}
else{
\$s->{data}{qq{$_}} = \$v;
}
#\$s->_check(qq{$_}=>\$v);#Using Params::Check
#make it chainable
return \$s;
}
#getting value
return \$s->{data}{qq{$_}} //= \$s->CHECKS->{qq{$_}}{default}; #getting value
}
SUB
}
my $dbh = $class->dbh;
if ($class->QUOTE_IDENTIFIERS) {
$code
.= 'no warnings qw"redefine";'
. "sub $class\::TABLE {'"
. $dbh->quote_identifier($class->TABLE) . "'}";
my %where = %{$class->WHERE};
$code .= "sub $class\::WHERE {{";
for (keys %where) {
$code
.= 'qq{'
. $dbh->quote_identifier($_)
. '}=>qq{'
. $dbh->quote($where{$_}) . '}, '
. $/;
}
$code .= '}}#end WHERE' . $/;
my @columns = @{$class->COLUMNS};
$code .= "sub $class\::COLUMNS {[";
for (@columns) {
$code .= 'qq{' . $dbh->quote_identifier($_) . '},';
}
$code .= ']}#end COLUMNS' . $/;
} #if ($class->QUOTE_IDENTIFIERS)
$code .= "$/1;";
#I know what I am doing. I think so...
unless (eval $code) { ##no critic (BuiltinFunctions::ProhibitStringyEval)
croak($class . " compiler error: $/$code$/$@$/");
}
if ($class->DEBUG) {
carp($class . " generated accessors: $/$code$/$@$/");
}
#make sure we die loudly
$dbh->{RaiseError} = 1;
return $_attributes_made->{$class} = 1;
}
#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/
Jump to Line
Something went wrong with that request. Please try again.