Mad-Mapper/lib/Mad/Mapper.pm
package Mad::Mapper;
=encoding utf8
=head1 NAME
Mad::Mapper - Map Perl objects to PostgreSQL, MySQL or SQLite data
=head1 VERSION
0.09
=head1 DESCRIPTION
L<Mad::Mapper> is a base class for objects that should be stored in a
persistent SQL database. Currently the supported backends are L<Mojo::Pg>
L<Mojo::mysql> and L<Mojo::SQLite>. These backends need to be installed
separately.
$ cpanm Mad::Mapper
$ cpanm Mojo::Pg # Mad::Mapper now supports postgres!
THIS MODULE IS EXPERIMENTAL. It is in use in production though, so
big changes will not be made without extreme consideration.
=head1 SYNOPSIS
package MyApp::Model::User;
use Mad::Mapper -base;
# Class attributes
col id => undef;
col email => '';
See also L<Mad::Mapper::Guides::Tutorial> for more details and
L<Mad::Mapper::Guides::Custom> if you want more control.
=head1 RELATIONSHIPS
See L<Mad::Mapper::Guides::HasMany> for example "has many" relationship.
TODO: C<belongs_to()> and maybe C<has_one()>.
=cut
use Mojo::Base -base;
use Mojo::IOLoop;
use Mojo::JSON ();
use Mojo::Loader 'load_class';
use Scalar::Util 'weaken';
use constant DEBUG => $ENV{MAD_DEBUG} || 0;
our $VERSION = '0.09';
my (%COLUMNS, %LOADED, %PK);
=head1 EXPORTED FUNCTIONS
=head2 col
Used to define a column. Follow the same rules as L</has>.
=head2 has
has name => "Bruce";
has [qw(name email)];
has pet => sub { Cat->new };
Same as L<Mojo::Base/has>.
=head2 pk
Used to define a primary key. Follow the same rules as L</has>.
The primary key is used by default in L</load> and L</update> to update the
correct row. If omitted, the first L</col> will act as primary key.
Note that L</pk> is not returned by L</columns>.
=head2 table
Used to define a table name. The default is to decamelize the last part of the
class name and add "s" at the end, unless it already has "s" at the end.
Examples:
.-------------------------------------.
| Class name | table |
|-----------------------|-------------|
| App::Model::User | users |
| App::Model::Users | users |
| App::Model::Group | groups |
| App::Model::UserAgent | user_agents |
'-------------------------------------'
=head1 ATTRIBUTES
=head2 db
$db = $self->db;
$self->db($db_obj);
Need to hold either a L<Mojo::Pg::Database> or L<Mojo::mysql::Database> object.
=head2 in_storage
$bool = $self->in_storage;
$self = $self->in_storage($bool);
=cut
has db => sub { die "'db' is required in constructor." };
has in_storage => 0;
=head1 METHODS
=head2 expand_sql
($sql, @args) = $self->expand_sql($sql, @args);
Used to expand a given C<$sql> statement with variables defined by helpers.
=over 4
=item * %t
Will be replaced by L</table>. Example: "SELECT * FROM %t" becomes "SELECT * FROM users".
=item * %c
Will be replaced by L</columns>. Example: "name,email".
=item * %c=
Will be replaced by L</columns> assignment. Example: "name=?,email=?"
=item * %c?
Will be replaced by L</columns> placeholders. Example: "?,?,?"
=item * %pc
Include L</pk> in list of columns. Example: "id,name,email".
=item * \%c
Becomes a literal "%c".
=back
It is also possible to define aliases for "%t", "%c", "%c=" and "%pc". Example:
%t.x = some_table as x
%c.x = x.col1
=cut
sub expand_sql {
my ($self, $sql, @args) = @_;
my $p;
$sql =~ s|(?<!\\)\%c(?:\.(\w+))?\=|{$p = $1 ? "$1." : ""; join ',', map {"$p$_=?"} $self->columns}|ge;
$sql =~ s|(?<!\\)\%c\?|{join ',', map {"?"} $self->columns}|ge;
$sql =~ s|(?<!\\)\%c(?:\.(\w+))?|{$p = $1 ? "$1." : ""; join ',', map {"$p$_"} $self->columns}|ge;
$sql =~ s|(?<!\\)\%pc(?:\.(\w+))?|{$p = $1 ? "$1." : ""; join ',', map {"$p$_"} $self->pk, $self->columns}|ge;
$sql =~ s|(?<!\\)\%t(?:\.(\w+))?|{$self->table. ($1 ? " $1" : "")}|ge;
$sql =~ s|\\%|%|g;
return $sql, @args;
}
=head2 expand_sst
DEPRECATED in favor of L</expand_sql>.
=cut
sub expand_sst {
Mojo::Util::deprecated("expand_sst() is deprecated in favor of expand_sql()");
shift->expand_sql(@_);
}
=head2 columns
@str = $self->columns;
Returns a list of columns, defined by L</col>.
=head2 delete
$self = $self->delete;
$self = $self->delete(sub { my ($self, $err) = @_, ... });
Will delete the object from database if L</in_storage>.
=cut
sub delete {
my $self = shift;
$self->_delete(@_) if $self->in_storage;
$self;
}
=head2 fresh
$self = $self->fresh;
Will mark the next relationship accessor to fetch new data from database,
instead of using the cached data on C<$self>.
=cut
sub fresh { $_[0]->{fresh}++; $_[0] }
=head2 load
$self = $self->load;
$self = $class->load(sub { my ($self, $err) = @_; });
Used to fetch data from storage and update the object attributes.
=cut
sub load {
my $self = shift;
$self->_find(@_);
$self;
}
=head2 save
$self = $self->save;
$self = $self->save(sub { my ($self, $err) = @_, ... });
Will update the object in database if L</in_storage> or insert it if not.
=cut
sub save {
my $self = shift;
$self->in_storage ? $self->_update(@_) : $self->_insert(@_);
$self;
}
=head2 import
Will set up the caller class with L<Mad::Mapper> functionality if "-base"
is given as argument. See L</SYNOPSIS> for example.
=cut
# Most of this code is copy/paste from Mojo::Base
sub import {
my $class = shift;
return unless my $flag = shift;
if ($flag eq '-base') { $flag = $class }
elsif ($flag eq '-strict') { $flag = undef }
elsif ((my $file = $flag) && !$flag->can('new')) {
$file =~ s!::|'!/!g;
require "$file.pm";
}
if ($flag) {
my $caller = caller;
my $table = Mojo::Util::decamelize((split /::/, $caller)[-1]);
$table =~ s!s?$!s!; # user => users
Mojo::Util::monkey_patch($caller, col => sub { $caller->_define_col(@_) });
Mojo::Util::monkey_patch($caller, columns => sub { @{$COLUMNS{$caller} || []} });
Mojo::Util::monkey_patch($caller, has => sub { Mojo::Base::attr($caller, @_) });
Mojo::Util::monkey_patch($caller, has_many => sub { $caller->_define_has_many(@_) });
Mojo::Util::monkey_patch($caller,
pk => sub { return UNIVERSAL::isa($_[0], $caller) ? $PK{$caller} : $caller->_define_pk(@_) });
Mojo::Util::monkey_patch($caller, table => sub { $table = $_[0] unless UNIVERSAL::isa($_[0], $caller); $table });
no strict 'refs';
push @{"${caller}::ISA"}, $flag;
}
$_->import for qw(strict warnings utf8);
feature->import(':5.10');
}
sub _delete {
my ($self, $cb) = @_;
my @sql = $self->_delete_sql;
warn "[Mad::Mapper::delete] ", Mojo::JSON::encode_json(\@sql), "\n" if DEBUG;
if ($cb) {
weaken $self;
$self->db->query(
@sql,
sub {
my ($db, $err, $res) = @_;
warn "[Mad::Mapper::delete] err=$err\n" if DEBUG and $err;
$self->in_storage(0) unless $err;
$self->$cb($err);
}
);
}
else {
$self->db->query(@sql);
$self->in_storage(0);
}
}
sub _delete_sql {
my $self = shift;
my $pk = $self->_pk_or_first_column;
$self->expand_sql("DELETE FROM %t WHERE $pk=?"), $self->$pk;
}
sub _delete_sst {
Mojo::Util::deprecated("_delete_sst() is deprecated in favor of _delete_sql()");
shift->_delete_sql(@_);
}
sub _define_col {
my $class = ref($_[0]) || $_[0];
push @{$COLUMNS{$class}}, ref $_[0] eq 'ARRAY' ? @{$_[1]} : $_[1];
Mojo::Base::attr(@_);
}
sub _define_has_many {
my ($class, $method, $related_class, $related_col) = @_;
my $pk = $class->_pk_or_first_column;
my $sql_method = $class->can("_has_many_${method}_sql");
Mojo::Util::monkey_patch(
$class => $method => sub {
my $cb = ref $_[-1] eq 'CODE' ? pop : undef;
my $self = shift;
my $err = $LOADED{$related_class}++ ? 0 : load_class $related_class;
my $fresh = delete $self->{fresh};
my $ck = join ':', $method, grep { $_ // '' } @_;
my @sql;
die ref $err ? "Exception: $err" : "Could not find class $related_class!" if $err;
@sql
= $sql_method
? $self->$sql_method($related_class, @_)
: $related_class->expand_sql("SELECT %pc FROM %t WHERE $related_col=?", $self->$pk);
warn sprintf "[Mad::Mapper::has_many::$method] %s\n",
(!$fresh and $self->{cache}{$ck}) ? 'CACHED' : Mojo::JSON::encode_json(\@sql)
if DEBUG;
if ($cb) {
if ($fresh or !$self->{cache}{$ck}) {
$self->db->query(
@sql,
sub {
my ($db, $err, $res) = @_;
warn "[Mad::Mapper::has_many::$method] err=$err\n" if DEBUG and $err;
$self->{cache}{$ck} = $res->hashes->map(sub { $related_class->new($_)->in_storage(1) });
$self->$cb($err, $self->{cache}{$ck});
}
);
}
else {
$self->$cb('', $self->{cache}{$ck});
}
return $self;
}
else {
delete $self->{cache}{$ck} if $fresh;
return $self->{cache}{$ck}
||= $self->db->query(@sql)->hashes->map(sub { $related_class->new($_)->in_storage(1) });
}
}
);
my $add_method = "add_$method";
$add_method =~ s!s?$!!;
Mojo::Util::monkey_patch(
$class => $add_method => sub {
my $self = shift;
my $err = $LOADED{$related_class}++ ? 0 : load_class $related_class;
$related_class->new(db => $self->db, @_, $related_col => $self->$pk);
}
);
}
sub _define_pk {
my $class = ref($_[0]) || $_[0];
$PK{$class} = $_[1];
Mojo::Base::attr(@_);
}
sub _find {
my ($self, $cb) = @_;
my @sql = $self->_find_sql;
warn "[Mad::Mapper::find] ", Mojo::JSON::encode_json(\@sql), "\n" if DEBUG;
if ($cb) {
weaken $self;
$self->db->query(
@sql,
sub {
my ($db, $err, $res) = @_;
warn "[Mad::Mapper::find] err=$err\n" if DEBUG and $err;
$res = $err ? {} : $res->hash || {};
$self->in_storage(1) if %$res and !$err;
$self->{$_} = $res->{$_} for keys %$res;
$self->$cb($err);
}
);
}
else {
my $res = $self->db->query(@sql)->hash || {};
$self->in_storage(1) if keys %$res;
$self->{$_} = $res->{$_} for keys %$res;
}
}
sub _find_sql {
my $self = shift;
my $pk = $self->_pk_or_first_column;
$self->expand_sql("SELECT %pc FROM %t WHERE $pk=?"), $self->$pk;
}
sub _find_sst {
Mojo::Util::deprecated("_find_sst() is deprecated in favor of _find_sql()");
shift->_find_sql(@_);
}
sub _insert {
my ($self, $cb) = @_;
my $pk = $self->_pk_or_first_column;
my $db = $self->db;
my @sql = $self->_insert_sql;
warn "[Mad::Mapper::insert] ", Mojo::JSON::encode_json(\@sql), "\n" if DEBUG;
if ($cb) {
weaken $self;
$db->query(
@sql,
sub {
my ($db, $err, $res) = @_;
warn "[Mad::Mapper::insert] err=$err\n" if DEBUG and $err;
$res = eval { $res->hash } || {};
if ($pk) {
$res->{$pk} ||= $db->dbh->last_insert_id(undef, undef, $self->table, $self->pk);
$res->{$pk} ||= eval { $res->sth->mysql_insertid }; # can probably be removed
}
$self->in_storage(1) if keys %$res;
$self->$_($res->{$_}) for grep { $self->can($_) } keys %$res;
$self->$cb($err);
}
);
}
else {
my $res = $db->query(@sql);
$res = eval { $res->hash } || {};
if ($pk) {
$res->{$pk} ||= $db->dbh->last_insert_id(undef, undef, $self->table, $self->pk);
$res->{$pk} ||= eval { $res->sth->mysql_insertid } # can probably be removed;
}
$self->in_storage(1) if keys %$res;
$self->$_($res->{$_}) for grep { $self->can($_) } keys %$res; # used with Mojo::Pg and RETURNING
}
}
sub _insert_sql {
my $self = shift;
my $pk = $self->pk;
my $sql = "INSERT INTO %t (%c) VALUES (%c?)";
$sql .= " RETURNING $pk" if $pk and UNIVERSAL::isa($self->db, 'Mojo::Pg::Database');
$self->expand_sql($sql), map { $self->$_ } $self->columns;
}
sub _insert_sst {
Mojo::Util::deprecated("_insert_sst() is deprecated in favor of _insert_sql()");
shift->_insert_sql(@_);
}
sub _pk_or_first_column { $_[0]->pk || ($_[0]->columns)[0] }
sub _update {
my ($self, $cb) = @_;
my @sql = $self->_update_sql;
warn "[Mad::Mapper::update] ", Mojo::JSON::encode_json(\@sql), "\n" if DEBUG;
if ($cb) {
weaken $self;
$self->db->query(
@sql,
sub {
my ($db, $err, $res) = @_;
warn "[Mad::Mapper::update] err=$err\n" if DEBUG and $err;
$self->$cb($err);
}
);
}
else {
$self->db->query(@sql);
}
}
sub _update_sql {
my $self = shift;
my $pk = $self->_pk_or_first_column;
$self->expand_sql("UPDATE %t SET %c= WHERE $pk=?"), (map { $self->$_ } $self->columns), $self->$pk;
}
sub _update_sst {
Mojo::Util::deprecated("_update_sst() is deprecated in favor of _update_sql()");
shift->_update_sql(@_);
}
sub TO_JSON {
my $self = shift;
my $pk = $self->pk;
return {$pk ? ($pk => $self->$pk) : (), map { ($_ => $self->$_) } $self->columns};
}
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2014-2016, Jan Henning Thorsen
This program is free software, you can redistribute it and/or modify it under
the terms of the Artistic License version 2.0.
=head1 AUTHOR
Jan Henning Thorsen - C<jhthorsen@cpan.org>
Красимир Беров - C<berov@cpan.org>
Stefan Adams - C<sadams@cpan.org>
=cut
1;