package Fey::Object::Table; use strict; use warnings; use Fey::Literal::Function; use Fey::Placeholder; use Fey::SQL; use Fey::Table; use List::MoreUtils qw( all ); use Scalar::Util qw( blessed ); use Fey::Exceptions qw( param_error ); use Fey::ORM::Exceptions qw( no_such_row ); use Moose; extends 'Moose::Object'; with 'MooseX::StrictConstructor::Role::Object'; sub new { my $class = shift; if ( $class->meta()->_object_cache_is_enabled() ) { my $instance = $class->meta()->_search_cache( ref $_[0] ? $_[0] : { @_ } ); return $instance if $instance; } my $instance = eval { $class->SUPER::new(@_) }; if ( my $e = $@ ) { return if blessed $e && $e->isa('Fey::Exception::NoSuchRow'); die $e; } $class->meta()->_write_to_cache($instance) if $class->meta()->_object_cache_is_enabled(); return $instance; } sub BUILD { my $self = shift; my $p = shift; if ( delete $p->{_from_query} ) { $self->_require_pk($p); return; }; $self->_load_from_dbms($p); return; } sub _require_pk { my $self = shift; my $p = shift; return if all { defined $p->{$_} } map { $_->name() } @{ $self->Table()->primary_key() }; my $package = ref $self; param_error "$package->new() requires that you pass the primary key if you set _from_query to true."; } sub EnableObjectCache { my $class = shift; $class->meta()->_set_object_cache_is_enabled(1); } sub DisableObjectCache { my $class = shift; $class->meta()->_set_object_cache_is_enabled(0); } sub ClearObjectCache { my $class = shift; $class->meta()->_clear_object_cache(); } sub _load_from_dbms { my $self = shift; my $p = shift; for my $key ( @{ $self->Table()->candidate_keys() } ) { my @names = map { $_->name() } @{ $key }; next unless all { defined $p->{$_} } @names; return if $self->_load_from_key( $key, [ @{ $p }{ @names } ] ); } my $error = 'Could not find a row in ' . $self->Table()->name(); $error .= ' matching the values you provided to the constructor.'; no_such_row $error; } sub _load_from_key { my $self = shift; my $key = shift; my $bind = shift; my $select = $self->_SelectSQLForKey($key); return 1 if $self->_get_column_values( $select, $bind ); my $error = 'Could not find a row in ' . $self->Table()->name(); $error .= ' where '; my @where; for ( my $i = 0; $i < @{ $key }; $i++ ) { push @where, $key->[$i]->name() . q{ = } . $bind->[$i]; } $error .= join ', ', @where; no_such_row $error; } sub insert { my $class = shift; my %p = @_; return $class->insert_many(\%p); } sub insert_many { my $class = shift; my @rows = @_; my $insert = $class->_insert_for_data( $rows[0] ); my $dbh = $class->_dbh($insert); my $sth = $dbh->prepare( $insert->sql($dbh) ); my @auto_inc_columns = ( grep { ! exists $rows[0]->{$_} } map { $_->name() } grep { $_->is_auto_increment() } $class->Table->columns() ); my $table_name = $class->Table()->name(); my @non_literal_row_keys; my @literal_row_keys; my @ref_row_keys; for my $key ( sort keys %{ $rows[0] } ) { if ( blessed $rows[0]{$key} && $rows[0]{$key}->isa('Fey::Literal') ) { push @literal_row_keys, $key; push @ref_row_keys, $key; } else { push @non_literal_row_keys, $key; push @ref_row_keys, $key if ref $rows[0]{$key}; } } my @bind_attributes = $class->_bind_attributes_for( $dbh, @non_literal_row_keys ); my $wantarray = wantarray; my @objects; for my $row (@rows) { push @objects, $class->_insert_one_row ( $row, $dbh, $sth, \@non_literal_row_keys, \@ref_row_keys, \@bind_attributes, \@auto_inc_columns, $table_name, $wantarray, ); } return $wantarray ? @objects : $objects[0]; } sub _bind_attributes_for { my $self = shift; my $dbh = shift; my @keys = @_; return unless $dbh->{Driver}{Name} eq 'Pg'; my @attr = map { lc $self->Table()->column($_)->type() eq 'bytea' ? { pg_type => DBD::Pg::PG_BYTEA() } : {} } @keys; return unless grep { keys %{ $_ } } @attr; return @attr; } sub _insert_one_row { my $class = shift; # This is really grotesque my $row = shift; my $dbh = shift; my $sth = shift; my $non_literal_row_keys = shift; my $ref_row_keys = shift; my $bind_attributes = shift; my $auto_inc_columns = shift; my $table_name = shift; my $wantarray = shift; $class->_sth_execute( $sth, [ map { $class->_deflated_value( $_, $row->{$_} ) } @{ $non_literal_row_keys } ], $bind_attributes, ); return unless defined $wantarray; my %auto_inc; for my $col ( @{ $auto_inc_columns } ) { $auto_inc{$col} = $dbh->last_insert_id( undef, undef, $table_name, $col ); } delete @{ $row }{ @{ $ref_row_keys } } if @{ $ref_row_keys }; return $class->new( %{ $row }, %auto_inc, _from_query => 1 ); } sub _sth_execute { my $self = shift; my $sth = shift; my $vals = shift; my $attr = shift; if ( @{ $attr } ) { for ( my $i = 0; $i < @{ $vals }; $i++ ) { $sth->bind_param( $i + 1, $vals->[$i], $attr->[$i] ); } return $sth->execute(); } else { return $sth->execute( @{ $vals } ); } } sub _deflated_value { my $self = shift; my $name = shift; my $val = @_ ? shift : $self->$name(); my $meth = $self->meta()->deflator_for($name); return $meth ? $self->$meth($val) : $val; } sub _insert_for_data { my $class = shift; my $data = shift; my $insert = $class->SchemaClass()->SQLFactoryClass()->new_insert(); my $table = $class->Table(); $insert->into( $table->columns( sort keys %{ $data } ) ); my $ph = Fey::Placeholder->new(); my @vals = ( map { $_ => ( blessed $data->{$_} && $data->{$_}->isa('Fey::Literal') ? $data->{$_} : $ph ) } sort keys %{ $data } ); $insert->values(@vals); return $insert; } sub update { my $self = shift; my %p = @_; my $update = $self->SchemaClass()->SQLFactoryClass()->new_update(); my $table = $self->Table(); $update->update($table); $update->set( map { $table->column($_) => $self->_deflated_value( $_, $p{$_} ) } sort keys %p ); for my $col ( @{ $table->primary_key() } ) { my $name = $col->name(); $update->where( $col, '=', $self->_deflated_value($name) ); } my $dbh = $self->_dbh($update); my $sth = $dbh->prepare( $update->sql($dbh) ); my @attr = $self->_bind_attributes_for( $dbh, ( sort keys %p, map { $_->name() } @{ $table->primary_key() } ), ); $self->_sth_execute( $sth, [ $update->bind_params() ], \@attr ); for my $k ( sort keys %p ) { if ( ref $p{$k} ) { my $clear = q{_clear_} . $k; $self->$clear(); } else { my $set = q{_set_} . $k; $self->$set( $p{$k} ); } } return; } sub delete { my $self = shift; my $delete = $self->SchemaClass()->SQLFactoryClass()->new_delete(); my $table = $self->Table(); $delete->from($table); for my $col ( @{ $table->primary_key() } ) { my $name = $col->name(); $delete->where( $col, '=', $self->_deflated_value($name) ); } my $dbh = $self->_dbh($delete); $dbh->do( $delete->sql($dbh), {}, $delete->bind_params() ); return; } sub _get_column_value { my $self = shift; my $col_values = $self->_get_column_values( $self->meta()->_select_by_pk_sql(), [ $self->pk_values_list() ], ); my $name = shift; return $col_values->{$name}; } # Based on discussions on #moose, this could be done more elegantly # with a custom instance metaclass that lazily initializes a batch of # attributes at once. sub _get_column_values { my $self = shift; my $select = shift; my $bind = shift; my $dbh = $self->_dbh($select); my $sth = $dbh->prepare( $select->sql($dbh) ); $sth->execute( @{ $bind } ); my %col_values; $sth->bind_columns( \( @col_values{ @{ $sth->{NAME} } } ) ); my $fetched = $sth->fetch(); $sth->finish(); return unless $fetched; $self->_set_column_values_from_hashref( \%col_values ); return \%col_values; } sub _set_column_values_from_hashref { my $self = shift; my $values = shift; for my $col ( keys %{ $values } ) { my $set = q{_set_} . $col; my $has = q{has_} . $col; $self->$set( $values->{$col} ) unless $self->$has(); } } sub _dbh { my $self = shift; my $sql = shift; my $source = $self->SchemaClass()->DBIManager()->source_for_sql($sql); die "Could not get a source for this sql ($sql)" unless $source; return $source->dbh(); } sub pk_values_hash { my $self = shift; my @vals = $self->pk_values_list() or return; my @cols = ( map { $_->name() } @{ $self->Table()->primary_key() } ); return map { $_ => $self->_deflated_value($_) } @cols; } sub pk_values_list { my $self = shift; my @cols = ( map { $_->name() } @{ $self->Table()->primary_key() } ); return map { $self->_deflated_value($_) } @cols; } sub _MakeSelectByPKSQL { my $class = shift; return $class->_SelectSQLForKey( $class->Table->primary_key() ); } sub _SelectSQLForKey { my $class = shift; my $key = shift; my $cache = $class->meta()->_select_sql_cache(); my $select = $cache->get($key); return $select if $select; my $table = $class->Table(); my %key = map { $_->name() => 1 } @{ $key }; my @non_key = grep { ! $key{ $_->name() } } $table->columns(); # This is a bit of a hack for tables that consist just of a key # (like a UserGroup table with a user_id and group_id). We need to # select _something_ or else shit blows up. my @select = @non_key ? @non_key : @{ $key }; $select = $class->SchemaClass()->SQLFactoryClass()->new_select(); $select->select( sort { $a->name() cmp $b->name() } @select ); $select->from($table); $select->where( $_, '=', Fey::Placeholder->new() ) for @{ $key }; $cache->store( $key => $select ); return $select; } sub Count { my $class = shift; my $select = $class->meta()->_count_sql(); my $dbh = $class->_dbh($select); my $row = $dbh->selectcol_arrayref( $select->sql($dbh) ); return $row->[0]; } sub Table { my $class = shift; return $class->meta()->table(); } sub SchemaClass { my $class = shift; return $class->meta()->schema_class(); } no Moose; __PACKAGE__->meta()->make_immutable(); 1; __END__ =head1 NAME Fey::Object::Table - Base class for table-based objects =head1 SYNOPSIS package MyApp::User; use Fey::ORM::Table; has_table(...); =head1 DESCRIPTION This class is a the base class for all table-based objects. It implements a large amount of the core L<Fey::ORM> functionality, including CRUD (create, update, delete) and loading of data from the DBMS. =head1 METHODS This class provides the following methods: =head2 $class->new(...) This method overrides the default C<Moose::Object> constructor in order to implement cache management. By default, object caching is disabled. In that case, this method lets its parent class do most of the work. However, unlike the standard Moose constructor, this method may sometimes not return an object. If it attempts to load object data from the DBMS and cannot find anything matching the parameters given to the constructor, it will return false. When this happens you can check C<$@> for details on the error. If caching is enabled, then this method will attempt to find a matching object in the cache. A match is determined by looking for an object which has a candidate key with the same values as are passed to the constructor. If no match is found, it attempts to create a new object. If this succeeds, it stores it in the cache before returning it. =head3 Constructor Parameters The constructor accepts any attribute of the class as a parameter. This includes any column-based attributes, as well as any additional attributes defined by C<has_one()> or C<has_many()>. Of course, if you disabled caching for C<has_one()> or C<has_many()> relationships, then they are implemented as simple methods, not attributes. If you define additional methods via Moose's C<has()> function, and these will be accepted by the constructor as well. Finally, the constructor accepts a parameter C<_from_query>. This tells the constructor that the parameters passed to the constructor are the result of a C<SELECT>. This stops the C<BUILD()> method from attempting to load the object from the DBMS. However, you still must pass values for the primary key, so that the object is identifiable in the DBMS. =head2 $class->EnableObjectCache() =head2 $class->DisableObjectCache() These methods enable or disable the object cache for the calling class. =head2 $class->Count() Returns the number of rows in the class's associated table. =head2 $class->ClearObjectCache() Clears the object cache for the calling class. =head3 $class->Table() Returns the L<Fey::Table> object passed to C<has_table()>. =head3 $class->SchemaClass() Returns the name of the class associated with the class's table's schema. =head2 $class->insert(%values) Given a hash of column names and values, this method inserts a new row for the class's table, and returns a new object for that row. The values for the columns can be plain scalars or object. Values will be passed through the appropriate deflators. You can also pass L<Fey::Literal> objects of any type. As an optimization, no object will be created in void context. =head2 $class->insert_many( \%values, \%values, ... ) This method allows you to insert multiple rows efficiently. It expects an array of hash references. Each hash reference should contain the same set of column names as its keys. The advantage of using this method is that under the hood it uses the same C<DBI> statement handle repeatedly. If you were to call C<< $class->insert() >> repeatedly it would have to recreate the same SQL and DBI statement handle repeatedly. In scalar context, it returns the first object created. In list context, it returns all the objects created. As an optimization, no objects will be created in void context. =head2 $object->update(%values) This method accepts a hash of column keys and values, just like C<< $class->insert() >>. However, it instead updates the values for an existing object's row. It will also make sure that the object's attributes are updated properly. In some cases, it will just clear the attribute, forcing it to be reloaded the next time it is accessed. This is necesasry when the update value was a L<Fey::Literal>, since that could be a function that gets interpreted by the DBMS, such as C<NOW()>. =head2 $object->delete() This method delete's the object's associated row from the DBMS. The object is still usable after this method is called, but if you attempt to call any method that tries to access the DBMS it will probably blow up. =head2 $object->pk_values_hash() Returns a hash representing the names and values for the object's primary key. The values are returned in their raw form, regardless of any transforms specific for a primary key column. This may return an empty hash if the primary key for the object has not yet been determined. This can happen if you try to call this method on an object before its attributes have been fetched from the dbms. =head2 $object->pk_values_list() Returns a list of values for the object's primary key. The values are returned in the same order as C<< $self->primary_key() >> returns the columns. The values are returned in their raw form, regardless of any transforms specific for a primary key column. This may return an empty list if the primary key for the object has not yet been determined. =head1 METHODS FOR SUBCLASSES Since your table-based class will be a subclass of this object, there are several methods you may want to use that are not intended for use outside of your subclasses. You may also want to subclass some of these methods in this class. =head2 $class->_dbh($sql) Given a L<Fey::SQL> object, this method returns an appropriate C<DBI> object for that SQL. Internally, it calls C<source_for_sql()> on the schema class's L<Fey::DBIManager> object and then calls C<< $source->dbh() >> on the source. If there is no source for the given SQL, it will die. =head2 $object->_load_from_dbms($params) This method will be called as part of object construction (unless C<_from_query> was true). By default, this method attempts to find a row in the associated table by looking at each of the table's candidate keys in turn. If the parameters passed to the constructor include values for all parts of a key, it does a select to find a matching row. You can override this method in order to attempt to load an object based on some other method. For example, if your user table stores a username and a hashed password, you could accept an I<unhashed> password, and then do a lookup based on the hashed value. This method is expected to create a C<SELECT> statement and then pass the statement and bind parameters to C<< $object->_get_column_values() >>. On success, this method should simply return. If it fails, it should throw a L<Fey::Exception::NoSuchRow> exception. See L<Fey::ORM::Exceptions> for details. =head2 $object->_get_column_values( $select, $bind_params ) This method takes a C<SELECT> statement and an array reference of bind parameters. The C<SELECT> is expected to find a single row, which should correspond to the current object. If it finds a row, it sets the corresponding attributes in the object based on the values returns by the C<SELECT>. =head1 AUTHOR Dave Rolsky, <autarch@urth.org> =head1 BUGS See L<Fey::ORM> for details. =head1 COPYRIGHT & LICENSE Copyright 2006-2009 Dave Rolsky, All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut