package DBIx::NinjaORM;
use 5.010;
use warnings;
use strict;
use Carp;
use Data::Dumper;
use Data::Validate::Type;
use Digest::SHA1 qw();
use MIME::Base64 qw();
use Storable;
use Try::Tiny;
use Log::Any qw( $log );
=head1 NAME
DBIx::NinjaORM - Flexible Perl ORM for easy transitions from inline SQL to objects.
=head1 VERSION
Version 2.3.1
=cut
our $VERSION = '2.3.1';
=head1 DESCRIPTION
Caveat: if you're starting a new project, L<DBIx::NinjaORM> is probably not the
right ORM to use. Look instead at L<DBIx::Class> for example, which has a more
abstract model and can leverage a nicely normalized database schema.
L<DBIx::NinjaORM> was designed with a few goals in mind:
=over 4
=item *
Allow a progressive introduction of a separate Model layer in a legacy codebase.
=item *
Expand objects with data joined from other tables, to do less queries and
prevent lazy-loading of ancillary information.
=item *
Have a short learning curve.
=back
=head1 SYNOPSIS
=head2 Simple example
Let's take the example of a C<My::Model::Book> class that represents a book. You
would start C<My::Model::Book> with the following code:
package My::Model::Book;
use strict;
use warnings;
use base 'DBIx::NinjaORM';
use DBI;
sub static_class_info
{
my ( $class ) = @_;
# Retrieve defaults from DBIx::Ninja->static_class_info().
my $info = $class->SUPER::static_class_info();
# Set mandatory defaults.
$info->{'table_name'} = 'books';
$info->{'primary_key_name'} = 'book_id';
$info->{'default_dbh'} = DBI->connect(
"dbi:mysql:[database_name]:localhost:3306",
"[user]",
"[password]",
);
# Add optional information.
# Allow filtering SELECTs on books.name.
$info->{'filtering_fields'} = [ 'name' ];
return $info;
}
1;
Inheriting with C<use base 'DBIx::NinjaORM'> and creating
C<sub static_class_info> (with a default database handle and a table name)
are the only two requirements to have a working model.
=head2 A more complex model
If you have more than one Model class to create, for example C<My::Model::Book>
and C<My::Model::Library>, you probably want to create a single class
C<My::Model> to hold the defaults and then inherits from that main class.
package My::Model;
use strict;
use warnings;
use base 'DBIx::NinjaORM';
use DBI;
use Cache::Memcached::Fast;
sub static_class_info
{
my ( $class ) = @_;
# Retrieve defaults from DBIx::Ninja->static_class_info().
my $info = $class->SUPER::static_class_info();
# Set defaults common to all your objects.
$info->{'default_dbh'} = DBI->connect(
"dbi:mysql:[database_name]:localhost:3306",
"[user]",
"[password]",
);
$info->{'memcache'} = Cache::Memcached::Fast->new(
{
servers =>
[
'localhost:11211',
],
}
);
return $info;
}
1;
The various classes will then inherit from C<My::Model>, and the inherited
defaults will make C<static_class_info()> shorter in the other classes:
package My::Model::Book;
use strict;
use warnings;
# Inherit from your base model class, not from DBIx::NinjaORM.
use base 'My::Model';
sub static_class_info
{
my ( $class ) = @_;
# Retrieve defaults from My::Model.
my $info = $class->SUPER::static_class_info();
# Set mandatory defaults for this class.
$info->{'table_name'} = 'books';
$info->{'primary_key_name'} = 'book_id';
# Add optional information.
# Allow filtering SELECTs on books.name.
$info->{'filtering_fields'} = [ 'name' ];
return $info;
}
1;
=cut
our $RETRIEVE_LIST_VALID_ARGUMENTS =
{
map { $_ => 1 }
qw(
allow_all
dbh
limit
lock
order_by
pagination
query_extensions
show_queries
skip_cache
)
};
=head1 SUPPORTED DATABASES
This distribution currently supports:
=over 4
=item * SQLite
=item * MySQL
=item * PostgreSQL
=back
Please contact me if you need support for another database type, I'm always
glad to add extensions if you can help me with testing.
=head1 SUBCLASSABLE METHODS
L<DBIx::NinjaORM> is designed with inheritance in mind, and you can subclass
most of its public methods to extend or alter its behavior.
This group of method covers the most commonly subclassed methods, with examples
and use cases.
=head2 clone()
Clone the current object and return the clone.
my $cloned_book = $book->clone();
=cut
sub clone
{
my ( $self ) = @_;
return Storable::dclone( $self );
}
=head2 commit()
Convenience function to insert or update the object.
If the object has a primary key set, C<update()> is called, otherwise
C<insert()> is called. If there's an error, the method with croak with
relevant error information.
$book->commit();
Arguments: (none).
=cut
sub commit
{
my ( $self ) = @_;
my $data = Storable::dclone( $self );
if ( defined( $self->id() ) )
{
my $primary_key_name = $self->get_primary_key_name();
delete( $data->{ $primary_key_name } )
if exists( $data->{ $primary_key_name } );
return $self->update( $data );
}
else
{
return $self->insert( $data );
}
}
=head2 get()
Get the value corresponding to an object's field.
my $book_name = $book->get('name');
This method will croak if you attempt to retrieve a private field. It also
detects if the object was retrieved from the database, in which case it
has an exhaustive list of the fields that actually exist in the database and
it will croak if you attempt to retrieve a field that doesn't exist in the
database.
=cut
sub get
{
my ( $self, $field_name ) = @_;
croak "The name of the field to retrieve must be defined"
if !defined( $field_name ) || ( $field_name eq '' );
# Create your own accessor for private properties.
croak 'Cannot retrieve the value of a private object property, create an accessor on the class if you need this value'
if substr( $field_name, 0, 1 ) eq '_';
# If the object was not populated by retrieve_list(), we know that the keys
# on the object correspond to all the columns in the database and we can then
# actively show errors in the log if the caller is requesting a field for
# which the key doesn't exist.
my $populated_by_retrieve_list = $self->{'_populated_by_retrieve_list'} // 0;
croak "The property '$field_name' does not exist on the object"
if $populated_by_retrieve_list && !exists( $self->{ $field_name } );
return $self->{ $field_name };
}
=head2 insert()
Insert a row corresponding to the data passed as first parameter, and fill the
object accordingly upon success.
my $book = My::Model::Book->new();
$book->insert(
{
name => 'Learning Perl',
}
);
If you don't need the object afterwards, you can simply do:
My::Model::Book->insert(
{
name => 'Learning Perl',
}
);
This method supports the following optional arguments:
=over 4
=item * overwrite_created
A UNIX timestamp to be used instead of the current time for the value of
'created'.
=item * generated_primary_key_value
A primary key value, in case the underlying table doesn't have an
autoincremented primary key.
=item * dbh
A different database handle than the default one specified in
C<static_class_info()>, but it has to be writable.
=item * ignore
INSERT IGNORE instead of plain INSERT.
=back
$book->insert(
\%data,
overwrite_created => $unixtime,
generated_primary_key_value => $value,
dbh => $dbh,
ignore => $boolean,
);
=cut
sub insert ## no critic (Subroutines::RequireArgUnpacking)
{
croak 'The first argument passed must be a hashref'
if !Data::Validate::Type::is_hashref( $_[1] );
my ( $self, $data, %args ) = @_;
# Allows calling Module->insert() if we don't need the object afterwards.
# In this case, we turn $self from a class into an object.
$self = $self->new()
if !ref( $self );
# Allow using a different database handle.
my $dbh = $self->assert_dbh( $args{'dbh'} );
# Clean input.
my $clean_data = $self->validate_data( $data, %args );
return 0
if !defined( $clean_data );
# Retrieve the metadata for that table.
my $class = ref( $self );
my $table_name = $self->get_table_name();
croak "The table name for class '$class' is not defined"
if !defined( $table_name );
my $primary_key_name = $self->get_primary_key_name();
croak "Missing primary key name for class '$class', cannot force primary key value"
if !defined( $primary_key_name ) && defined( $args{'generated_primary_key_value'} );
# Set defaults.
if ( $self->has_created_field() )
{
$clean_data->{'created'} = defined( $args{'overwrite_created'} ) && $args{'overwrite_created'} =~ m/^\d+$/
? $args{'overwrite_created'}
: time();
}
$clean_data->{'modified'} = time()
if $self->has_modified_field();
$clean_data->{ $primary_key_name } = $args{'generated_primary_key_value'}
if defined( $args{'generated_primary_key_value'} );
# Prepare the query elements.
my $ignore = defined( $args{'ignore'} ) && $args{'ignore'} ? 1 : 0;
my @insert_fields = ();
my @insert_values = ();
foreach my $key ( keys %$clean_data )
{
push( @insert_fields, $key );
push( @insert_values, $clean_data->{ $key } );
}
my $query = sprintf(
q|
INSERT %s INTO %s( %s )
VALUES ( %s )
|,
$ignore ? 'IGNORE' : '',
$dbh->quote_identifier( $table_name ),
join( ', ', @insert_fields ),
join( ', ', ( ( '?' ) x scalar( @insert_fields ) ) ),
);
# Insert.
try
{
local $dbh->{'RaiseError'} = 1;
$dbh->do(
$query,
{},
@insert_values,
);
}
catch
{
$log->fatalf(
"Could not insert row: %s\nQuery: %s\nValues: %s",
$_,
$query,
\@insert_values,
);
croak "Insert failed: $_";
};
if ( defined( $primary_key_name ) )
{
$clean_data->{ $primary_key_name } = defined( $args{'generated_primary_key_value'} )
? $args{'generated_primary_key_value'}
: $dbh->last_insert_id( undef, undef, $table_name, $primary_key_name );
}
# Check that the object was correctly inserted.
croak "Could not insert into table '$table_name': " . Dumper( $data )
if defined( $primary_key_name ) && !defined( $clean_data->{ $primary_key_name } );
# Make sure that the object reflects the changes in the database.
$self->set(
$clean_data,
force => 1,
);
return;
}
=head2 new()
C<new()> has two possible uses:
=over 4
=item * Creating a new empty object
my $object = My::Model::Book->new();
=item * Retrieving a single object from the database.
# Retrieve by ID.
my $object = My::Model::Book->new( { id => 3 } )
// die 'Book #3 does not exist';
# Retrieve by unique field.
my $object = My::Model::Book->new( { isbn => '9781449303587' } )
// die 'Book with ISBN 9781449303587 does not exist';
=back
When retrieving a single object from the database, the first argument should be
a hashref containing the following information to select a single row:
=over 4
=item * id
The ID for the primary key on the underlying table. C<id> is an alias for the
primary key field name.
my $object = My::Model::Book->new( { id => 3 } )
// die 'Book #3 does not exist';
=item * A unique field
Allows passing a unique field and its value, in order to load the
corresponding object from the database.
my $object = My::Model::Book->new( { isbn => '9781449303587' } )
// die 'Book with ISBN 9781449303587 does not exist';
Note that unique fields need to be defined in C<static_class_info()>, in the
C<unique_fields> key.
=back
This method also supports the following optional arguments, passed in a hash
after the filtering criteria above-mentioned:
=over 4
=item * skip_cache (default: 0)
By default, if cache is enabled with C<object_cache_time()> in
C<static_class_info()>, then C<new> attempts to load the object from the cache
first. Setting C<skip_cache> to 1 forces the ORM to load the values from the
database.
my $object = My::Model::Book->new(
{ isbn => '9781449303587' },
skip_cache => 1,
) // die 'Book with ISBN 9781449303587 does not exist';
=item * lock (default: 0)
By default, the underlying row is not locked when retrieving an object via
C<new()>. Setting C<lock> to 1 forces the ORM to bypass the cache if any, and
to lock the rows in the database as it retrieves them.
my $object = My::Model::Book->new(
{ isbn => '9781449303587' },
lock => 1,
) // die 'Book with ISBN 9781449303587 does not exist';
=back
=cut
sub new
{
my ( $class, $filters, %args ) = @_;
# If filters exist, they need to be a hashref.
croak 'The first argument must be a hashref containing filtering criteria'
if defined( $filters ) && !Data::Validate::Type::is_hashref( $filters );
# Check if we have a unique identifier passed.
# Note: passing an ID is a subcase of passing field defined as unique, but
# unique_fields() doesn't include the primary key name.
my $unique_field;
foreach my $field ( 'id', @{ $class->get_unique_fields() } )
{
next
if ! exists( $filters->{ $field } );
# If the field exists in the list of filters, it needs to be
# defined. Being undefined probably indicates a problem in the calling code.
croak "Called new() with '$field' declared but not defined"
if ! defined( $filters->{ $field } );
# Detect if we're passing two unique fields to retrieve the object. This is
# obviously bad.
croak "Called new() with the unique argument '$field', but already found another unique argument '$unique_field'"
if defined( $unique_field );
$unique_field = $field;
}
# Retrieve the object.
my $self;
if ( defined( $unique_field ) )
{
my $objects = $class->retrieve_list(
{
$unique_field => $filters->{ $unique_field },
},
skip_cache => $args{'skip_cache'},
lock => $args{'lock'} ? 1 : 0,
);
my $objects_count = scalar( @$objects );
if ( $objects_count == 0 )
{
# No row found.
$self = undef;
}
elsif ( $objects_count == 1 )
{
$self = $objects->[0];
}
else
{
croak "Called new() with a set of non-unique arguments that returned $objects_count objects: " . Dumper( \%args );
}
}
else
{
$self = bless( {}, $class );
}
return $self;
}
=head2 remove()
Delete in the database the row corresponding to the current object.
$book->remove();
This method accepts the following arguments:
=over 4
=item * dbh
A different database handle from the default specified in C<static_class_info()>.
This is particularly useful if you have separate reader/writer databases.
=back
=cut
sub remove
{
my ( $self, %args ) = @_;
# Retrieve the metadata for that table.
my $class = ref( $self );
my $table_name = $self->get_table_name();
croak "The table name for class '$class' is not defined"
if ! defined( $table_name );
my $primary_key_name = $self->get_primary_key_name();
croak "Missing primary key name for class '$class', cannot delete safely"
if !defined( $primary_key_name );
croak "The object of class '$class' does not have a primary key value, cannot delete"
if ! defined( $self->id() );
# Allow using a different DB handle.
my $dbh = $self->assert_dbh( $args{'dbh'} );
# Prepare the query.
my $query = sprintf(
q|
DELETE
FROM %s
WHERE %s = ?
|,
$dbh->quote_identifier( $table_name ),
$dbh->quote_identifier( $primary_key_name ),
);
my @query_values = ( $self->id() );
# Delete the row.
try
{
local $dbh->{'RaiseError'} = 1;
$dbh->do(
$query,
{},
@query_values,
);
}
catch
{
$log->fatalf(
"Could not delete row: %s\nQuery: %s\nValues: %s",
$_,
$query,
\@query_values,
);
croak "Failed delete: $_";
};
return;
}
=head2 retrieve_list_nocache()
Dispatch of retrieve_list() when objects should not be retrieved from the cache.
See C<retrieve_list()> for the parameters this method accepts.
=cut
sub retrieve_list_nocache ## no critic (Subroutines::ProhibitExcessComplexity)
{
my ( $class, $filters, %args ) = @_;
# Handle a different database handle, if requested.
my $dbh = $class->assert_dbh( $args{'dbh'} );
# TODO: If we're asked to lock the rows, we check that we're in a transaction.
# Check if we were passed arguments we don't know how to handle. This will
# help the calling code to detect typos or deprecated arguments.
foreach my $arg ( keys %args )
{
next if defined( $RETRIEVE_LIST_VALID_ARGUMENTS->{ $arg } );
croak(
"The argument '$arg' passed to DBIx::NinjaORM->retrieve_list() via " .
"${class}->retrieve_list() is not handled by the superclass. " .
"It could mean that you have a typo in the name or that the argument has " .
"been deprecated."
);
}
# Check the parameters and prepare the corresponding where clauses.
my $where_clauses = $args{'query_extensions'}->{'where_clauses'} || [];
my $where_values = $args{'query_extensions'}->{'where_values'} || [];
my $filtering_field_keys_passed = 0;
my $filtering_criteria = $class->parse_filtering_criteria(
$filters
);
if ( defined( $filtering_criteria ) )
{
push( @$where_clauses, @{ $filtering_criteria->[0] || [] } );
push( @$where_values, @{ $filtering_criteria->[1] || [] } );
$filtering_field_keys_passed = $filtering_criteria->[2];
}
# Make sure there's at least one argument, unless allow_all=1 or there is
# custom where clauses.
croak 'At least one argument must be passed'
if !$args{'allow_all'} && !$filtering_field_keys_passed && scalar( @$where_clauses ) == 0;
# Prepare the ORDER BY.
my $table_name = $class->get_table_name();
my $order_by = defined( $args{'order_by'} ) && ( $args{'order_by'} ne '' )
? "ORDER BY $args{'order_by'}"
: "ORDER BY " . $dbh->quote_identifier( $table_name ) . ".created ASC";
# Prepare the SQL request elements.
my $where = scalar( @$where_clauses ) != 0
? 'WHERE ( ' . join( ' ) AND ( ', @$where_clauses ) . ' )'
: '';
my $joins = $args{'query_extensions'}->{'joins'} || '';
my $fields = $dbh->quote_identifier( $table_name ) . '.*';
$fields .= defined( $args{'query_extensions'}->{'joined_fields'} )
? ', ' . $args{'query_extensions'}->{'joined_fields'}
: '';
my $limit = defined( $args{'limit'} ) && ( $args{'limit'} =~ m/^\d+$/ )
? 'LIMIT ' . $args{'limit'}
: '';
# We need to make an exception for lock=1 when using SQLite, since
# SQLite doesn't support FOR UPDATE.
# Per http://sqlite.org/cvstrac/wiki?p=UnsupportedSql, the entire
# database is locked when updating any bit of it, so we can simply
# ignore the locking request here.
my $lock = '';
if ( $args{'lock'} )
{
my $database_type = $dbh->{'Driver'}->{'Name'} || '';
if ( $database_type eq 'SQLite' )
{
$log->info(
'SQLite does not support locking since only one process at a time is ',
'allowed to update a given SQLite database, so lock=1 is ignored.',
);
}
else
{
$lock = 'FOR UPDATE';
}
}
# Prepare quoted identifiers.
my $primary_key_name = $class->get_primary_key_name();
my $quoted_primary_key_name = $dbh->quote_identifier( $primary_key_name );
my $quoted_table_name = $dbh->quote_identifier( $table_name );
# Check if we need to paginate.
my $pagination_info = {};
if ( defined( $args{'pagination'} ) )
{
# Allow for pagination => 1 as a shortcut to get all the defaults.
$args{'pagination'} = {}
if !Data::Validate::Type::is_hashref( $args{'pagination'} ) && ( $args{'pagination'} eq '1' );
# Set defaults.
$pagination_info->{'per_page'} = ( $args{'pagination'}->{'per_page'} || '' ) =~ m/^\d+$/
? $args{'pagination'}->{'per_page'}
: 20;
# Count the total number of results.
my $count_data = $dbh->selectrow_arrayref(
sprintf(
q|
SELECT COUNT(*)
FROM %s
%s
%s
|,
$quoted_table_name,
$joins,
$where,
),
{},
map { @$_ } @$where_values,
);
$pagination_info->{'total_count'} = defined( $count_data ) && scalar( @$count_data ) != 0
? $count_data->[0]
: undef;
# Calculate what the max page can be.
$pagination_info->{'page_max'} = int( ( $pagination_info->{'total_count'} - 1 ) / $pagination_info->{'per_page'} ) + 1;
# Determine what the current page is.
$pagination_info->{'page'} = ( ( $args{'pagination'}->{'page'} || '' ) =~ m/^\d+$/ ) && ( $args{'pagination'}->{'page'} > 0 )
? $pagination_info->{'page_max'} < $args{'pagination'}->{'page'}
? $pagination_info->{'page_max'}
: $args{'pagination'}->{'page'}
: 1;
# Set LIMIT and OFFSET.
$limit = "LIMIT $pagination_info->{'per_page'} "
. 'OFFSET ' . ( ( $pagination_info->{'page'} - 1 ) * $pagination_info->{'per_page'} );
}
# If we need to lock the rows and there's joins, let's do this in two steps:
# 1) Lock the rows without join.
# 2) Using the IDs found, do another select to retrieve the data with the joins.
if ( ( $lock ne '' ) && ( $joins ne '' ) )
{
my $query = sprintf(
q|
SELECT %s
FROM %s
%s
ORDER BY %s ASC
%s
%s
|,
$quoted_primary_key_name,
$quoted_table_name,
$where,
$quoted_primary_key_name,
$limit,
$lock,
);
my @query_values = map { @$_ } @$where_values;
$log->debugf(
"Performing pre-locking query:\n%s\nValues:\n%s",
$query,
\@query_values,
) if $args{'show_queries'};
my $locked_ids;
try
{
local $dbh->{'RaiseError'} = 1;
$locked_ids = $dbh->selectall_arrayref(
$query,
{
Columns => [ 1 ],
},
@query_values
);
}
catch
{
$log->fatalf(
"Could not select rows in pre-locking query: %s\nQuery: %s\nValues:\n%s",
$_,
$query,
\@query_values,
);
croak "Failed select: $_";
};
if ( !defined( $locked_ids ) || ( scalar( @$locked_ids ) == 0 ) )
{
return [];
}
$where = sprintf(
'WHERE %s.%s IN ( %s )',
$quoted_table_name,
$quoted_primary_key_name,
join( ', ', ( ('?') x scalar( @$locked_ids ) ) ),
);
$where_values = [ [ map { $_->[0] } @$locked_ids ] ];
$lock = '';
}
# Prepare the query elements.
my $query = sprintf(
q|
SELECT %s
FROM %s
%s %s %s %s %s
|,
$fields,
$quoted_table_name,
$joins,
$where,
$order_by,
$limit,
$lock,
);
my @query_values = map { @$_ } @$where_values;
$log->debugf(
"Performing query:\n%s\nValues:\n%s",
$query,
\@query_values,
) if $args{'show_queries'};
# Retrieve the objects.
my $sth;
try
{
local $dbh->{'RaiseError'} = 1;
$sth = $dbh->prepare( $query );
$sth->execute( @query_values );
}
catch
{
$log->fatalf(
"Could not select rows: %s\nQuery: %s\nValues: %s",
$_,
$query,
\@query_values,
);
croak "Failed select: $_";
};
my $object_list = [];
while ( my $ref = $sth->fetchrow_hashref() )
{
my $object = Storable::dclone( $ref );
bless( $object, $class );
$object->reorganize_non_native_fields();
# Add a flag to distinguish objects that were populated via
# retrieve_list_nocache(), as those objects are known for sure to contain
# all the keys for columns that exist in the database. We also won't have to
# worry about missing defaults, like insert() would have to.
$object->{'_populated_by_retrieve_list'} = 1;
# Add cache debugging information.
$object->{'_debug'}->{'list_cache_used'} = 0;
$object->{'_debug'}->{'object_cache_used'} = 0;
push( @$object_list, $object );
}
if ( wantarray && defined( $args{'pagination'} ) )
{
return ( $object_list, $pagination_info );
}
else
{
return $object_list;
}
}
=head2 set()
Set fields and values on an object.
$book->set(
{
name => 'Learning Perl',
isbn => '9781449303587',
},
);
This method supports the following arguments:
=over 4
=item * force
Set the properties on the object without going through C<validate_data()>.
$book->set(
{
name => 'Learning Perl',
isbn => '9781449303587',
},
force => 1,
);
=back
=cut
sub set ## no critic (NamingConventions::ProhibitAmbiguousNames, Subroutines::RequireArgUnpacking)
{
croak 'The first argument passed must be a hashref'
if !Data::Validate::Type::is_hashref( $_[1] );
my ( $self, $data, %args ) = @_;
# Validate the data first, unless force=1.
$data = $self->validate_data( $data )
if !$args{'force'};
# Update the object.
foreach ( keys %$data )
{
$self->{ $_ } = $data->{ $_ };
}
return;
}
=head2 static_class_info()
This methods sets defaults as well as general information for a specific class.
It allows for example indicating what table the objects will be related to, or
what database handle to use.
Here's what a typical subclassed C<static_class_info()> would look like:
sub static_class_info
{
my ( $class ) = @_;
# Retrieve defaults coming from higher in the inheritance chain, up
# to DBIx::NinjaORM->static_class_info().
my $info = $class->SUPER::static_class_info();
# Set or override information.
$info->{'table_name'} = 'books';
$info->{'primary_key_name'} = 'book_id';
$info->{'default_dbh'} = DBI->connect(
"dbi:mysql:[database_name]:localhost:3306",
"[user]",
"[password]",
);
# Return the updated information hashref.
return $info;
}
Here's the full list of the options that can be set or overridden:
=over 4
=item * default_dbh
The database handle to use when performing queries. The methods that interact
with the database always provide a C<dbh> argument to allow using a specific
database handle, but setting it here means you won't have to systematically
pass that argument.
$info->{'default_dbh'} = DBI->connect(
"dbi:mysql:[database_name]:localhost:3306",
"[user]",
"[password]",
);
=item * memcache
Optionally, C<DBIx::NinjaORM> uses memcache to cache objects and queries,
in conjunction with the C<list_cache_time> and C<object_cache_time> arguments.
If you want to enable the cache features, you can set this to a valid
C<Cache::Memcached> object (or a compatible module, such as
C<Cache::Memcached::Fast>).
$info->{'memcache'} = Cache::Memcached::Fast->new(
{
servers =>
[
'localhost:11211',
],
}
);
=item * table_name
Mandatory, the name of the table that this class will be the interface for.
# Interface with a 'books' table.
$info->{'table_name'} = 'books';
=item * primary_key_name
The name of the primary key on the table specified with C<table_name>.
$info->{'primary_key_name'} = 'book_id';
=item * list_cache_time
Control the list cache, which is an optional cache system in
C<retrieve_list()> to store how search criteria translate into object IDs.
By default it is disabled (with C<undef>), but it is activated by setting it to
an integer that represents the cache time in seconds.
# Cache for 10 seconds.
$info->{'list_cache_time'} = 10;
# Don't cache.
$info->{'list_cache_time'} = undef;
A good use case for this would be retrieving a list of books for a given author.
We would pass the author ID as a search criteria, and the resulting list of book
objects does not change often. Provided that you can tolerate a 1 hour delay
for a new book to show up associated with a given author, then it makes sense
to set the list_cache_time to 3600 and save most of the queries to find what
book otherwise belongs to the author.
=item * object_cache_time
Control the object cache, which is an optional cache system in
C<retrieve_list()> to store the objects returned and be able to look them up
by object ID.
By default it is disabled (with C<undef>), but it is activated by setting it to
an integer that represents the cache time in seconds.
# Cache for 10 seconds.
$info->{'object_cache_time'} = 10;
# Don't cache.
$info->{'object_cache_time'} = undef;
A good use case for this are objects that are expensive to build. You will see
more in C<retrieve_list()> on how to cache objects.
=item * unique_fields
The list of unique fields on the object.
Note: L<DBIx::NinjaORM> does not support unique indexes made of more than one
field. If you add more than one field in this arrayref, the ORM will treat them
as separate unique indexes.
# Declare books.isbn as unique.
$info->{'unique_fields'} = [ 'isbn' ];
# Declare books.isbn and books.upc as unique.
$info->{'unique_fields'} = [ 'isbn', 'upc' ];
=item * filtering_fields
The list of fields that can be used to filter on in C<retrieve_list()>.
# Allow filtering based on the book name and author ID.
$info->{'unique_fields'} = [ 'name', 'author_id' ];
=item * readonly_fields
The list of fields that cannot be set directly. They will be populated in
C<retrieve_list>, but you won't be able to insert / update / set them directly.
=item * has_created_field
Indicate whether the table has a field name C<created> to store the UNIX time
at which the row was created. Default: 1.
# The table doesn't have a 'created' field.
$info->{'has_created_field'} = 0;
=item * has_modified_field
Indicate whether the table has a field name C<modified> to store the UNIX time
at which the row was modified. Default: 1.
# The table doesn't have a 'modified' field.
$info->{'has_modified_field'} = 0;
=item * cache_key_field
By default, the object cache uses the primary key value to make cached objects
available to look up, but this allows specifying a different field for that
purpose.
For example, you may want to use books.isbn instead of books.book_id to cache
objects:
$info->{'cache_key_field'} = 'isbn';
=item * verbose
Add debugging and tracing information, 0 by default.
# Show debugging information for operations on this class.
$info->{'verbose'} = 1;
=item * verbose_cache_operations
Add information in the logs regarding cache operations and uses.
=back
=cut
sub static_class_info
{
return
{
'default_dbh' => undef,
'memcache' => undef,
'table_name' => undef,
'primary_key_name' => undef,
'list_cache_time' => undef,
'object_cache_time' => undef,
'unique_fields' => [],
'filtering_fields' => [],
'readonly_fields' => [],
'has_created_field' => 1,
'has_modified_field' => 1,
'cache_key_field' => undef,
'verbose' => 0,
'verbose_cache_operations' => 0,
};
}
=head2 update()
Update the row in the database corresponding to the current object, using the
primary key and its value on the object.
$book->update(
{
name => 'Learning Perl',
}
);
This method supports the following optional arguments:
=over 4
=item * skip_modified_update (default 0)
Do not update the 'modified' field. This is useful if you're using 'modified' to
record when was the last time a human changed the row, but you want to exclude
automated changes.
=item * dbh
A different database handle than the default one specified in
C<static_class_info()>, but it has to be writable.
=item * restrictions
The update statement is limited using the primary key. This parameter however
allows adding extra restrictions on the update. Additional clauses passed here
are joined with AND.
$book->update(
{
author_id => 1234,
},
restrictions =>
{
where_clauses => [ 'status != ?' ],
where_values => [ 'protected' ],
},
);
=item * set
\%data contains the data to update the row with "SET field = value". It is
however sometimes necessary to use more complex SETs, such as
"SET field = field + value", which is what this parameter allows.
Important: you will need to subclass C<update()> in your model classes and
update manually the values upon success (or reload the object), as
L<DBIx::NinjaORM> cannot determine the end result of those complex sets on the
database side.
$book->update(
{
name => 'Learning Perl',
},
set =>
{
placeholders => [ 'edits = edits + ?' ],
values => [ 1 ],
}
);
=back
=cut
sub update ## no critic (Subroutines::RequireArgUnpacking)
{
croak 'The first argument passed must be a hashref'
if !Data::Validate::Type::is_hashref( $_[1] );
my ( $self, $data, %args ) = @_;
# Allow using a different DB handle.
my $dbh = $self->assert_dbh( $args{'dbh'} );
# Clean input
my $clean_data = $self->validate_data( $data, %args );
return 0
if !defined( $clean_data );
# Set defaults
$clean_data->{'modified'} = time()
if !$args{'skip_modified_update'} && $self->has_modified_field();
# If there's nothing to update, bail out.
if ( scalar( keys %$clean_data ) == 0 )
{
$log->debug( 'No data left to update after validation, skipping SQL update' )
if $self->is_verbose();
return;
}
# Retrieve the meta-data for that table.
my $class = ref( $self );
my $table_name = $self->get_table_name();
croak "The table name for class '$class' is not defined"
if ! defined( $table_name );
my $primary_key_name = $self->get_primary_key_name();
croak "Missing primary key name for class '$class', cannot force primary key value"
if !defined( $primary_key_name ) && defined( $args{'generated_primary_key_value'} );
croak "The object of class '$class' does not have a primary key value, cannot update"
if ! defined( $self->id() );
# Prepare the SQL request elements.
my $where_clauses = $args{'restrictions'}->{'where_clauses'} || [];
my $where_values = $args{'restrictions'}->{'where_values'} || [];
push( @$where_clauses, $primary_key_name . ' = ?' );
push( @$where_values, [ $self->id() ] );
my $where = '( ' . join( ' ) AND ( ', @$where_clauses ) . ' )';
# Prepare the values to set.
my @set_placeholders = ();
my @set_values = ();
foreach my $key ( keys %$clean_data )
{
push( @set_placeholders, $dbh->quote_identifier( $key ) . ' = ?' );
push( @set_values, $clean_data->{ $key } );
}
if ( defined( $args{'set'} ) )
{
push( @set_placeholders, @{ $args{'set'}->{'placeholders'} // [] } );
push( @set_values, @{ $args{'set'}->{'values'} // [] } );
}
my $set_placeholders = join( ', ', @set_placeholders );
# Prepare the query elements.
my $query = sprintf(
qq|
UPDATE %s
SET $set_placeholders
WHERE $where
|,
$dbh->quote_identifier( $table_name ),
);
my @query_values =
(
@set_values,
map { @$_ } @$where_values,
);
# Update the row.
my $rows_updated_count;
try
{
local $dbh->{'RaiseError'} = 1;
my $sth = $dbh->prepare( $query );
$sth->execute( @query_values );
$rows_updated_count = $sth->rows();
}
catch
{
$log->fatalf(
"Could not update rows: %s\nQuery: %s\nValues: %s",
$_,
$query,
\@query_values,
);
};
# Also, if rows() returns -1, it's an error.
croak 'Could not execute update: ' . $dbh->errstr()
if $rows_updated_count < 0;
my $object_cache_time = $self->get_object_cache_time();
# This needs to be before the set() below, so we invalidate the cache based on the
# old object. We don't need to do it twice, because you can't change primary IDs, and
# you can't change unique fields to ones that are taken, and that's all that we set
# the object cache keys for.
if ( defined( $object_cache_time ) )
{
$log->debugf(
"An update on '%s' is forcing to clear the cache for '%s=%s'",
$table_name,
$primary_key_name,
$self->id(),
) if $self->is_verbose();
$self->invalidate_cached_object();
}
# Make sure that the object reflects $clean_data.
$self->set(
$clean_data,
force => 1,
);
return $rows_updated_count;
}
=head2 validate_data()
Validate the hashref of data passed as first argument. This is used both by
C<insert()> and C<update> to check the data before performing databse
operations.
my $validated_data = $object->validate_data(
\%data,
);
If there is invalid data, the method will croak with a detail of the error.
=cut
sub validate_data
{
my ( $self, $original_data ) = @_;
my $data = Storable::dclone( $original_data );
# Protect read-only fields.
foreach my $field ( @{ $self->get_readonly_fields() } )
{
next
unless defined( $data->{ $field } );
croak "The field '$field' is read-only and cannot be set via the model";
}
# Don't allow setting timestamps.
foreach my $field ( qw( created modified ) )
{
croak "The field '$field' cannot be set and will be ignored"
if $self->is_verbose();
delete( $data->{ $field } );
}
# Allow inserting the primary key, but not updating it.
my $primary_key_name = $self->get_primary_key_name();
if ( defined( $primary_key_name ) && defined( $self->{ $primary_key_name } ) && exists( $data->{ $primary_key_name } ) )
{
croak "'$primary_key_name' with a value of '" . ( $data->{ $primary_key_name } || 'undef' ) . "' ",
"was passed to set(), but primary keys cannot be set manually";
}
# Fields starting with an underscore are hidden data that shouldn't be
# modified via a public interface.
foreach my $field ( keys %$data )
{
delete( $data->{ $field } )
if substr( $field, 0, 1 ) eq '_';
}
return $data;
}
=head1 UTILITY METHODS
=head2 dump()
Return a Dumper( ) of the current object.
my $string = $book->dump();
=cut
sub dump ## no critic (Subroutines::ProhibitBuiltinHomonyms)
{
my ( $self ) = @_;
return Dumper( $self );
}
=head2 flatten_object()
Return a hash with the requested key/value pairs based on the list of fields
provided.
Note that non-native fields (starting with an underscore) are not allowed. It
also protects sensitive fields.
#TODO: allow defining sensitive fields.
my $book_data = $book->flatten_object(
[ 'name', 'isbn' ]
);
=cut
sub flatten_object
{
my ( $self, $fields ) = @_;
my @protected_fields = qw( password );
my %data = ();
foreach my $field ( @$fields )
{
if ( scalar( grep { $_ eq $field } @protected_fields ) != 0 )
{
croak "The fields '$field' is protected and cannot be added to the flattened copy";
}
elsif ( substr( $field, 0, 1 ) eq '_' )
{
croak "The field '$field' is hidden and cannot be added to the flattened copy";
}
elsif ( $field eq 'id' )
{
if ( defined( $self->get_primary_key_name() ) )
{
$data{'id'} = $self->id();
}
else
{
croak "Requested adding ID to the list of fields, but the class doesn't define a primary key name";
}
}
else
{
$data{ $field } = $self->{ $field };
}
}
return \%data;
}
=head2 reload()
Reload the content of the current object. This always skips the cache.
$book->reload();
=cut
sub reload
{
my ( $self ) = @_;
# Make sure we were passed an object.
croak 'This method can only be called on an object'
if !Data::Validate::Type::is_hashref( $self );
my $class = ref( $self );
croak 'The object is not blessed with a class name'
if !defined( $class ) || ( $class eq '' );
croak "The class '$class' doesn't allow calling \$class->new()"
if ! $class->can('new');
# Verify that we can reload the object.
croak 'Cannot reload an object for which a primary key name has not been defined at the class level.'
if ! defined( $self->get_primary_key_name() );
croak 'Cannot reload an object with no ID value for its primary key'
if ! defined( $self->id() );
# Retrieve a fresh version using the object ID.
my $id = $self->id();
my $fresh_object = $class->new(
{ id => $self->id() },
skip_cache => 1,
);
croak "Could not retrieve the row in the database corresponding to the current object using ID '$id'"
if ! defined( $fresh_object );
# Keep the memory location intact.
%{ $self } = %{ $fresh_object };
return;
}
=head2 retrieve_list()
Return an arrayref of objects matching all the criteria passed.
This method supports the following filtering criteria in a hashref passed as
first argument:
=over 4
=item * id
An ID or an arrayref of IDs corresponding to the primary key.
# Retrieve books with ID 1.
my $books = My::Model::Book->retrieve_list(
{
id => 1,
}
);
# Retrieve books with IDs 1, 2 or 3.
my $books = My::Model::Book->retrieve_list(
{
id => [ 1, 2, 3 ]
}
);
=item * Field names
A scalar value or an arrayref of values corresponding to a field listed in
C<static_class_info()> under either C<filtering_fields> or C<unique_fields>.
# Retrieve books for an author.
my $books = My::Model::Book->retrieve_list(
{
author_id => 12,
}
);
# Retrieve books by ISBN.
my $books = My::Model::Book->retrieve_list(
{
isbn =>
[
'9781449313142',
'9781449393090',
]
}
);
=back
Note that you can combine filters (which is the equivalent of AND in SQL) in
that hashref:
# Retrieve books by ISBN for a specific author.
my $books = My::Model::Book->retrieve_list(
{
isbn =>
[
'9781449313142',
'9781449393090',
],
author_id => 12,
}
);
This method also supports the following optional arguments, passed in a hash
after the filtering criteria above-mentioned:
=over 4
=item * dbh
Retrieve the data against a different database than the default one specified
in C<static_class_info>.
=item * order_by
Specify an ORDER BY clause to sort the objects returned.
my $books = My::Model::Book->retrieve_list(
{
author_id => 12,
},
order_by => 'books.name ASC',
);
=item * limit
Limit the number of objects to return.
# Get 10 books from author #12.
my $books = My::Model::Book->retrieve_list(
{
author_id => 12,
},
limit => 10,
);
=item * query_extensions
Add joins and support different filtering criteria:
=over 8
=item * where_clauses
An arrayref of clauses to add to WHERE.
=item * where_values
An arrayref of values corresponding to the clauses.
=item * joins
A string specifying JOIN statements.
=item * joined_fields
A string of extra fields to add to the SELECT.
=back
my $books = My::Model::Book->retrieve_list(
{
id => [ 1, 2, 3 ],
},
query_extensions =>
{
where_clauses => [ 'authors.name = ?' ],
where_values => [ [ 'Randal L. Schwartz' ] ],
joins => 'INNER JOIN authors USING (author_id)',
joined_fields => 'authors.name AS _author_name',
}
);
=item * pagination
Off by default. Paginate the results. You can control the pagination options
by setting it to the following hashref:
{
total_count => $total_count,
page => $page,
page_max => $page_max,
per_page => $per_page,
}
Additionally, pagination can be set to '1' instead of {} and then the default
options will be used.
=item * lock (default 0)
Add a lock to the rows retrieved.
my $books = My::Model::Book->retrieve_list(
{
id => [ 1, 2, 3 ],
},
lock => 1,
);
=item * allow_all (default 0)
Retrieve all the rows in the table if no criteria is passed. Off by
default to prevent retrieving large tables at once.
# All the books!
my $books = My::Model::Book->retrieve_list(
{},
allow_all => 1,
);
=item * show_queries (default 0)
Set to '1' to see in the logs the queries being performed.
my $books = My::Model::Book->retrieve_list(
{
id => [ 1, 2, 3 ],
},
show_queries => 1,
);
=back
=cut
sub retrieve_list
{
my ( $class, $filters, %args ) = @_;
# Check caller and prevent calls from a subclass' retrieve_list().
my $subroutine = (caller(1))[3];
if ( defined( $subroutine ) )
{
$subroutine =~ s/^.*:://;
croak(
'You have subclassed retrieve_list(), which is not allowed to prevent infinite recursions. ' .
'You most likely want to subclass retrieve_list_nocache() instead.'
) if $subroutine eq 'retrieve_list';
}
my $any_cache_time = $class->get_list_cache_time() || $class->get_object_cache_time();
return defined( $any_cache_time ) && !$args{'skip_cache'} && !$args{'lock'}
? $class->retrieve_list_cache( $filters, %args )
: $class->retrieve_list_nocache( $filters, %args );
}
=head1 ACCESSORS
=head2 get_cache_key_field()
Return the name of the field that should be used in the cache key.
my $cache_time = $class->cache_key_field();
my $cache_time = $object->cache_key_field();
=cut
sub get_cache_key_field
{
my ( $self ) = @_;
my $cache_key_field = $self->cached_static_class_info()->{'cache_key_field'};
# If the subclass specifies a field to use for the cache key name, use it.
# Otherwise, we fall back on the primary key if it exists.
return defined( $cache_key_field )
? $cache_key_field
: $self->get_primary_key_name();
}
=head2 get_default_dbh()
Return the default database handle to use with this class.
my $default_dbh = $class->get_default_dbh();
my $default_dbh = $object->get_default_dbh();
=cut
sub get_default_dbh
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'default_dbh'};
}
=head2 get_filtering_fields()
Returns the fields that can be used as filtering criteria in retrieve_list().
Notes:
=over 4
=item * Does not include the primary key.
=item * Includes unique fields.
my $filtering_fields = $class->get_filtering_fields();
my $filtering_fields = $object->get_filtering_fields();
=back
=cut
sub get_filtering_fields
{
my ( $self ) = @_;
my %fields = (
map { $_ => undef }
(
@{ $self->cached_static_class_info()->{'filtering_fields'} },
@{ $self->cached_static_class_info()->{'unique_fields'} },
)
);
return [ keys %fields ];
}
=head2 get_list_cache_time()
Return the duration for which a list of objects of the current class can be
cached.
my $list_cache_time = $class->list_cache_time();
my $list_cache_time = $object->list_cache_time();
=cut
sub get_list_cache_time
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'list_cache_time'};
}
=head2 get_memcache()
Return the memcache object to use with this class.
my $memcache = $class->get_memcache();
my $memcache = $object->get_memcache();
=cut
sub get_memcache
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'memcache'};
}
=head2 get_object_cache_time()
Return the duration for which an object of the current class can be cached.
my $object_cache_time = $class->get_object_cache_time();
my $object_cache_time = $object->get_object_cache_time();
=cut
sub get_object_cache_time
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'object_cache_time'}
}
=head2 get_primary_key_name()
Return the underlying primary key name for the current class or object.
my $primary_key_name = $class->get_primary_key_name();
my $primary_key_name = $object->get_primary_key_name();
=cut
sub get_primary_key_name
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'primary_key_name'};
}
=head2 get_readonly_fields()
Return an arrayref of fields that cannot be modified via C<set()>, C<update()>,
or C<insert()>.
my $readonly_fields = $class->get_readonly_fields();
my $readonly_fields = $object->get_readonly_fields();
=cut
sub get_readonly_fields
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'readonly_fields'} || [];
}
=head2 get_table_name()
Returns the underlying table name for the current class or object.
my $table_name = $class->get_table_name();
my $table_name = $object->get_table_name();
=cut
sub get_table_name
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'table_name'};
}
=head2 get_unique_fields()
Return an arrayref of fields that are unique for the underlying table.
Important: this doesn't include the primary key name. To retrieve the name
of the primary key, use C<$class->primary_key_name()>
my $unique_fields = $class->get_unique_fields();
my $unique_fields = $object->get_unique_fields();
=cut
sub get_unique_fields
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'unique_fields'} || [];
}
=head2 has_created_field()
Return a boolean to indicate whether the underlying table has a 'created'
field.
my $has_created_field = $class->has_created_field();
my $has_created_field = $object->has_created_field();
=cut
sub has_created_field
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'has_created_field'};
}
=head2 has_modified_field()
Return a boolean to indicate whether the underlying table has a 'modified'
field.
my $has_modified_field = $class->has_modified_field();
my $has_modified_field = $object->has_modified_field();
=cut
sub has_modified_field
{
my ( $self ) = @_;
return $self->cached_static_class_info()->{'has_modified_field'};
}
=head2 id()
Return the value associated with the primary key for the current object.
my $id = $object->id();
=cut
sub id
{
my ( $self ) = @_;
my $primary_key_name = $self->get_primary_key_name();
return defined( $primary_key_name )
? $self->{ $primary_key_name }
: undef;
}
=head2 is_verbose()
Return if verbosity is enabled.
This method supports two types of verbosity:
=over 4
=item * general verbosity
Called with no argument, this returns whether code in general will be verbose.
$log->debug( 'This is verbose' )
if $class->is_verbose();
$log->debug( 'This is verbose' )
if $object->is_verbose();
=item * verbosity for a specific type of operations
Called with a specific type of operations as first argument, this returns
whether that type of operations will be verbose.
$log->debug( 'Describe cache operation' )
if $class->is_verbose( $operation_type );
$log->debug( 'Describe cache operation' )
if $object->is_verbose( $operation_type );
Currently, the following types of operations are supported:
=over 8
=item * 'cache_operations'
=back
=back
=cut
sub is_verbose
{
my ( $self, $specific_area ) = @_;
my $cached_static_class_info = $self->cached_static_class_info();
if ( defined( $specific_area ) )
{
my $info_key = 'verbose_' . $specific_area;
croak "'$specific_area' is not valid"
if ! exists( $cached_static_class_info->{ $info_key } );
return $cached_static_class_info->{ $info_key };
}
else
{
return $cached_static_class_info->{'verbose'};
}
}
=head1 CACHE RELATED METHODS
=head2 cached_static_class_info()
Return a cached version of the information retrieved by C<static_class_info()>.
my $static_class_info = $class->cached_static_class_info();
my $static_class_info = $object->cached_static_class_info();
=cut
{
my $CACHE = {};
sub cached_static_class_info
{
my ( $self ) = @_;
my $class = ref( $self ) || $self;
$CACHE->{ $class } ||= $class->static_class_info();
return $CACHE->{ $class }
}
}
=head2 delete_cache()
Delete a key from the cache.
my $value = $class->delete_cache( key => $key );
=cut
sub delete_cache
{
my ( $self, %args ) = @_;
my $key = delete( $args{'key'} );
croak 'Invalid argument(s): ' . join( ', ', keys %args )
if scalar( keys %args ) != 0;
# Check parameters.
croak 'The parameter "key" is mandatory'
if !defined( $key ) || $key !~ /\w/;
my $memcache = $self->get_memcache();
return undef
if !defined( $memcache );
return $memcache->delete( $key );
}
=head2 get_cache()
Get a value from the cache.
my $value = $class->get_cache( key => $key );
=cut
sub get_cache
{
my ( $self, %args ) = @_;
my $key = delete( $args{'key'} );
croak 'Invalid argument(s): ' . join( ', ', keys %args )
if scalar( keys %args ) != 0;
# Check parameters.
croak 'The parameter "key" is mandatory'
if !defined( $key ) || $key !~ /\w/;
my $memcache = $self->get_memcache();
return undef
if !defined( $memcache );
return $memcache->get( $key );
}
=head2 get_object_cache_key()
Return the name of the cache key for an object or a class, given a field name
on which a unique constraint exists and the corresponding value.
my $cache_key = $object->get_object_cache_key();
my $cache_key = $class->get_object_cache_key(
unique_field => $unique_field,
value => $value,
);
=cut
sub get_object_cache_key
{
my ( $self, %args ) = @_;
my $unique_field = delete( $args{'unique_field'} );
my $value = delete( $args{'value'} );
# Retrieve the field we'll use to create the cache key.
my $cache_key_field = $self->get_cache_key_field();
croak 'No cache key found for class'
if !defined( $cache_key_field );
my $table_name = $self->get_table_name();
if ( defined( $unique_field ) )
{
if ( !defined( $value ) )
{
$log->debugf(
"Passed unique field '%s' without a corresponding value for "
. "table '%s', cannot determine cache key",
$unique_field,
$table_name,
);
return;
}
# 'id' is only an alias and needs to be expanded to its actual name.
$unique_field = $self->get_primary_key_name()
if $unique_field eq 'id';
}
else
{
# If no unique field was passed, use the $cache_key_field field and its
# corresponding value.
if ( Data::Validate::Type::is_hashref( $self ) )
{
$unique_field = $cache_key_field;
$value = $self->{ $unique_field };
# See Trac #1695 for why we think this is significant.
unless ( defined( $value ) )
{
$log->debugf(
"Trying to use field '%s' on table '%s' to generate "
. "a cache key, but the value for that field on the "
. "object is undef",
$cache_key_field,
$table_name,
);
return;
}
}
else
{
$log->debug(
"If you don't specify a unique field and value, you need to "
. "call this function on an object"
);
return;
}
}
# If the unique field passed doesn't match what the cache key is, we need
# to do a database lookup to find out the corresponding cache key.
my $cache_key_value;
if ( $unique_field ne $cache_key_field )
{
my $dbh = $self->assert_dbh();
$cache_key_value = $dbh->selectrow_arrayref(
sprintf(
q|
SELECT %s
FROM %s
WHERE %s = ?
|,
$dbh->quote_identifier( $cache_key_field ),
$dbh->quote_identifier( $table_name ),
$dbh->quote_identifier( $unique_field ),
),
{},
$value,
);
$cache_key_value = defined( $cache_key_value ) && scalar( @$cache_key_value ) != 0
? $cache_key_value->[0]
: undef;
unless ( defined( $cache_key_value ) )
{
$log->debugf(
"Cache miss for unique field '%s' and value '%s' on table "
. "'%s', cannot generate cache key.",
$unique_field,
$value,
$table_name,
) if $self->is_verbose();
return;
}
}
else
{
$cache_key_value = $value;
}
return lc( 'object|' . $table_name . '|' . $cache_key_field . '|' . $cache_key_value );
}
=head2 invalidate_cached_object()
Invalidate the cached copies of the current object across all the unique
keys this object can be referenced with.
$object->invalidate_cached_object();
=cut
sub invalidate_cached_object
{
my ( $self ) = @_;
my $primary_key_name = $self->get_primary_key_name();
if ( defined( $primary_key_name ) )
{
my $cache_key = $self->get_object_cache_key(
unique_field => 'id',
value => $self->id(),
);
$self->delete_cache( key => $cache_key );
}
foreach my $field ( @{ $self->get_unique_fields() } )
{
# If the object has no value for the unique field, it wasn't
# cached for this key/value pair and we can't build a cache key
# for it anyway, so we just skip to the next unique field.
next unless defined( $self->{ $field } );
my $cache_key = $self->get_object_cache_key(
unique_field => $field,
value => $self->{ $field },
);
$self->delete_cache( key => $cache_key );
}
return 1;
}
=head2 retrieve_list_cache()
Dispatch of retrieve_list() when objects should be retrieved from the cache.
See C<retrieve_list()> for the parameters this method accepts.
=cut
sub retrieve_list_cache ## no critic (Subroutines::ProhibitExcessComplexity)
{
my ( $class, $filters, %args ) = @_;
my $list_cache_time = $class->get_list_cache_time();
my $object_cache_time = $class->get_object_cache_time();
my $primary_key_name = $class->get_primary_key_name();
# Create a unique cache key.
my $list_cache_keys = [];
foreach my $filter ( keys %$filters )
{
# Force all arguments into lower case for purposes of caching.
push( @$list_cache_keys, [ lc( $filter ), $filters->{ $filter } ] );
}
foreach my $arg ( sort keys %args )
{
# Those arguments don't have an impact on the filters to IDs translation,
# so we can exclude them from the unique cache key.
next if $arg =~ /^(?:dbh|lock|show_queries|skip_cache)$/x;
# Force all arguments into lower case for purposes of caching.
push( @$list_cache_keys, [ lc( $arg ), $args{ $arg } ] );
}
my $list_cache_key = MIME::Base64::encode_base64( Storable::freeze( $list_cache_keys ) );
chomp( $list_cache_key );
my $list_cache_key_sha1 = Digest::SHA1::sha1_base64( $list_cache_key );
# Find out if the parameters are searching by ID or using a unique field.
my $search_field;
my $list_of_search_values;
foreach my $field ( 'id', @{ $class->get_unique_fields() } )
{
next
unless exists( $filters->{ $field } );
$search_field = $field;
$list_of_search_values = Data::Validate::Type::filter_arrayref( $filters->{ $field } )
// [ $filters->{ $field } ];
}
# If we're searcing by ID or unique field, those are how the objects are
# cached so we already know how to retrieve them from the object cache.
# If we're searching by anything else, then we maintain a "list cache",
# which associates retrieve_list() args with the resulting IDs.
my $pagination;
my $list_cache_used = 0;
if ( !defined( $search_field ) )
{
# Test if we have a corresponding list of IDs in the cache.
my $cache = $class->get_cache( key => $list_cache_key_sha1 );
if ( defined( $cache ) )
{
my $cache_content = Storable::thaw( MIME::Base64::decode_base64( $cache ) );
my ( $original_list_cache_key, $original_pagination, $original_search_field, $original_list_of_ids ) = @{ Data::Validate::Type::filter_arrayref( $cache_content ) // [] };
# We need to use SHA1 due to the limitation on the length of memcache keys
# (we can't just cache $cache_key).
# However, there is a very small risk of collision so we check here that
# the cache key stored inside the cache entry is the same.
if ( $original_list_cache_key eq $list_cache_key )
{
$list_of_search_values = $original_list_of_ids;
$pagination = $original_pagination;
$search_field = $original_search_field;
$list_cache_used = 1;
}
}
}
my $cached_objects = {};
my $objects;
if ( !$args{'lock'} && defined( $list_of_search_values ) )
{
$log->debug( "Using values (unique/IDs) from the list cache" )
if $class->is_verbose('cache_operations');
# If we're not trying to lock the underlying rows, and we have a list of
# IDs from the cache, we try to get the objects from the object cache.
my $objects_to_retrieve_from_database = {};
foreach my $search_value ( @$list_of_search_values )
{
my $object_cache_key = $class->get_object_cache_key(
unique_field => $search_field eq 'id'
? $primary_key_name
: $search_field,
value => $search_value,
);
my $object = defined( $object_cache_key )
? $class->get_cache( key => $object_cache_key )
: undef;
if ( defined( $object ) )
{
$log->debugf(
"Retrieved '%s' from cache.",
$object_cache_key,
) if $class->is_verbose('cache_operations');
$object->{'_debug'}->{'object_cache_used'} = 1;
my $hash_key = lc(
$search_field eq 'id'
? $object->id()
: $object->get( $search_field )
);
$cached_objects->{ $hash_key } = $object;
}
else
{
$log->debugf(
"'%s' not found in the cache.",
$object_cache_key,
) if $class->is_verbose('cache_operations');
$objects_to_retrieve_from_database->{ lc( $search_value ) } = $object_cache_key;
}
}
# If we have any ID we couldn't get an object for from the cache, we now
# go to the database.
if ( scalar( keys %$objects_to_retrieve_from_database ) != 0 )
{
$log->debug(
"The following objects are not cached and need to be retrieved from the database: %s",
join( ', ', keys %$objects_to_retrieve_from_database ),
) if $class->is_verbose('cache_operations');
$objects = $class->retrieve_list_nocache(
{
$search_field => [ keys %$objects_to_retrieve_from_database ],
},
);
}
# Indicate that we've used the list cache to retrieve the list of object
# IDs.
if ( $list_cache_used )
{
foreach my $object ( values %$cached_objects, @{ $objects // [] } )
{
$object->{'_debug'}->{'list_cache_used'} = 1;
}
}
}
else
{
# If we don't have a list of IDs, we need to go to the database via
# retrieve_list_nocache() to get the objects.
( $objects, $pagination ) = $class->retrieve_list_nocache(
$filters,
%args,
);
# Set the list cache.
my $list_cache_ids = [ map { $_->id() } @$objects ];
$log->debugf(
"Adding key '%s' to the list cache, with the following IDs: %s",
$list_cache_key,
join( ', ', @$list_cache_ids ),
) if $class->is_verbose('cache_operations');
$class->set_cache(
key => $list_cache_key_sha1,
value => MIME::Base64::encode_base64(
Storable::freeze(
[
$list_cache_key,
$pagination,
'id',
$list_cache_ids,
]
)
),
expire_time => $list_cache_time,
);
}
# For cache purposes, we use the search field if it is available (as it's
# either the primary key or a unique field), and we fall back on 'id'
# which exists on all objects as a primary key shortcut.
my $cache_field = $search_field // 'id';
# Cache the objects.
my $database_objects = {};
foreach my $object ( @$objects )
{
my $hash_key = lc(
$cache_field eq 'id'
? $object->id()
: $object->get( $cache_field )
);
$database_objects->{ $hash_key } = $object;
my $object_cache_key = $cache_field eq 'id'
? $object->get_object_cache_key()
: $object->get_object_cache_key(
unique_field => $cache_field,
value => $object->get( $cache_field ),
);
next if !defined( $object_cache_key );
$object->{'_debug'}->{'cache_expires'} = time() + $object_cache_time;
$log->debugf(
"Set object cache for key '%s'.",
$object_cache_key,
) if $class->is_verbose('cache_operations');
$class->set_cache(
key => $object_cache_key,
value => $object,
expire_time => $object_cache_time,
);
}
# Make sure the objects are sorted.
my $sorted_objects;
if ( defined( $list_of_search_values ) )
{
# If we've been using a list of IDs from the cache, we need to merge
# the objects and sort them.
$sorted_objects = [];
foreach my $search_value ( @$list_of_search_values )
{
if ( exists( $cached_objects->{ lc( $search_value ) } ) )
{
push( @$sorted_objects, $cached_objects->{ lc( $search_value ) } );
}
else
{
push( @$sorted_objects, $database_objects->{ lc( $search_value ) } );
}
}
}
else
{
# Otherwise, $object comes from the database and is already sorted by
# retrieve_list_nocache().
$sorted_objects = $objects;
}
# Return the objects, taking into account whether pagination is requested.
if ( wantarray && defined( $args{'pagination'} ) )
{
return ( $sorted_objects, $pagination );
}
else
{
return $sorted_objects;
}
}
=head2 set_cache()
Set a value into the cache.
$class->set_cache(
key => $key,
value => $value,
expire_time => $expire_time,
);
=cut
sub set_cache
{
my ( $self, %args ) = @_;
my $key = delete( $args{'key'} );
my $value = delete( $args{'value'} );
my $expire_time = delete( $args{'expire_time'} );
croak 'Invalid argument(s): ' . join( ', ', keys %args )
if scalar( keys %args ) != 0;
# Check parameters.
croak 'The argument "key" is mandatory'
if !defined( $key ) || $key !~ /\w/;
croak 'The argument "value" is mandatory'
if !defined( $value );
my $memcache = $self->get_memcache();
return
if !defined( $memcache );
$memcache->set( $key, $value, $expire_time )
|| $log->errorf( "Failed to set cache with key '%s'.", $key );
return;
}
=head1 INTERNAL METHODS
Those methods are used internally by L<DBIx::NinjaORM>, you should not subclass
them.
=head2 assert_dbh()
Assert that there is a database handle, either a specific one passed as first
argument to this function (if defined) or the default one specified via
C<static_class_info()>, and return it.
my $dbh = $class->assert_dbh();
my $dbh = $object->assert_dbh();
my $dbh = $class->assert_dbh( $custom_dbh );
my $dbh = $object->assert_dbh( $custom_dbh );
Note that this method also supports coderefs that return a C<DBI::db> object
when evaluated. That way, if no database connection is needed when running the
code, no connection needs to be established.
=cut
sub assert_dbh
{
my ( $class, $specific_dbh ) = @_;
my ( $dbh, $type );
if ( defined( $specific_dbh ) )
{
$dbh = $specific_dbh;
$type = 'specified';
}
else
{
$dbh = $class->get_default_dbh();
$type = 'default';
}
$dbh = $dbh->()
if Data::Validate::Type::is_coderef( $dbh );
croak "The $type database handle is not a valid DBI::db object (" . ref( $dbh ) . ')'
if !Data::Validate::Type::is_instance( $dbh, class => 'DBI::db' );
return $dbh;
}
=head2 build_filtering_clause()
Create a filtering clause using the field, operator and values passed.
my ( $clause, $clause_values ) = $class->build_filtering_clause(
field => $field,
operator => $operator,
values => $values,
);
=cut
sub build_filtering_clause
{
my ( $class, %args ) = @_;
my $field = $args{'field'};
my $operator = $args{'operator'};
my $values = $args{'values'};
my $clause;
my $clause_values = [ $values ];
# Quote the field name.
my $dbh = $class->assert_dbh();
my $quoted_field = join( '.', map { $dbh->quote_identifier( $_ ) } split( /\./, $field ) );
croak 'A field name is required'
if !defined( $field ) || $field eq '';
# Between is a special case where values are an arrayref of a specific size.
if ( $operator eq 'between' ) ## no critic (ControlStructures::ProhibitCascadingIfElse)
{
unless ( defined( $values ) && Data::Validate::Type::is_arrayref( $values ) && scalar( @$values ) == 2 )
{
croak '>between< requires two values to be passed as an arrayref';
}
$clause = "$quoted_field BETWEEN ? AND ?";
$clause_values = $values;
}
# 'null' is also a special case with no values.
elsif ( $operator eq 'null' )
{
$clause = "$quoted_field IS NULL";
$clause_values = [];
}
# 'not_null' is also a special case with no values.
elsif ( $operator eq 'not_null' )
{
$clause = "$quoted_field IS NOT NULL";
$clause_values = [];
}
# More than one value passed.
elsif ( Data::Validate::Type::is_arrayref( $values ) )
{
if ( $operator eq '=' ) ## no critic (ControlStructures::ProhibitCascadingIfElse)
{
$clause = "$quoted_field IN (" . join( ', ', ( ( '?' ) x scalar( @$values ) ) ) . ")";
$clause_values = $values;
}
elsif ( $operator eq 'not' )
{
$clause = "$quoted_field NOT IN (" . join( ', ', ( ( '?' ) x scalar( @$values ) ) ) . ")";
$clause_values = $values;
}
elsif ( $operator eq '>' || $operator eq '>=' )
{
# List::Util::max() really hates undefined elements and will warn
# loudly at each one it encounters. So, grep them out first.
my $max = List::Util::max( grep { defined( $_ ) } @$values );
if ( defined( $max ) )
{
$clause = "$quoted_field $operator ?";
$clause_values = [ $max ];
}
else
{
croak 'Could not find max of the following list: ' . Dumper( $values );
}
}
elsif ( $operator eq '<' || $operator eq '<=' )
{
# List::Util::max() really hates undefined elements and will warn
# loudly at each one it encounters. So, grep them out first.
my $min = List::Util::min( grep { defined( $_ ) } @$values );
if ( defined( $min ) )
{
$clause = "$quoted_field $operator ?";
$clause_values = [ $min ];
}
else
{
croak 'Could not find min of the following list: ' . Dumper( $values );
}
}
# Only one value passed.
else
{
croak "The operator '$operator' is not implemented";
}
}
else
{
$operator = '!='
if $operator eq 'not';
$clause = "$quoted_field $operator ?";
}
return ( $clause, $clause_values );
}
=head2 parse_filtering_criteria()
Helper function that takes a list of fields and converts them into where
clauses and values that can be used by retrieve_list().
my ( $where_clauses, $where_values, $filtering_field_keys_passed ) =
@{
$class->parse_filtering_criteria(
\%filtering_criteria
)
};
$filtering_field_keys_passed indicates whether %values had keys matching at
least one element of @field. This allows detecting whether any filtering
criteria was passed, even if the filtering criteria do not result in WHERE
clauses being returned.
=cut
sub parse_filtering_criteria
{
my ( $class, $filters ) = @_;
# Check the arguments.
if ( !Data::Validate::Type::is_hashref( $filters ) )
{
my $error = "The first argument must be a hashref of filtering criteria";
$log->error( $error );
croak $error;
};
# Build the list of filtering fields we allow.
my $filtering_fields =
{
map { $_ => 1 }
@{ $class->get_filtering_fields() || [] }
};
my $primary_key_name = $class->get_primary_key_name();
if ( defined( $primary_key_name ) )
{
# If there's a primary key name, allow 'id' as an alias.
$filtering_fields->{'id'} = 1;
}
# Check if we were passed filters we don't know how to handle. This will
# help the calling code to detect typos or missing filtering fields in the
# static class declaration.
foreach my $filter ( keys %$filters )
{
next if defined( $filtering_fields->{ $filter } );
croak(
"The filtering criteria '$filter' passed to DBIx::NinjaORM->retrieve_list() " .
"via ${class}->retrieve_list() is not handled by the superclass. It could " .
"mean that you have a typo in the name, or that you need to add it to " .
"the list of filtering fields in ${class}->static_class_info()."
);
}
# Find the table name to prefix it to the field names when we create where
# clauses.
my $table_name = $class->get_table_name();
croak "No table name found for the class >" . ( ref( $class ) || $class ) . "<"
if !defined( $table_name );
my $where_clauses = [];
my $where_values = [];
my $filtering_field_keys_passed = 0;
foreach my $field ( sort keys %$filters )
{
next unless defined( $filters->{ $field } );
$filtering_field_keys_passed = 1;
# Add the table prefix if needed, this will prevent conflicts if the
# main query performs JOINs.
my $full_field_name = defined( $primary_key_name ) && ( $field eq 'id' )
? $table_name . '.' . $primary_key_name
: $field =~ m/\./
? $field
: $table_name . '.' . $field;
# Turn the value into an array of values, if needed.
my $values = Data::Validate::Type::is_arrayref( $filters->{ $field } )
? $filters->{ $field }
: [ $filters->{ $field } ];
my @scalar_values = ();
foreach my $block ( @$values )
{
if ( Data::Validate::Type::is_hashref( $block ) )
{
if ( !defined( $block->{'operator'} ) )
{
croak 'The operator is missing or not defined';
}
elsif ( $block->{'operator'} !~ m/^(?:=|not|<=|>=|<|>|between|null|not_null)$/x )
{
croak "The operator '$block->{'operator'}' is not a valid one. Try (=|not|<=|>=|<|>)";
}
elsif ( !exists( $block->{'value'} ) && $block->{'operator'} !~ /^(?:null|not_null)$/ )
{
croak "The value key is missing for operator '$block->{'operator'}'";
}
my ( $clause, $clause_values ) = $class->build_filtering_clause(
field => $full_field_name,
operator => $block->{'operator'},
values => $block->{'value'},
);
push( @$where_clauses, $clause );
push( @$where_values, $clause_values );
}
else
{
push( @scalar_values, $block );
}
}
if ( scalar( @scalar_values ) != 0 )
{
my ( $clause, $clause_values ) = $class->build_filtering_clause(
field => $full_field_name,
operator => '=',
values => \@scalar_values,
);
push( @$where_clauses, $clause );
push( @$where_values, $clause_values );
}
}
return [ $where_clauses, $where_values, $filtering_field_keys_passed ];
}
=head2 reorganize_non_native_fields()
When we retrieve fields via SELECT in retrieve_list_nocache(), by convention we use
_[table_name]_[field_name] for fields that are not native to the underlying
table that the object represents.
This method moves them to $object->{'_table_name'}->{'field_name'} for a
cleaner organization inside the object.
$object->reorganize_non_native_fields();
=cut
sub reorganize_non_native_fields
{
my ( $self ) = @_;
# Move non-native fields to their own happy place.
foreach my $field ( keys %$self )
{
next unless $field =~ m/^(_[^_]+)_(.*)$/;
$self->{ $1 }->{ $2 } = $self->{ $field };
delete( $self->{ $field } );
}
return;
}
=head1 AUTHOR
Guillaume Aubert, C<< <aubertg at cpan.org> >>.
=head1 BUGS
Please report any bugs or feature requests to C<bug-dbix-ninjaorm at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBIx-NinjaORM>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc DBIx::NinjaORM
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-NinjaORM>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/DBIx-NinjaORM>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/DBIx-NinjaORM>
=item * Search CPAN
L<http://search.cpan.org/dist/DBIx-NinjaORM/>
=back
=head1 ACKNOWLEDGEMENTS
Thanks to ThinkGeek (L<http://www.thinkgeek.com/>) and its corporate overlords
at Geeknet (L<http://www.geek.net/>), for footing the bill while I write code
for them!
Thanks to Kate Kirby C< <<kate at cpan.org>> > for her help with the design of
this module, various additions, and pair programming C<retrieve_list_cache()>
with me.
Thanks to Jennifer Pinkham C< <<jpinkham at cpan.org >> > for creating separate
cache times for objects and arguments to IDs translations.
Thanks to Jamie McCarthy for adding the 'ignore' argument to C<insert()>.
=head1 COPYRIGHT & LICENSE
Copyright 2009-2013 Guillaume Aubert.
This program is free software: you can redistribute it and/or modify it under
the terms of the GNU General Public License version 3 as published by the Free
Software Foundation.
This program is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with
this program. If not, see http://www.gnu.org/licenses/
=cut
1;