File Coverage

blib/lib/Mad/Mapper.pm
Criterion Covered Total %
statement 66 214 30.8
branch 12 78 15.3
condition 3 45 6.6
subroutine 26 50 52.0
pod 5 6 83.3
total 112 393 28.5


line stmt bran cond sub pod time code
1             package Mad::Mapper;
2              
3             =encoding utf8
4              
5             =head1 NAME
6              
7             Mad::Mapper - Map Perl objects to PostgreSQL, MySQL or SQLite data
8              
9             =head1 VERSION
10              
11             0.07
12              
13             =head1 DESCRIPTION
14              
15             L is base class for objects that should be stored to the a
16             persistent SQL database. Currently the supported backends are L
17             L and L. These backends need to be installed
18             separately.
19              
20             $ cpanm Mad::Mapper
21             $ cpanm Mojo::Pg # Mad::Mapper now support postgres!
22              
23             THIS MODULE IS EXPERIMENTAL. It is in use in production though, so
24             big changes will not be made without extreme consideration.
25              
26             =head1 SYNOPSIS
27              
28             The synopsis is split into three parts: The two first is for model developers,
29             and the last is for the developer using the models.
30              
31             package MyApp::Model::User;
32             use Mad::Mapper -base;
33              
34             # Class attributes
35             col id => undef;
36             col email => '';
37              
38             See also L for more details and
39             L if you want more control.
40              
41             =head1 RELATIONSHIPS
42              
43             See L for example "has many" relationship.
44              
45             TODO: C and maybe C.
46              
47             =cut
48              
49 5     8   148177 use Mojo::Base -base;
  5         10  
  5         37  
50 5     5   4662 use Mojo::IOLoop;
  5         645970  
  5         32  
51 5     5   3796 use Mojo::JSON ();
  5         78638  
  5         158  
52 5     5   43 use Mojo::Loader 'load_class';
  5         10  
  5         269  
53 5     5   27 use Scalar::Util 'weaken';
  5         9  
  5         269  
54 5   50 5   26 use constant DEBUG => $ENV{MAD_DEBUG} || 0;
  5         11  
  5         6691  
55              
56             our $VERSION = '0.07';
57              
58             my (%COLUMNS, %LOADED, %PK);
59              
60             =head1 EXPORTED FUNCTIONS
61              
62             =head2 col
63              
64             Used to define a column. Follow the same rules as L.
65              
66             =head2 has
67              
68             has name => "Bruce";
69             has [qw(name email)];
70             has pet => sub { Cat->new };
71              
72             Same as L.
73              
74             =head2 pk
75              
76             Used to define a primary key. Follow the same rules as L.
77              
78             The primary key is used by default in L and L to update the
79             correct row. If omitted, the first L will act as primary key.
80              
81             Note that L is not returned by L.
82              
83             =head2 table
84              
85             Used to define a table name. The default is to decamelize the last part of the
86             class name and add "s" at the end, unless it already has "s" at the end.
87             Examples:
88              
89             .-------------------------------------.
90             | Class name | table |
91             |-----------------------|-------------|
92             | App::Model::User | users |
93             | App::Model::Users | users |
94             | App::Model::Group | groups |
95             | App::Model::UserAgent | user_agents |
96             '-------------------------------------'
97              
98             =head1 ATTRIBUTES
99              
100             =head2 db
101              
102             $db = $self->db;
103             $self->db($db_obj);
104              
105             Need to hold either a L or L object.
106              
107             =head2 in_storage
108              
109             $bool = $self->in_storage;
110             $self = $self->in_storage($bool);
111              
112             =cut
113              
114             has db => sub { die "'db' is required in constructor." };
115             has in_storage => 0;
116              
117             =head1 METHODS
118              
119             =head2 expand_sst
120              
121             ($sst, @args) = $self->expand_sst($sst, @args);
122              
123             Used to expand a given C<$sst> with variables defined by helpers.
124              
125             =over 4
126              
127             =item * %t
128              
129             Will be replaced by
. Example: "SELECT * FROM %t" becomes "SELECT * FROM users". 130               131             =item * %c 132               133             Will be replaced by L. Example: "name,email". 134               135             =item * %c= 136               137             Will be replaced by L assignment. Example: "name=?,email=?" 138               139             =item * %c? 140               141             Will be replaced by L placeholders. Example: "?,?,?" 142               143             =item * %pc 144               145             Include L in list of columns. Example: "id,name,email". 146               147             =item * \%c 148               149             Becomes a literal "%c". 150               151             =back 152               153             It is also possible to defined aliases for "%t", "%c", "%c=" and "%pc". Example: 154               155             %t.x = some_table as x 156             %c.x = x.col1 157               158             =cut 159               160             sub expand_sst { 161 0     0 1 0 my ($self, $sst, @args) = @_; 162 0         0 my $p; 163               164 0 0       0 $sst =~ s|(?columns}|ge;   0         0     0         0     0         0     0         0   165 0         0 $sst =~ s|(?columns}|ge;   0         0     0         0     0         0   166 0 0       0 $sst =~ s|(?columns}|ge;   0         0     0         0     0         0     0         0   167 0 0       0 $sst =~ s|(?pk, $self->columns}|ge;   0         0     0         0     0         0     0         0   168 0 0       0 $sst =~ s|(?table. ($1 ? " $1" : "")}|ge;   0         0     0         0   169 0         0 $sst =~ s|\\%|%|g; 170               171 0         0 return $sst, @args; 172             } 173               174             =head2 columns 175               176             @str = $self->columns; 177               178             Returns a list of columns, defined by L. 179               180             =head2 delete 181               182             $self = $self->delete; 183             $self = $self->delete(sub { my ($self, $err) = @_, ... }); 184               185             Will delete the object from database if L. 186               187             =cut 188               189             sub delete { 190 0     0 1 0 my $self = shift; 191 0 0       0 $self->_delete(@_) if $self->in_storage; 192 0         0 $self; 193             } 194               195             =head2 fresh 196               197             $self = $self->fresh; 198               199             Will mark the next relationship accessor to fetch new data from database, 200             instead of using the cached data on C<$self>. 201               202             =cut 203               204 0     0 1 0 sub fresh { $_[0]->{fresh}++; $_[0] }   0         0   205               206             =head2 load 207               208             $self = $self->load; 209             $self = $class->load(sub { my ($self, $err) = @_; }); 210               211             Used to fetch data from storage and update the object attributes. 212               213             =cut 214               215             sub load { 216 0     0 1 0 my $self = shift; 217 0         0 $self->_find(@_); 218 0         0 $self; 219             } 220               221             =head2 save 222               223             $self = $self->save; 224             $self = $self->save(sub { my ($self, $err) = @_, ... }); 225               226             Will update the object in database if L or insert it if not. 227               228             =cut 229               230             sub save { 231 0     0 1 0 my $self = shift; 232 0 0       0 $self->in_storage ? $self->_update(@_) : $self->_insert(@_); 233 0         0 $self; 234             } 235               236             =head2 import 237               238             Will set up the caller class with L functionality if "-base" 239             is given as argument. See L for example. 240               241             =cut 242               243             # Most of this code is copy/paste from Mojo::Base 244             sub import { 245 10     10   954 my $class = shift; 246 10 100       9772 return unless my $flag = shift; 247               248 6 50 0     24 if ($flag eq '-base') { $flag = $class }   6 0       12       0           249 0         0 elsif ($flag eq '-strict') { $flag = undef } 250             elsif ((my $file = $flag) && !$flag->can('new')) { 251 0         0 $file =~ s!::|'!/!g; 252 0         0 require "$file.pm"; 253             } 254               255 6 50       27 if ($flag) { 256 6         18 my $caller = caller; 257 6         44 my $table = Mojo::Util::decamelize((split /::/, $caller)[-1]); 258 6         147 $table =~ s!s?$!s!; # user => users 259 6     11   41 Mojo::Util::monkey_patch($caller, col => sub { $caller->_define_col(@_) });   11     11   476   260 6 50   2   134 Mojo::Util::monkey_patch($caller, columns => sub { @{$COLUMNS{$caller} || []} });   2     2   8     2         36   261 6     3   117 Mojo::Util::monkey_patch($caller, has => sub { Mojo::Base::attr($caller, @_) });   1     1   48   262 6     9   111 Mojo::Util::monkey_patch($caller, has_many => sub { $caller->_define_has_many(@_) });   8     8   243   263             Mojo::Util::monkey_patch($caller, 264 6 100   15   113 pk => sub { return UNIVERSAL::isa($_[0], $caller) ? $PK{$caller} : $caller->_define_pk(@_) });   15     15   111068   265 6 100   10   114 Mojo::Util::monkey_patch($caller, table => sub { $table = $_[0] unless UNIVERSAL::isa($_[0], $caller); $table });   7     7   3962     7         25   266 5     5   29 no strict 'refs';   5         9     5         13245   267 6         89 push @{"${caller}::ISA"}, $flag;   6         85   268             } 269               270 6         156 $_->import for qw(strict warnings utf8); 271 6         5314 feature->import(':5.10'); 272             } 273               274             sub _delete { 275 0     2   0 my ($self, $cb) = @_; 276 0         0 my @sst = $self->_delete_sst; 277               278 0         0 warn "[Mad::Mapper::delete] ", Mojo::JSON::encode_json(\@sst), "\n" if DEBUG; 279               280 0 0       0 if ($cb) { 281 0         0 weaken $self; 282             $self->db->query( 283             @sst, 284             sub { 285 0     0   0 my ($db, $err, $res) = @_; 286 0         0 warn "[Mad::Mapper::delete] err=$err\n" if DEBUG and $err; 287 0 0       0 $self->in_storage(0) unless $err; 288 0         0 $self->$cb($err); 289             } 290 0         0 ); 291             } 292             else { 293 0         0 $self->db->query(@sst); 294 0         0 $self->in_storage(0); 295             } 296             } 297               298             sub _delete_sst { 299 0     0   0 my $self = shift; 300 0         0 my $pk = $self->_pk_or_first_column; 301               302 0         0 $self->expand_sst("DELETE FROM %t WHERE $pk=?"), $self->$pk; 303             } 304               305             sub _define_col { 306 11   33 11   48 my $class = ref($_[0]) || $_[0]; 307 11 50       15 push @{$COLUMNS{$class}}, ref $_[0] eq 'ARRAY' ? @{$_[1]} : $_[1];   11         48     0         0   308 11         35 Mojo::Base::attr(@_); 309             } 310               311             sub _define_has_many { 312 8     8   20 my ($class, $method, $related_class, $related_col) = @_; 313 8         30 my $pk = $class->_pk_or_first_column; 314 8         75 my $sst_method = $class->can("_has_many_${method}_sst"); 315               316             Mojo::Util::monkey_patch( 317             $class => $method => sub { 318 0 0   0   0 my $cb = ref $_[-1] eq 'CODE' ? pop : undef;         0               0       319 0         0 my $self = shift; 320 0 0       0 my $err = $LOADED{$related_class}++ ? 0 : load_class $related_class; 321 0         0 my $fresh = delete $self->{fresh}; 322 0   0     0 my $ck = join ':', $method, grep { $_ // '' } @_;   0         0   323 0         0 my @sst; 324               325 0 0       0 die ref $err ? "Exception: $err" : "Could not find class $related_class!" if $err;     0           326               327             @sst 328 0 0       0 = $sst_method 329             ? $self->$sst_method($related_class, @_) 330             : $related_class->expand_sst("SELECT %pc FROM %t WHERE $related_col=?", $self->$pk); 331               332             warn sprintf "[Mad::Mapper::has_many::$method] %s\n", 333 0         0 (!$fresh and $self->{cache}{$ck}) ? 'CACHED' : Mojo::JSON::encode_json(\@sst) 334             if DEBUG; 335               336 0 0       0 if ($cb) { 337 0 0 0     0 if ($fresh or !$self->{cache}{$ck}) { 338             $self->db->query( 339             @sst, 340             sub { 341 0     0   0 my ($db, $err, $res) = @_; 342 0         0 warn "[Mad::Mapper::has_many::$method] err=$err\n" if DEBUG and $err; 343 0         0 $self->{cache}{$ck} = $res->hashes->map(sub { $related_class->new($_)->in_storage(1) });   0         0   344 0         0 $self->$cb($err, $self->{cache}{$ck}); 345             } 346 0         0 ); 347             } 348             else { 349 0         0 $self->$cb('', $self->{cache}{$ck}); 350             } 351 0         0 return $self; 352             } 353             else { 354 0 0       0 delete $self->{cache}{$ck} if $fresh; 355             return $self->{cache}{$ck} 356 0   0 0   0 ||= $self->db->query(@sst)->hashes->map(sub { $related_class->new($_)->in_storage(1) });   0         0   357             } 358             } 359 8         56 ); 360               361 8         152 my $add_method = "add_$method"; 362 8         35 $add_method =~ s!s?$!!; 363             Mojo::Util::monkey_patch( 364             $class => $add_method => sub { 365 0     0   0 my $self = shift;         0               0       366 0 0       0 my $err = $LOADED{$related_class}++ ? 0 : load_class $related_class; 367 0         0 $related_class->new(db => $self->db, @_, $related_col => $self->$pk); 368             } 369 8         42 ); 370             } 371               372             sub _define_pk { 373 6   33 6   30 my $class = ref($_[0]) || $_[0]; 374 6         17 $PK{$class} = $_[1]; 375 6         25 Mojo::Base::attr(@_); 376             } 377               378             sub _find { 379 0     0   0 my ($self, $cb) = @_; 380 0         0 my @sst = $self->_find_sst; 381               382 0         0 warn "[Mad::Mapper::find] ", Mojo::JSON::encode_json(\@sst), "\n" if DEBUG; 383 0 0       0 if ($cb) { 384 0         0 weaken $self; 385             $self->db->query( 386             @sst, 387             sub { 388 0     0   0 my ($db, $err, $res) = @_; 389 0         0 warn "[Mad::Mapper::find] err=$err\n" if DEBUG and $err; 390 0 0 0     0 $res = $err ? {} : $res->hash || {}; 391 0 0 0     0 $self->in_storage(1) if %$res and !$err; 392 0         0 $self->{$_} = $res->{$_} for keys %$res; 393 0         0 $self->$cb($err); 394             } 395 0         0 ); 396             } 397             else { 398 0   0     0 my $res = $self->db->query(@sst)->hash || {}; 399 0 0       0 $self->in_storage(1) if keys %$res; 400 0         0 $self->{$_} = $res->{$_} for keys %$res; 401             } 402             } 403               404             sub _find_sst { 405 0     0   0 my $self = shift; 406 0         0 my $pk = $self->_pk_or_first_column; 407               408 0         0 $self->expand_sst("SELECT %pc FROM %t WHERE $pk=?"), $self->$pk; 409             } 410               411             sub _insert { 412 0     0   0 my ($self, $cb) = @_; 413 0         0 my $pk = $self->_pk_or_first_column; 414 0         0 my $db = $self->db; 415 0         0 my @sst = $self->_insert_sst; 416               417 0         0 warn "[Mad::Mapper::insert] ", Mojo::JSON::encode_json(\@sst), "\n" if DEBUG; 418               419 0 0       0 if ($cb) { 420 0         0 weaken $self; 421             $db->query( 422             @sst, 423             sub { 424 0     0   0 my ($db, $err, $res) = @_; 425 0         0 warn "[Mad::Mapper::insert] err=$err\n" if DEBUG and $err; 426 0   0     0 $res = eval { $res->hash } || {}; 427               428 0 0       0 if ($pk) { 429 0   0     0 $res->{$pk} ||= $db->dbh->last_insert_id(undef, undef, $self->table, $self->pk); 430 0   0     0 $res->{$pk} ||= eval { $res->sth->mysql_insertid }; # can probably be removed   0         0   431             } 432               433 0 0       0 $self->in_storage(1) if keys %$res; 434 0         0 $self->$_($res->{$_}) for grep { $self->can($_) } keys %$res;   0         0   435 0         0 $self->$cb($err); 436             } 437 0         0 ); 438             } 439             else { 440 0         0 my $res = $db->query(@sst); 441 0   0     0 $res = eval { $res->hash } || {}; 442               443 0 0       0 if ($pk) { 444 0   0     0 $res->{$pk} ||= $db->dbh->last_insert_id(undef, undef, $self->table, $self->pk); 445 0   0     0 $res->{$pk} ||= eval { $res->sth->mysql_insertid } # can probably be removed;   0         0   446             } 447               448 0 0       0 $self->in_storage(1) if keys %$res; 449 0         0 $self->$_($res->{$_}) for grep { $self->can($_) } keys %$res; # used with Mojo::Pg and RETURNING   0         0   450             } 451             } 452               453             sub _insert_sst { 454 0     0   0 my $self = shift; 455 0         0 my $pk = $self->pk; 456 0         0 my $sql = "INSERT INTO %t (%c) VALUES (%c?)"; 457               458 0 0 0     0 $sql .= " RETURNING $pk" if $pk and UNIVERSAL::isa($self->db, 'Mojo::Pg::Database'); 459 0         0 $self->expand_sst($sql), map { $self->$_ } $self->columns;   0         0   460             } 461               462 8 50   8   22 sub _pk_or_first_column { $_[0]->pk || ($_[0]->columns)[0] } 463               464             sub _update { 465 0     0   0 my ($self, $cb) = @_; 466 0         0 my @sst = $self->_update_sst; 467               468 0         0 warn "[Mad::Mapper::update] ", Mojo::JSON::encode_json(\@sst), "\n" if DEBUG; 469               470 0 0       0 if ($cb) { 471 0         0 weaken $self; 472             $self->db->query( 473             @sst, 474             sub { 475 0     0   0 my ($db, $err, $res) = @_; 476 0         0 warn "[Mad::Mapper::update] err=$err\n" if DEBUG and $err; 477 0         0 $self->$cb($err); 478             } 479 0         0 ); 480             } 481             else { 482 0         0 $self->db->query(@sst); 483             } 484             } 485               486             sub _update_sst { 487 0     0   0 my $self = shift; 488 0         0 my $pk = $self->_pk_or_first_column; 489               490 0         0 $self->expand_sst("UPDATE %t SET %c= WHERE $pk=?"), (map { $self->$_ } $self->columns), $self->$pk;   0         0   491             } 492               493             sub TO_JSON { 494 1     1 0 2989 my $self = shift; 495 1         4 my $pk = $self->pk; 496 1 50       6 return {$pk ? ($pk => $self->$pk) : (), map { ($_ => $self->$_) } $self->columns};   3         18   497             } 498               499             =head1 COPYRIGHT AND LICENSE 500               501             Copyright (C) 2014, Jan Henning Thorsen 502               503             This program is free software, you can redistribute it and/or modify it under 504             the terms of the Artistic License version 2.0. 505               506             =head1 AUTHOR 507               508             Jan Henning Thorsen - C 509               510             Красимир Беров - C 511               512             =cut 513               514             1;