diff --git a/extlib/Data/ObjectDriver.pm b/extlib/Data/ObjectDriver.pm new file mode 100644 index 000000000..e7b4e4ba1 --- /dev/null +++ b/extlib/Data/ObjectDriver.pm @@ -0,0 +1,793 @@ +# $Id: ObjectDriver.pm 560 2009-01-28 18:37:28Z btrott $ + +package Data::ObjectDriver; +use strict; +use warnings; +use Class::Accessor::Fast; + +use base qw( Class::Accessor::Fast ); +use Data::ObjectDriver::Iterator; + +__PACKAGE__->mk_accessors(qw( pk_generator txn_active )); + +our $VERSION = '0.06'; +our $DEBUG = $ENV{DOD_DEBUG} || 0; +our $PROFILE = $ENV{DOD_PROFILE} || 0; +our $PROFILER; +our $LOGGER; + +sub new { + my $class = shift; + my $driver = bless {}, $class; + $driver->init(@_); + $driver; +} + +sub logger { + my $class = shift; + if ( @_ ) { + return $LOGGER = shift; + } else { + return $LOGGER ||= sub { + print STDERR @_; + }; + } +} + +sub init { + my $driver = shift; + my %param = @_; + $driver->pk_generator($param{pk_generator}); + $driver->txn_active(0); + $driver; +} + +# Alias record_query to start_query +*record_query = \*start_query; + +sub start_query { + my $driver = shift; + my($sql, $bind) = @_; + + $driver->debug($sql, $bind) if $DEBUG; + $driver->profiler($sql) if $PROFILE; + + return; +} + +sub end_query { } + +sub begin_work { + my $driver = shift; + $driver->txn_active(1); + $driver->debug(sprintf("%14s", "BEGIN_WORK") . ": driver=$driver"); +} + +sub commit { + my $driver = shift; + _end_txn($driver, 'commit'); +} + +sub rollback { + my $driver = shift; + _end_txn($driver, 'rollback'); +} + +sub _end_txn { + my $driver = shift; + my $method = shift; + $driver->txn_active(0); + $driver->debug(sprintf("%14s", uc($method)) . ": driver=$driver"); +} + +sub debug { + my $driver = shift; + return unless $DEBUG; + + my $class = ref $driver || $driver; + my @caller; + my $i = 0; + while (1) { + @caller = caller($i++); + last if $caller[0] !~ /^(Data::ObjectDriver|$class)/; + } + + my $where = " in file $caller[1] line $caller[2]\n"; + + if (@_ == 1 && !ref($_[0])) { + $driver->logger->( @_, $where ); + } else { + require Data::Dumper; + local $Data::Dumper::Indent = 1; + $driver->logger->( Data::Dumper::Dumper(@_), $where ); + } +} + +sub profiler { + my $driver = shift; + my ($sql) = @_; + $PROFILER ||= eval { + require Data::ObjectDriver::Profiler; + Data::ObjectDriver::Profiler->new; + }; + return $PROFILE = 0 if $@ || !$PROFILER; + return $PROFILER unless @_; + $PROFILER->record_query($driver, $sql); +} + +sub list_or_iterator { + my $driver = shift; + my($objs) = @_; + + ## Emulate the standard search behavior of returning an + ## iterator in scalar context, and the full list in list context. + if (wantarray) { + return @{$objs}; + } else { + my $iter = sub { shift @{$objs} }; + return Data::ObjectDriver::Iterator->new($iter); + } +} + +sub cache_object { } +sub uncache_object { } + +1; +__END__ + +=head1 NAME + +Data::ObjectDriver - Simple, transparent data interface, with caching + +=head1 SYNOPSIS + + ## Set up your database driver code. + package FoodDriver; + sub driver { + Data::ObjectDriver::Driver::DBI->new( + dsn => 'dbi:mysql:dbname', + username => 'username', + password => 'password', + ) + } + + ## Set up the classes for your recipe and ingredient objects. + package Recipe; + use base qw( Data::ObjectDriver::BaseObject ); + __PACKAGE__->install_properties({ + columns => [ 'recipe_id', 'title' ], + datasource => 'recipe', + primary_key => 'recipe_id', + driver => FoodDriver->driver, + }); + + package Ingredient; + use base qw( Data::ObjectDriver::BaseObject ); + __PACKAGE__->install_properties({ + columns => [ 'ingredient_id', 'recipe_id', 'name', 'quantity' ], + datasource => 'ingredient', + primary_key => [ 'recipe_id', 'ingredient_id' ], + driver => FoodDriver->driver, + }); + + ## And now, use them! + my $recipe = Recipe->new; + $recipe->title('Banana Milkshake'); + $recipe->save; + + my $ingredient = Ingredient->new; + $ingredient->recipe_id($recipe->id); + $ingredient->name('Bananas'); + $ingredient->quantity(5); + $ingredient->save; + + ## Needs more bananas! + $ingredient->quantity(10); + $ingredient->save; + + ## Shorthand constructor + my $ingredient = Ingredient->new(recipe_id=> $recipe->id, + name => 'Milk', + quantity => 2); + +=head1 DESCRIPTION + +I is an object relational mapper, meaning that it maps +object-oriented design concepts onto a relational database. + +It's inspired by, and descended from, the I classes in +Six Apart's Movable Type and TypePad weblogging products. But it adds in +caching and partitioning layers, allowing you to spread data across multiple +physical databases, without your application code needing to know where the +data is stored. + +It's currently considered ALPHA code. The API is largely fixed, but may seen +some small changes in the future. For what it's worth, the likeliest area +for changes are in the syntax for the I method, and would most +likely not break much in the way of backwards compatibility. + +=head1 METHODOLOGY + +I provides you with a framework for building +database-backed applications. It provides built-in support for object +caching and database partitioning, and uses a layered approach to allow +building very sophisticated database interfaces without a lot of code. + +You can build a driver that uses any number of caching layers, plus a +partitioning layer, then a final layer that actually knows how to load +data from a backend datastore. + +For example, the following code: + + my $driver = Data::ObjectDriver::Driver::Cache::Memcached->new( + cache => Cache::Memcached->new( + servers => [ '127.0.0.1:11211' ], + ), + fallback => Data::ObjectDriver::Driver::Partition->new( + get_driver => \&get_driver, + ), + ); + +creates a new driver that supports both caching (using memcached) and +partitioning. + +It's useful to demonstrate the flow of a sample request through this +driver framework. The following code: + + my $ingredient = Ingredient->lookup([ $recipe->recipe_id, 1 ]); + +would take the following path through the I framework: + +=over 4 + +=item 1. + +The caching layer would look up the object with the given primary key in all +of the specified memcached servers. + +If the object was found in the cache, it would be returned immediately. + +If the object was not found in the cache, the caching layer would fall back +to the driver listed in the I setting: the partitioning layer. + +=item 2. + +The partitioning layer does not know how to look up objects by itself--all +it knows how to do is to give back a driver that I know how to look +up objects in a backend datastore. + +In our example above, imagine that we're partitioning our ingredient data +based on the recipe that the ingredient is found in. For example, all of +the ingredients for a "Banana Milkshake" would be found in one partition; +all of the ingredients for a "Chocolate Sundae" might be found in another +partition. + +So the partitioning layer needs to tell us which partition to look in to +load the ingredients for I<$recipe-Erecipe_id>. If we store a +I column along with each I<$recipe> object, that information +can be loaded very easily, and the partitioning layer will then +instantiate a I driver that knows how to load an ingredient from +that recipe. + +=item 3. + +Using the I driver that the partitioning layer created, +I can look up the ingredient with the specified primary +key. It will return that key back up the chain, giving each layer a chance +to do something with it. + +=item 4. + +The caching layer, when it receives the object loaded in Step 3, will +store the object in memcached. + +=item 5. + +The object will be passed back to the caller. Subsequent lookups of that +same object will come from the cache. + +=back + +=head1 HOW IS IT DIFFERENT? + +I differs from other similar frameworks +(e.g. L) in a couple of ways: + +=over 4 + +=item * It has built-in support for caching. + +=item * It has built-in support for data partitioning. + +=item * Drivers are attached to classes, not to the application as a whole. + +This is essential for partitioning, because your partition drivers need +to know how to load a specific class of data. + +But it can also be useful for caching, because you may find that it doesn't +make sense to cache certain classes of data that change constantly. + +=item * The driver class != the base object class. + +All of the object classes you declare will descend from +I, and all of the drivers you instantiate +or subclass will descend from I itself. + +This provides a useful distinction between your data/classes, and the +drivers that describe how to B on that data, meaning that an +object based on I is not tied to any +particular type of driver. + +=back + +=head1 USAGE + +=head2 Class->lookup($id) + +Looks up/retrieves a single object with the primary key I<$id>, and returns +the object. + +I<$id> can be either a scalar or a reference to an array, in the case of +a class with a multiple column primary key. + +=head2 Class->lookup_multi(\@ids) + +Looks up/retrieves multiple objects with the IDs I<\@ids>, which should be +a reference to an array of IDs. As in the case of I, an ID can +be either a scalar or a reference to an array. + +Returns a reference to an array of objects B as the IDs +you passed in. Any objects that could not successfully be loaded will be +represented in that array as an C element. + +So, for example, if you wanted to load 2 objects with the primary keys +C<[ 5, 3 ]> and C<[ 4, 2 ]>, you'd call I like this: + + Class->lookup_multi([ + [ 5, 3 ], + [ 4, 2 ], + ]); + +And if the first object in that list could not be loaded successfully, +you'd get back a reference to an array like this: + + [ + undef, + $object + ] + +where I<$object> is an instance of I. + +=head2 Class->search(\%terms [, \%options ]) + +Searches for objects matching the terms I<%terms>. In list context, returns +an array of matching objects; in scalar context, returns a reference to +a subroutine that acts as an iterator object, like so: + + my $iter = Ingredient->search({ recipe_id => 5 }); + while (my $ingredient = $iter->()) { + ... + } + +C<$iter> is blessed in L package, so the above +could also be written: + + my $iter = Ingredient->search({ recipe_id => 5 }); + while (my $ingredient = $iter->next()) { + ... + } + +The keys in I<%terms> should be column names for the database table +modeled by I (and the values should be the desired values for those +columns). + +I<%options> can contain: + +=over 4 + +=item * sort + +The name of a column to use to sort the result set. + +Optional. + +=item * direction + +The direction in which you want to sort the result set. Must be either +C or C. + +Optional. + +=item * limit + +The value for a I clause, to limit the size of the result set. + +Optional. + +=item * offset + +The offset to start at when limiting the result set. + +Optional. + +=item * fetchonly + +A reference to an array of column names to fetch in the I statement generated will include a +I clause. + +=item * comment + +A sql comment to watermark the SQL query. + +=item * window_size + +Used when requesting an iterator for the search method and selecting +a large result set or a result set of unknown size. In such a case, +no LIMIT clause is assigned, which can load all available objects into +memory. Specifying C will load objects in manageable chunks. +This will also cause any caching driver to be bypassed for issuing +the search itself. Objects are still placed into the cache upon load. + +This attribute is ignored when the search method is invoked in an array +context, or if a C attribute is also specified that is smaller than +the C. + +=back + +=head2 Class->search(\@terms [, \%options ]) + +This is an alternative calling signature for the search method documented +above. When providing an array of terms, it allows for constructing complex +expressions that mix 'and' and 'or' clauses. For example: + + my $iter = Ingredient->search([ { recipe_id => 5 }, + -or => { calories => { value => 300, op => '<' } } ]); + while (my $ingredient = $iter->()) { + ... + } + +Supported logic operators are: '-and', '-or', '-and_not', '-or_not'. + +=head2 Class->add_trigger($trigger, \&callback) + +Adds a trigger to all objects of class I, such that when the event +I<$trigger> occurs to any of the objects, subroutine C<&callback> is run. Note +that triggers will not occur for instances of I of I, only +of I itself. See TRIGGERS for the available triggers. + +=head2 Class->call_trigger($trigger, [@callback_params]) + +Invokes the triggers watching class I. The parameters to send to the +callbacks (in addition to I) are specified in I<@callback_params>. See +TRIGGERS for the available triggers. + +=head2 $obj->save + +Saves the object I<$obj> to the database. + +If the object is not yet in the database, I will automatically +generate a primary key and insert the record into the database table. +Otherwise, it will update the existing record. + +If an error occurs, I will I. + +Internally, I calls I for records that already exist in the +database, and I for those that don't. + +=head2 $obj->remove + +Removes the object I<$obj> from the database. + +If an error occurs, I will I. + +=head2 Class->remove(\%terms, \%args) + +Removes objects found with the I<%terms>. So it's a shortcut of: + + my @obj = Class->search(\%terms, \%args); + for my $obj (@obj) { + $obj->remove; + } + +However, when you pass C option set to C<%args>, it won't +create objects with C, but issues I SQL directly to +the database. + + ## issues "DELETE FROM tbl WHERE user_id = 2" + Class->remove({ user_id => 2 }, { nofetch => 1 }); + +This might be much faster and useful for tables without Primary Key, +but beware that in this case B because no +objects are instanciated. + +=head2 Class->bulk_insert([col1, col2], [[d1,d2], [d1,d2]]); + +Bulk inserts data into the underlying table. The first argument +is an array reference of columns names as specified in install_properties + +=head2 $obj->add_trigger($trigger, \&callback) + +Adds a trigger to the object I<$obj>, such that when the event I<$trigger> +occurs to the object, subroutine C<&callback> is run. See TRIGGERS for the +available triggers. Triggers are invoked in the order in which they are added. + +=head2 $obj->call_trigger($trigger, [@callback_params]) + +Invokes the triggers watching all objects of I<$obj>'s class and the object +I<$obj> specifically for trigger event I<$trigger>. The additional parameters +besides I<$obj>, if any, are passed as I<@callback_params>. See TRIGGERS for +the available triggers. + +=head1 TRIGGERS + +I provides a trigger mechanism by which callbacks can be +called at certain points in the life cycle of an object. These can be set on a +class as a whole or individual objects (see USAGE). + +Triggers can be added and called for these events: + +=over 4 + +=item * pre_save -> ($obj, $orig_obj) + +Callbacks on the I trigger are called when the object is about to be +saved to the database. For example, use this callback to translate special code +strings into numbers for storage in an integer column in the database. Note that this hook is also called when you C the object. + +Modifications to I<$obj> will affect the values passed to subsequent triggers +and saved in the database, but not the original object on which the I +method was invoked. + +=item * post_save -> ($obj, $orig_obj) + +Callbaks on the I triggers are called after the object is +saved to the database. Use this trigger when your hook needs primary +key which is automatically assigned (like auto_increment and +sequence). Note that this hooks is B called when you remove the +object. + +=item * pre_insert/post_insert/pre_update/post_update/pre_remove/post_remove -> ($obj, $orig_obj) + +Those triggers are fired before and after $obj is created, updated and +deleted. + +=item * post_load -> ($obj) + +Callbacks on the I trigger are called when an object is being +created from a database query, such as with the I and I class +methods. For example, use this callback to translate the numbers your +I callback caused to be saved I into string codes. + +Modifications to I<$obj> will affect the object passed to subsequent triggers +and returned from the loading method. + +Note I should only be used as a trigger on a class, as the object to +which the load is occuring was not previously available for triggers to be +added. + +=item * pre_search -> ($class, $terms, $args) + +Callbacks on the I trigger are called when a content addressed +query for objects of class I<$class> is performed with the I method. +For example, use this callback to translate the entry in I<$terms> for your +code string field to its appropriate integer value. + +Modifications to I<$terms> and I<$args> will affect the parameters to +subsequent triggers and what objects are loaded, but not the original hash +references used in the I query. + +Note I should only be used as a trigger on a class, as I is +never invoked on specific objects. + +=over + +The return values from your callbacks are ignored. + +Note that the invocation of callbacks is the responsibility of the object +driver. If you implement a driver that does not delegate to +I, it is I responsibility to invoke the +appropriate callbacks with the I method. + +=back + +=back + +=head1 PROFILING + +For performance tuning, you can turn on query profiling by setting +I<$Data::ObjectDriver::PROFILE> to a true value. Or, alternatively, you can +set the I environment variable to a true value before starting +your application. + +To obtain the profile statistics, get the global +I instance: + + my $profiler = Data::ObjectDriver->profiler; + +Then see the documentation for I to see the +methods on that class. + + +=head1 TRANSACTIONS + + +Transactions are supported by Data::ObjectDriver's default drivers. So each +Driver is capable to deal with transactional state independently. Additionally + class know how to turn transactions switch on +for all objects. + +In the case of a global transaction all drivers used during this time are put +in a transactional state until the end of the transaction. + +=head2 Example + + ## start a transaction + Data::ObjectDriver::BaseObject->begin_work; + + $recipe = Recipe->new; + $recipe->title('lasagnes'); + $recipe->save; + + my $ingredient = Ingredient->new; + $ingredient->recipe_id($recipe->recipe_id); + $ingredient->name("more layers"); + $ingredient->insert; + $ingredient->remove; + + if ($you_are_sure) { + Data::ObjectDriver::BaseObject->commit; + } + else { + ## erase all trace of the above + Data::ObjectDriver::BaseObject->rollback; + } + +=head2 Driver implementation + +Drivers have to implement the following methods: + +=over 4 + +=item * begin_work to initialize a transaction + +=item * rollback + +=item * commmit + +=back + +=head2 Nested transactions + +Are not supported and will result in warnings and the inner transactions +to be ignored. Be sure to B each transaction and not to let et long +running transaction open (i.e you should execute a rollback or commit for +each open begin_work). + +=head2 Transactions and DBI + +In order to make transactions work properly you have to make sure that +the C<$dbh> for each DBI drivers are shared among drivers using the same +database (basically dsn). + +One way of doing that is to define a get_dbh() subref in each DBI driver +to return the same dbh if the dsn and attributes of the connection are +identical. + +The other way is to use the new configuration flag on the DBI driver that +has been added specifically for this purpose: C. + + ## example coming from the test suite + __PACKAGE__->install_properties({ + columns => [ 'recipe_id', 'partition_id', 'title' ], + datasource => 'recipes', + primary_key => 'recipe_id', + driver => Data::ObjectDriver::Driver::Cache::Cache->new( + cache => Cache::Memory->new, + fallback => Data::ObjectDriver::Driver::DBI->new( + dsn => 'dbi:SQLite:dbname=global.db', + reuse_dbh => 1, ## be sure that the corresponding dbh is shared + ), + ), + }); + +=head1 EXAMPLES + +=head2 A Partitioned, Caching Driver + + package Ingredient; + use strict; + use base qw( Data::ObjectDriver::BaseObject ); + + use Data::ObjectDriver::Driver::DBI; + use Data::ObjectDriver::Driver::Partition; + use Data::ObjectDriver::Driver::Cache::Cache; + use Cache::Memory; + use Carp; + + our $IDs; + + __PACKAGE__->install_properties({ + columns => [ 'ingredient_id', 'recipe_id', 'name', 'quantity', ], + datasource => 'ingredients', + primary_key => [ 'recipe_id', 'ingredient_id' ], + driver => + Data::ObjectDriver::Driver::Cache::Cache->new( + cache => Cache::Memory->new( namespace => __PACKAGE__ ), + fallback => + Data::ObjectDriver::Driver::Partition->new( + get_driver => \&get_driver, + pk_generator => \&generate_pk, + ), + ), + }); + + sub get_driver { + my($terms) = @_; + my $recipe; + if (ref $terms eq 'HASH') { + my $recipe_id = $terms->{recipe_id} + or Carp::croak("recipe_id is required"); + $recipe = Recipe->lookup($recipe_id); + } elsif (ref $terms eq 'ARRAY') { + $recipe = Recipe->lookup($terms->[0]); + } + Carp::croak("Unknown recipe") unless $recipe; + Data::ObjectDriver::Driver::DBI->new( + dsn => 'dbi:mysql:database=cluster' . $recipe->cluster_id, + username => 'foo', + pk_generator => \&generate_pk, + ); + } + + sub generate_pk { + my($obj) = @_; + $obj->ingredient_id(++$IDs{$obj->recipe_id}); + 1; + } + + 1; + +=head1 SUPPORTED DATABASES + +I is very modular and it's not very diffucult to add new drivers. + +=over 4 + +=item * MySQL is well supported and has been heavily tested. + +=item * PostgreSQL has been been used in production and should just work, too. + +=item * SQLite is supported, but YMMV depending on the version. This is the +backend used for the test suite. + +=item * Oracle support has been added in 0.06 + +=back + +=head1 LICENSE + +I is free software; you may redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 MAILING LIST, CODE & MORE INFORMATION + +I developers can be reached via the following group: +L + +Bugs should be reported using the CPAN RT system, patches are encouraged when +reporting bugs. + +L + +=head1 AUTHOR & COPYRIGHT + +Except where otherwise noted, I is Copyright 2005-2006 +Six Apart, cpan@sixapart.com. All rights reserved. + +=cut diff --git a/extlib/Data/ObjectDriver/BaseObject.pm b/extlib/Data/ObjectDriver/BaseObject.pm new file mode 100644 index 000000000..9ad9424e3 --- /dev/null +++ b/extlib/Data/ObjectDriver/BaseObject.pm @@ -0,0 +1,1297 @@ +# $Id: BaseObject.pm 553 2009-01-07 22:20:44Z ykerherve $ + +package Data::ObjectDriver::BaseObject; +use strict; +use warnings; + +our $HasWeaken; +eval q{ use Scalar::Util qw(weaken) }; ## no critic +$HasWeaken = !$@; + +use Carp (); + +use Class::Trigger qw( pre_save post_save post_load pre_search + pre_insert post_insert pre_update post_update + pre_remove post_remove post_inflate ); + +use Data::ObjectDriver::ResultSet; + +## Global Transaction variables +our @WorkingDrivers; +our $TransactionLevel = 0; + +sub install_properties { + my $class = shift; + my($props) = @_; + my $columns = delete $props->{columns}; + $props->{columns} = []; + { + no strict 'refs'; ## no critic + *{"${class}::__properties"} = sub { $props }; + } + + foreach my $col (@$columns) { + $class->install_column($col); + } + return $props; +} + +sub install_column { + my($class, $col, $type) = @_; + my $props = $class->properties; + + push @{ $props->{columns} }, $col; + $props->{column_names}{$col} = (); + # predefine getter/setter methods here + # Skip adding this method if the class overloads it. + # this lets the SUPER::columnname magic do it's thing + if (! $class->can($col)) { + no strict 'refs'; ## no critic + *{"${class}::$col"} = $class->column_func($col); + } + if ($type) { + $props->{column_defs}{$col} = $type; + } +} + +sub properties { + my $this = shift; + my $class = ref($this) || $this; + $class->__properties; +} + +# see docs below + +sub has_a { + my $class = shift; + my @args = @_; + + # Iterate over each remote object + foreach my $config (@args) { + my $parentclass = $config->{class}; + + # Parameters + my $column = $config->{column}; + my $method = $config->{method}; + my $cached = $config->{cached} || 0; + my $parent_method = $config->{parent_method}; + + # column is required + if (!defined($column)) { + die "Please specify a valid column for $parentclass" + } + + # create a method name based on the column + if (! defined $method) { + if (!ref($column)) { + $method = $column; + $method =~ s/_id$//; + $method .= "_obj"; + } elsif (ref($column) eq 'ARRAY') { + foreach my $col (@{$column}) { + my $part = $col; + $part =~ s/_id$//; + $method .= $part . '_'; + } + $method .= "obj"; + } + } + + # die if we have clashing methods method + if (! defined $method || defined(*{"${class}::$method"})) { + die "Please define a valid method for $class->$column"; + } + + if ($cached) { + # Store cached item inside this object's namespace + my $cachekey = "__cache_$method"; + + no strict 'refs'; ## no critic + *{"${class}::$method"} = sub { + my $obj = shift; + + return $obj->{$cachekey} + if defined $obj->{$cachekey}; + + my $id = (ref($column) eq 'ARRAY') + ? [ map { $obj->{column_values}->{$_} } @{$column}] + : $obj->{column_values}->{$column} + ; + ## Hold in a variable here too, so we don't lose it immediately + ## by having only the weak reference. + my $ret = $parentclass->lookup($id); + if ($HasWeaken) { + $obj->{$cachekey} = $ret; + weaken($obj->{$cachekey}); + } + return $ret; + }; + } else { + if (ref($column)) { + no strict 'refs'; ## no critic + *{"${class}::$method"} = sub { + my $obj = shift; + return $parentclass->lookup([ map{ $obj->{column_values}->{$_} } @{$column}]); + }; + } else { + no strict 'refs'; ## no critic + *{"${class}::$method"} = sub { + return $parentclass->lookup(shift()->{column_values}->{$column}); + }; + } + } + + # now add to the parent + if (!defined $parent_method) { + $parent_method = lc($class); + $parent_method =~ s/^.*:://; + + $parent_method .= '_objs'; + } + if (ref($column)) { + no strict 'refs'; ## no critic + *{"${parentclass}::$parent_method"} = sub { + my $obj = shift; + my $terms = shift || {}; + my $args = shift; + + my $primary_key = $obj->primary_key; + + # inject pk search into given terms. + # composite key, ugh + foreach my $key (@$column) { + $terms->{$key} = shift(@{$primary_key}); + } + + return $class->search($terms, $args); + }; + } else { + no strict 'refs'; ## no critic + *{"${parentclass}::$parent_method"} = sub { + my $obj = shift; + my $terms = shift || {}; + my $args = shift; + # TBD - use primary_key_to_terms + $terms->{$column} = $obj->primary_key; + return $class->search($terms, $args); + }; + }; + } # end of loop over class names + return; +} + +sub driver { + my $class = shift; + $class->properties->{driver} ||= $class->properties->{get_driver}->(); +} + +sub get_driver { + my $class = shift; + $class->properties->{get_driver} = shift if @_; +} + +sub new { + my $obj = bless {}, shift; + + return $obj->init(@_); +} + +sub init { + my $self = shift; + + while (@_) { + my $field = shift; + my $val = shift; + $self->$field($val); + } + return $self; +} + +sub is_pkless { + my $obj = shift; + my $prop_pk = $obj->properties->{primary_key}; + return 1 if ! $prop_pk; + return 1 if ref $prop_pk eq 'ARRAY' && ! @$prop_pk; +} + +sub is_primary_key { + my $obj = shift; + my($col) = @_; + + my $prop_pk = $obj->properties->{primary_key}; + if (ref($prop_pk)) { + for my $pk (@$prop_pk) { + return 1 if $pk eq $col; + } + } else { + return 1 if $prop_pk eq $col; + } + + return; +} + +sub primary_key_tuple { + my $obj = shift; + my $pk = $obj->properties->{primary_key} || return; + $pk = [ $pk ] unless ref($pk) eq 'ARRAY'; + $pk; +} + +sub primary_key { + my $obj = shift; + my $pk = $obj->primary_key_tuple; + my @val = map { $obj->$_() } @$pk; + @val == 1 ? $val[0] : \@val; +} + +sub is_same_array { + my($a1, $a2) = @_; + return if ($#$a1 != $#$a2); + for (my $i = 0; $i <= $#$a1; $i++) { + return if $a1->[$i] ne $a2->[$i]; + } + return 1; +} + +sub primary_key_to_terms { + my($obj, $id) = @_; + my $pk = $obj->primary_key_tuple; + if (! defined $id) { + $id = $obj->primary_key; + } else { + if (ref($id) eq 'HASH') { + my @keys = sort keys %$id; + unless (is_same_array(\@keys, [ sort @$pk ])) { + Carp::confess("keys don't match with primary keys: @keys|@$pk"); + } + return $id; + } + } + $id = [ $id ] unless ref($id) eq 'ARRAY'; + my %terms; + @terms{@$pk} = @$id; + \%terms; +} + +sub is_same { + my($obj, $other) = @_; + + my @a; + for my $o ($obj, $other) { + push @a, [ map { $o->$_() } @{ $o->primary_key_tuple }]; + } + return is_same_array( @a ); +} + +sub object_is_stored { + my $obj = shift; + return $obj->{__is_stored} ? 1 : 0; +} +sub pk_str { + my ($obj) = @_; + my $pk = $obj->primary_key; + return $pk unless ref ($pk) eq 'ARRAY'; + return join (":", @$pk); +} + +sub has_primary_key { + my $obj = shift; + return unless @{$obj->primary_key_tuple}; + my $val = $obj->primary_key; + $val = [ $val ] unless ref($val) eq 'ARRAY'; + for my $v (@$val) { + return unless defined $v; + } + 1; +} + +sub datasource { $_[0]->properties->{datasource} } + +sub columns_of_type { + my $obj = shift; + my($type) = @_; + my $props = $obj->properties; + my $cols = $props->{columns}; + my $col_defs = $props->{column_defs}; + my @cols; + for my $col (@$cols) { + push @cols, $col if $col_defs->{$col} && $col_defs->{$col} eq $type; + } + \@cols; +} + +sub set_values { + my $obj = shift; + my $values = shift; + for my $col (keys %$values) { + unless ( $obj->has_column($col) ) { + Carp::croak("You tried to set non-existent column $col to value $values->{$col} on " . ref($obj)); + } + $obj->$col($values->{$col}); + } +} + +sub set_values_internal { + my $obj = shift; + my $values = shift; + for my $col (keys %$values) { + # Not needed for the internal version of this method + #unless ( $obj->has_column($col) ) { + # Carp::croak("You tried to set inexistent column $col to value $values->{$col} on " . ref($obj)); + #} + + $obj->column_values->{$col} = $values->{$col}; + } +} + +sub clone { + my $obj = shift; + my $clone = $obj->clone_all; + for my $pk (@{ $obj->primary_key_tuple }) { + $clone->$pk(undef); + } + $clone; +} + +sub clone_all { + my $obj = shift; + my $clone = ref($obj)->new(); + $clone->set_values_internal($obj->column_values); + $clone->{changed_cols} = defined $obj->{changed_cols} ? { %{$obj->{changed_cols}} } : undef; + $clone; +} + +sub has_column { + return exists $_[0]->properties->{column_names}{$_[1]}; +} + +sub column_names { + ## Reference to a copy. + [ @{ shift->properties->{columns} } ] +} + +sub column_values { $_[0]->{'column_values'} ||= {} } + +## In 0.1 version we didn't die on inexistent column +## which might lead to silent bugs +## You should override column if you want to find the old +## behaviour +sub column { + my $obj = shift; + my $col = shift or return; + unless ($obj->has_column($col)) { + Carp::croak("Cannot find column '$col' for class '" . ref($obj) . "'"); + } + + # set some values + if (@_) { + $obj->{column_values}->{$col} = shift; + unless ($_[0] && ref($_[0]) eq 'HASH' && $_[0]->{no_changed_flag}) { + $obj->{changed_cols}->{$col}++; + } + } + + $obj->{column_values}->{$col}; +} + +sub column_func { + my $obj = shift; + my $col = shift or die "Must specify column"; + + return sub { + my $obj = shift; + # getter + return $obj->{column_values}->{$col} unless (@_); + + # setter + my ($val, $flags) = @_; + $obj->{column_values}->{$col} = $val; + unless ($flags && ref($flags) eq 'HASH' && $flags->{no_changed_flag}) { + $obj->{changed_cols}->{$col}++; + } + + return $obj->{column_values}->{$col}; + }; +} + + +sub changed_cols_and_pk { + my $obj = shift; + keys %{$obj->{changed_cols}}; +} + +sub changed_cols { + my $obj = shift; + my $pk = $obj->primary_key_tuple; + my %pk = map { $_ => 1 } @$pk; + grep !$pk{$_}, $obj->changed_cols_and_pk; +} + +sub is_changed { + my $obj = shift; + if (@_) { + return exists $obj->{changed_cols}->{$_[0]}; + } else { + return $obj->changed_cols > 0; + } +} + +sub exists { + my $obj = shift; + return 0 unless $obj->has_primary_key; + $obj->_proxy('exists', @_); +} + +sub save { + my $obj = shift; + if ($obj->exists(@_)) { + return $obj->update(@_); + } else { + return $obj->insert(@_); + } +} + +sub bulk_insert { + my $class = shift; + my $driver = $class->driver; + + return $driver->bulk_insert($class, @_); +} + +sub lookup { + my $class = shift; + my $driver = $class->driver; + my $obj = $driver->lookup($class, @_) or return; + $driver->cache_object($obj); + $obj; +} + +sub lookup_multi { + my $class = shift; + my $driver = $class->driver; + my $objs = $driver->lookup_multi($class, @_) or return; + for my $obj (@$objs) { + $driver->cache_object($obj) if $obj; + } + $objs; +} + +sub result { + my $class = shift; + my ($terms, $args) = @_; + + return Data::ObjectDriver::ResultSet->new({ + class => (ref $class || $class), + page_size => delete $args->{page_size}, + paging => delete $args->{no_paging}, + terms => $terms, + args => $args, + }); +} + +sub search { + my $class = shift; + my($terms, $args) = @_; + my $driver = $class->driver; + if (wantarray) { + my @objs = $driver->search($class, $terms, $args); + + ## Don't attempt to cache objects where the caller specified fetchonly, + ## because they won't be complete. + ## Also skip this step if we don't get any objects back from the search + if (!$args->{fetchonly} || !@objs) { + for my $obj (@objs) { + $driver->cache_object($obj) if $obj; + } + } + return @objs; + } else { + my $iter = $driver->search($class, $terms, $args); + return $iter if $args->{fetchonly}; + + my $caching_iter = sub { + my $d = $driver; + + my $o = $iter->(); + unless ($o) { + $iter->end; + return; + } + $driver->cache_object($o); + return $o; + }; + return Data::ObjectDriver::Iterator->new($caching_iter, sub { $iter->end }); + } +} + +sub remove { shift->_proxy( 'remove', @_ ) } +sub update { shift->_proxy( 'update', @_ ) } +sub insert { shift->_proxy( 'insert', @_ ) } +sub replace { shift->_proxy( 'replace', @_ ) } +sub fetch_data { shift->_proxy( 'fetch_data', @_ ) } +sub uncache_object { shift->_proxy( 'uncache_object', @_ ) } + +sub refresh { + my $obj = shift; + return unless $obj->has_primary_key; + my $fields = $obj->fetch_data; + $obj->set_values_internal($fields); + $obj->call_trigger('post_load'); + return 1; +} + +## NOTE: I wonder if it could be useful to BaseObject superclass +## to override the global transaction flag. If so, I'd add methods +## to manipulate this flag and the working drivers. -- Yann +sub _proxy { + my $obj = shift; + my($meth, @args) = @_; + my $driver = $obj->driver; + ## faster than $obj->txn_active && ! $driver->txn_active but see note. + if ($TransactionLevel && ! $driver->txn_active) { + $driver->begin_work; + push @WorkingDrivers, $driver; + } + $driver->$meth($obj, @args); +} + +sub txn_active { $TransactionLevel } + +sub begin_work { + my $class = shift; + if ( $TransactionLevel > 0 ) { + Carp::carp( + $TransactionLevel > 1 + ? "$TransactionLevel transactions already active" + : "Transaction already active" + ); + } + $TransactionLevel++; +} + +sub commit { + my $class = shift; + $class->_end_txn('commit'); +} + +sub rollback { + my $class = shift; + $class->_end_txn('rollback'); +} + +sub _end_txn { + my $class = shift; + my $meth = shift; + + ## Ignore nested transactions + if ($TransactionLevel > 1) { + $TransactionLevel--; + return; + } + + if (! $TransactionLevel) { + Carp::carp("No active transaction to end; ignoring $meth"); + return; + } + my @wd = @WorkingDrivers; + $TransactionLevel--; + @WorkingDrivers = (); + + for my $driver (@wd) { + $driver->$meth; + } +} + +sub txn_debug { + my $class = shift; + return { + txn => $TransactionLevel, + drivers => \@WorkingDrivers, + }; +} + +sub deflate { { columns => shift->column_values } } + +sub inflate { + my $class = shift; + my($deflated) = @_; + my $obj = $class->new; + $obj->set_values($deflated->{columns}); + $obj->{changed_cols} = {}; + $obj->call_trigger('post_inflate'); + return $obj; +} + +sub DESTROY { } + +sub AUTOLOAD { + my $obj = $_[0]; + (my $col = our $AUTOLOAD) =~ s!.+::!!; + Carp::croak("Cannot find method '$col' for class '$obj'") unless ref $obj; + unless ($obj->has_column($col)) { + Carp::croak("Cannot find column '$col' for class '" . ref($obj) . "'"); + } + + { + no strict 'refs'; ## no critic + *$AUTOLOAD = $obj->column_func($col); + } + + goto &$AUTOLOAD; +} + +sub has_partitions { + my $class = shift; + my(%param) = @_; + my $how_many = delete $param{number} + or Carp::croak("number (of partitions) is required"); + + ## save the number of partitions in the class + $class->properties->{number_of_partitions} = $how_many; + + ## Save the get_driver subref that we were passed, so that the + ## SimplePartition driver can access it. + $class->properties->{partition_get_driver} = delete $param{get_driver} + or Carp::croak("get_driver is required"); + + ## When creating a new $class object, we should automatically fill in + ## the partition ID by selecting one at random, unless a partition_id + ## is already defined. This allows us to keep it simple but for the + ## caller to do something more complex, if it wants to. + $class->add_trigger(pre_insert => sub { + my($obj, $orig_obj) = @_; + unless (defined $obj->partition_id) { + my $partition_id = int(rand $how_many) + 1; + $obj->partition_id($partition_id); + $orig_obj->partition_id($partition_id); + } + }); +} + +1; + +__END__ + +=head1 NAME + +Data::ObjectDriver::BaseObject - base class for modeled objects + +=head1 SYNOPSIS + + package Ingredient; + use base qw( Data::ObjectDriver::BaseObject ); + + __PACKAGE__->install_properties({ + columns => [ 'ingredient_id', 'recipe_id', 'name', 'quantity' ], + datasource => 'ingredient', + primary_key => [ 'recipe_id', 'ingredient_id' ], + driver => FoodDriver->driver, + }); + + __PACKAGE__->has_a( + { class => 'Recipe', column => 'recipe_id', } + ); + + package main; + + my ($ingredient) = Ingredient->search({ recipe_id => 4, name => 'rutabaga' }); + $ingredient->quantity(7); + $ingredient->save(); + + +=head1 DESCRIPTION + +I provides services to data objects modeled +with the I object relational mapper. + +=head1 CLASS DEFINITION + +=head2 Cinstall_properties(\%params)> + +Defines all the properties of the specified object class. Generally you should +call C in the body of your class definition, so the +properties can be set when the class is Cd or Cd. + +Required members of C<%params> are: + +=over 4 + +=item * C + +All the columns in the object class. This property is an arrayref. + +=item * C + +The identifier of the table in which the object class's data are stored. +Usually the datasource is simply the table name, but the datasource can be +decorated into the table name by the C module if the +database requires special formatting of table names. + +=item * C or C + +The driver used to perform database operations (lookup, update, etc) for the +object class. + +C is the instance of C to use. If your driver +requires configuration options not available when the properties are initially +set, specify a coderef as C instead. It will be called the first +time the driver is needed, storing the driver in the class's C property +for subsequent calls. + +=back + +The optional members of C<%params> are: + +=over 4 + +=item * C + +The column or columns used to uniquely identify an instance of the object +class. If one column (such as a simple numeric ID) identifies the class, +C should be a scalar. Otherwise, C is an arrayref. + +=item * C + +Specifies types for specially typed columns, if any, as a hashref. For example, +if a column holds a timestamp, name it in C as a C for +proper handling with some C database drivers. +Columns for which types aren't specified are handled as C columns. + +Known C types are: + +=over 4 + +=item * C + +A blob of binary data. C maps this to +C, C to C and C +to C. + +=item * C + +A non-blob string of binary data. C +maps this to C. + +=back + +Other types may be defined by custom database drivers as needed, so consult +their documentation. + +=item * C + +The name of the database. When used with C +type object drivers, this name is passed to the C method when the +actual database handle is being created. + +=back + +Custom object drivers may define other properties for your object classes. +Consult the documentation of those object drivers for more information. + +=head2 Cinstall_column($col, $def)> + +Modify the Class definition to declare a new column C<$col> of definition <$def> +(see L). + +=head2 Chas_a(@definitions)> + +B C is an experimental system, likely to both be buggy and change +in future versions. + +Defines a foreign key reference between two classes, creating accessor methods +to retrieve objects both ways across the reference. For each defined reference, +two methods are created: one for objects of class C to load the objects +they reference, and one for objects of the referenced class to load the set of +C objects that reference I. + +For example, this definition: + + package Ingredient; + __PACKAGE__->has_a( + { class => 'Recipe', column => 'recipe_id' }, + ); + +would create Crecipe_obj> and Cingredient_objs> +instance methods. + +Each member of C<@definitions> is a hashref containing the parameters for +creating one accessor method. The required members of these hashes are: + +=over 4 + +=item * C + +The class to associate. + +=item * C + +The column or columns in this class that identify the primary key of the +associated object. As with primary keys, use a single scalar string for a +single column or an arrayref for a composite key. + +=back + +The optional members of C definitions are: + +=over 4 + +=item * C + +The name of the accessor method to create. + +By default, the method name is the concatenated set of column names with each +C<_id> suffix removed, and the suffix C<_obj> appended at the end of the method +name. For example, if C were C<['recipe_id', 'ingredient_id']>, the +resulting method would be called C by default. + +=item * C + +Whether to keep a reference to the foreign object once it's loaded. Subsequent +calls to the accessor method would return that reference immediately. + +=item * C + +The name of the reciprocal method created in the referenced class named in +C. + +By default, that method is named with the lowercased name of the current class +with the suffix C<_objs>. For example, if in your C class you +defined a relationship with C on the column C, this would +create a C<$recipe-Eingredient_objs> method. + +Note that if you reference one class with multiple sets of fields, you can omit +only one parent_method; otherwise the methods would be named the same thing. +For instance, if you had a C class with two references to C +objects in its C and C columns, one of them would need a +C. + +=back + +=head2 Chas_partitions(%param)> + +Defines that the given class is partitioned, configuring it for use with the +C object driver. Required members +of C<%param> are: + +=over 4 + +=item * C + +The number of partitions in which objects of this class may be stored. + +=item * C + +A function that returns an object driver, given a partition ID and any extra +parameters specified when the class's +C was instantiated. + +=back + +Note that only the parent object for use with the C driver +should use C. See +C for more about partitioning. + +=head1 BASIC USAGE + +=head2 Clookup($id)> + +Returns the instance of C with the given value for its primary key. If +C has a complex primary key (more than one column), C<$id> should be an +arrayref specifying the column values in the same order as specified in the +C property. + +=head2 Csearch(\%terms, [\%args])> + +Returns all instances of C that match the values specified in +C<\%terms>, keyed on column names. In list context, C returns the +objects containing those values. In scalar context, C returns an +iterator function containing the same set of objects. + +Your search can be customized with parameters specified in C<\%args>. Commonly +recognized parameters (those implemented by the standard C +object drivers) are: + +=over 4 + +=item * C + +A column by which to order the object results. + +=item * C + +If set to C, the results (ordered by the C column) are returned +in descending order. Otherwise, results will be in ascending order. + +=item * C + +The number of results to return, at most. You can use this with C to +paginate your C results. + +=item * C + +The number of results to skip before the first returned result. Use this with +C to paginate your C results. + +=item * C + +A list (arrayref) of columns that should be requested. If specified, only the +specified columns of the resulting objects are guaranteed to be set to the +correct values. + +Note that any caching object drivers you use may opt to ignore C +instructions, or decline to cache objects queried with C. + +=item * C + +If true, instructs the object driver to indicate the query is a search, but the +application may want to update the data after. That is, the generated SQL +C. + +=head2 $profiler->query_frequency + +Returns a reference to a hash containing, as keys, all of the SQL statements +in the query log, where the value for each of the keys is a number +representing the number of times the query was executed. + +=head2 $profiler->reset + +Resets the statistics and the query log. + +=head2 $profiler->total_queries + +Returns the total number of queries currently logged in the profiler. + +=head2 $profiler->report_queries_by_type + +Returns a string containing a pretty report of information about the current +number of each type of query in the profiler (e.g. C (arrayref) + +The database columns to select in a C query should return DISTINCT rows only. + +=head2 C (hashref) + +The map of database column names to object fields in a C list to column names. + +=head2 C (hashref) + +The map of object fields to database column names in a C query. + +Note if you perform a C query. The requested object member will be indicated to be C<$term> +in the statement's C and C attributes. + +C<$term> is optional, and defaults to the same value as C<$column>. + +=head2 C<$sql-Eadd_join($table, \@joins)> + +Adds the join statement indicated by C<$table> and C<\@joins> to the list of +C table references for the statement. The structure for the set of joins +are as described for the C attribute member above. + +=head2 C<$sql-Eadd_index_hint($table, $index)> + +Specifies a particular index to use for a particular table. + +=head2 C<$sql-Eadd_where($column, $value)> + +Adds a condition on the value of the database column C<$column> to the +statement's C clause. A record will be tested against the below +conditions according to what type of data structure C<$value> is: + +=over 4 + +=item * a scalar + +The value of C<$column> must equal C<$value>. + +=item * a reference to a scalar + +The value of C<$column> must evaluate true against the SQL given in C<$$value>. +For example, if C<$$value> were C, C<$column> must be C for a +record to pass. + +=item * a hashref + +The value of C<$column> must compare against the condition represented by +C<$value>, which can contain the members: + +=over 4 + +=item * C + +The value with which to compare (required). + +=item * C + +The SQL operator with which to compare C and the value of C<$column> +(required). + +=item * C + +The column name for the comparison. If this is present, it overrides the +column name C<$column>, allowing you to build more complex conditions +like C<((foo = 1 AND bar = 2) OR (baz = 3))>. + +=back + +For example, if C were C and C were C, a record's +C<$column> column would have to be C to match. + +=item * an arrayref of scalars + +The value of C<$column> may equal any of the members of C<@$value>. The +generated SQL performs the comparison with as an C expression. + +=item * an arrayref of (mostly) references + +The value of C<$column> must compare against I of the expressions +represented in C<@$value>. Each member of the list can be any of the structures +described here as possible forms of C<$value>. + +If the first member of the C<@$value> array is the scalar string C<-and>, +I subsequent members of <@$value> must be met for the record to match. +Note this is not very useful unless contained as one option of a larger C +alternation. + +=back + +All individual conditions specified with C must be true for a +record to be a result of the query. + +Beware that you can create a circular reference that will recursively generate +an infinite SQL statement (for example, by specifying a arrayref C<$value> that +itself contains C<$value>). As C evaluates your expressions before +storing the conditions in the C attribute as a generated SQL string, +this will occur when calling C, not C. So don't do that. + +=head2 C<$sql-Eadd_complex_where(\@list)> + +This method accepts an array reference of clauses that are glued together with +logical operators. With it, you can express where clauses that mix logical +operators together to produce more complex queries. For instance: + + [ { foo => 1, bar => 2 }, -or => { baz => 3 } ] + +The values given for the columns support all the variants documented for the +C method above. Logical operators used inbetween the hashref +elements can be one of: '-or', '-and', '-or_not', '-and_not'. + +=head2 C<$sql-Ehas_where($column, [$value])> + +Returns whether a where clause for the column C<$column> was added to the +statement with the C method. + +The C<$value> argument is currently ignored. + +=head2 C<$sql-Eadd_having($column, $value)> + +Adds an expression to the C portion of the statement's C clause. The expression compares C<$column> using C<$value>, which can +be any of the structures described above for the C method. + +=head2 C<$sql-Eadd_index_hint($table, \@hints)> + +Addes the index hint into a C