From: Justin Guenther Date: Thu, 25 May 2006 14:53:12 +0000 (-0700) Subject: Merge 'trunk' into 'DBIx-Class-current' X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=183dd9875c7cdff77fedf29cf6609c79ed35376d;hp=70634260007b23e9d71c3962bb757b4532d76a02;p=dbsrgits%2FDBIx-Class-Historic.git Merge 'trunk' into 'DBIx-Class-current' r1808@moss (orig r1807): jguenther | 2006-05-25 09:53:12 -0700 Changed txn_do docs/Cookbook example to use closures, and made their content more consistent --- diff --git a/Build.PL b/Build.PL index f1d2ad8..2ab62b9 100644 --- a/Build.PL +++ b/Build.PL @@ -15,18 +15,16 @@ my %arguments = ( 'Class::Data::Accessor' => 0.01, 'Carp::Clan' => 0, 'DBI' => 1.40, + 'Module::Find' => 0, + 'Class::Inspector' => 0, }, build_requires => { 'DBD::SQLite' => 1.11, }, - recommends => { - 'Data::UUID' => 0, - 'Module::Find' => 0, - 'Class::Inspector' => 0, - }, create_makefile_pl => 'passthrough', create_readme => 1, - test_files => [ glob('t/*.t'), glob('t/*/*.t') ] + test_files => [ glob('t/*.t'), glob('t/*/*.t') ], + script_files => [ glob('script/*') ], ); Module::Build->new(%arguments)->create_build_script; diff --git a/Changes b/Changes index 54514fb..cd9962b 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,29 @@ Revision history for DBIx::Class + - marked DB.pm as deprecated and noted it will be removed by 1.0 + - add ResultSetColumn + - refactor ResultSet code to resolve attrs as late as poss + - merge prefetch attrs into join attrs + - add +select and +as attributes to ResultSet + - added AutoInflate::DateTime component + - refactor debugging to allow for profiling using Storage::Statistics + - removed Data::UUID from deps, made other optionals required + - modified SQLT parser to skip dupe table names + - added remove_column(s) to ResultSource/ResultSourceProxy + - added add_column alias to ResultSourceProxy + - added source_name to ResultSource + - load_classes now uses source_name and sets it if necessary + - add update_or_create_related to Relationship::Base + - add find_or_new to ResultSet/ResultSetProxy and find_or_new_related + to Relationship::Base + - add accessors for unique constraint names and coulums to + ResultSource/ResultSourceProxy + - rework ResultSet::find() to search unique constraints + - CDBICompat: modify retrieve to fix column casing when ColumnCase is + loaded + - CDBICompat: override find_or_create to fix column casing when + ColumnCase is loaded + 0.06003 - make find_or_create_related check defined() instead of truth - don't unnecessarily fetch rels for cascade_update @@ -92,7 +116,7 @@ Revision history for DBIx::Class - remove build dependency on version.pm 0.05004 2006-02-13 20:59:00 - - allow specification of related columns via cols attr when primary + - allow specification of related columns via cols attr when primary keys of the related table are not fetched - fix count for group_by as scalar - add horrific fix to make Oracle's retarded limit syntax work diff --git a/TODO b/TODO index d0726b3..e22c6ba 100644 --- a/TODO +++ b/TODO @@ -1,3 +1,23 @@ +2005-04-16 by mst + - set_from_related should take undef + - ResultSource objects caching ->resultset causes interesting problems + - find why XSUB dumper kills schema in Catalyst (may be Pg only?) + +2006-04-11 by castaway + - using PK::Auto should set is_auto_increment for the PK columns, so that copy() "just works" + - docs of copy() should say that is_auto_increment is essential for auto_incrementing keys + +2006-03-25 by mst + - Refactor ResultSet::new to be less hairy + - we should move the setup of select, as, and from out of here + - these should be local rs attrs, not main attrs, and extra joins + provided on search should be merged + - find a way to un-wantarray search without breaking compat + - audit logging component + - delay relationship setup if done via ->load_classes + - double-sided relationships + - incremental deploy + - make short form of class specifier in relationships work 2006-01-31 by bluefeet - Create a DBIx::Class::FilterColumn to replace inflate/deflate. This @@ -7,13 +27,34 @@ We should still support the old inflate/deflate syntax, but this new way should be recommended. -2006-02-07 by JR +2006-02-07 by castaway - Extract DBIC::SQL::Abstract into a separate module for CPAN - Chop PK::Auto::Foo up to have PK::Auto refer to an appropriate DBIx::Storage::DBI::Foo, which will be loaded on connect from Driver info? +(done -> 0.06001!) - Add deploy method to Schema, which will create DB tables from Schema, via SQLT +(sorta done) 2006-03-18 by bluefeet - Support table locking. +2006-03-21 by bluefeet + - When subclassing a dbic class make it so you don't have to do + __PACKAGE__->table(__PACKAGE__->table()); for the result set to + return the correct object type. + +2006-03-27 by mst + Add the ability for deploy to be given a directory and grab .sql + out of there if available. Try SQL::Translator if not. If none of the above, + cry (and die()). Then you can have a script that pre-gens for all available + SQLT modules so an app can do its own deploy without SQLT on the target + system + +2006-05-25 by mst (TODOed by bluefeet) + Add the search attributes "limit" and "rows_per_page". + limit: work as expected just like offset does + rows_per_page: only be used if you used the page attr or called $rs->page + rows: modify to be an alias that gets used to populate either as appropriate, + if you haven't specified one of the others + diff --git a/VERSIONING.SKETCH b/VERSIONING.SKETCH new file mode 100644 index 0000000..03e6ea1 --- /dev/null +++ b/VERSIONING.SKETCH @@ -0,0 +1,30 @@ +Schema versioning/deployment ideas from Jess (with input from theorbtwo and mst): +1) Add a method to storage to: + - take args of DB type, version, and optional file/pathname + - create an SQL file, via SQLT, for the current schema + - passing prev. version + version will create an sqlt-diff'ed upgrade file, such as + - $preversion->$currentversion-$dbtype.sql, which contains ALTER foo statements. +2) Make deploy/deploy_statements able to to load from the appropriate file, for the current DB, or on the fly? - Compare against current schema version.. +3) Add an on_connect_cb (callback) thingy to storage. +4) create a component to deploy version/updates: + - it hooks itself into on_connect_cb ? + - when run it: + - Attempts or prompts a backup of the database. (commands for these per-rdbms can be stored in storage::dbi:: ?) + - Checks the version of the current schema being used + - Compares it to some schema table containing the installed version + - If none such exists, we can attempt to sqlt-diff the DB structure with the schema + - If version does exist, we use an array of user-defined upgrade paths, + eg: version = '3x.'; schema = '1.x', upgrade paths = ('1.x->2.x', '2.x->3.x') + - Find the appropriate upgrade-path file, parse into two chunks: + a) the commands which do not contain "DROP" + b) the ones that do + - Calls user callbacks for "pre-upgrade" + - Runs the first set of commands on the DB + - Calls user callbacks for "post-alter" + - Runs drop commands + - Calls user callbacks for "post-drop" + - The user will need to define (or ignore) the following callbacks: + - "pre-upgrade", any code to be run before the upgrade, called with schema object, version-from, version-to, db-type .. bear in mind that here any new fields in the schema will not work, but can be used via scalarrefs. + - "post-alter", this is the main callback, at this stage, all old and new fields will be available, to allow data migration. + - "post-drop", this is the clean-up stage, now only new fields are available. + diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 3522e18..cc8e1cb 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -206,6 +206,8 @@ quicksilver: Jules Bean jguenther: Justin Guenther +captainL: Luke Saunders + draven: Marcus Ramberg nigel: Nigel Metheringham @@ -222,12 +224,12 @@ scotty: Scotty Allen sszabo: Stephan Szabo -captainL: Luke Saunders - Todd Lipcon wdh: Will Hawes +gphat: Cory G Watson + =head1 LICENSE You may distribute this code under the same terms as Perl itself. diff --git a/lib/DBIx/Class/CDBICompat/ColumnCase.pm b/lib/DBIx/Class/CDBICompat/ColumnCase.pm index 9d0c96f..9be24ff 100644 --- a/lib/DBIx/Class/CDBICompat/ColumnCase.pm +++ b/lib/DBIx/Class/CDBICompat/ColumnCase.pm @@ -66,6 +66,19 @@ sub find_column { return $class->next::method(lc($col)); } +# _build_query +# +# Build a query hash for find, et al. Overrides Retrieve::_build_query. + +sub _build_query { + my ($self, $query) = @_; + + my %new_query; + $new_query{lc $_} = $query->{$_} for keys %$query; + + return \%new_query; +} + sub _mk_group_accessors { my ($class, $type, $group, @fields) = @_; #warn join(', ', map { ref $_ ? (@$_) : ($_) } @fields); diff --git a/lib/DBIx/Class/CDBICompat/HasA.pm b/lib/DBIx/Class/CDBICompat/HasA.pm index 6930f3b..647674f 100644 --- a/lib/DBIx/Class/CDBICompat/HasA.pm +++ b/lib/DBIx/Class/CDBICompat/HasA.pm @@ -7,7 +7,7 @@ use warnings; sub has_a { my ($self, $col, $f_class, %args) = @_; $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col); - eval "require $f_class"; + $self->ensure_class_loaded($f_class); if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a if (!ref $args{'inflate'}) { my $meth = $args{'inflate'}; diff --git a/lib/DBIx/Class/CDBICompat/Retrieve.pm b/lib/DBIx/Class/CDBICompat/Retrieve.pm index 899ed69..1186ae4 100644 --- a/lib/DBIx/Class/CDBICompat/Retrieve.pm +++ b/lib/DBIx/Class/CDBICompat/Retrieve.pm @@ -5,9 +5,44 @@ use strict; use warnings FATAL => 'all'; -sub retrieve { - die "No args to retrieve" unless @_ > 1; - shift->find(@_); +sub retrieve { + my $self = shift; + die "No args to retrieve" unless @_ > 0; + + my @cols = $self->primary_columns; + + my $query; + if (ref $_[0] eq 'HASH') { + $query = { %{$_[0]} }; + } + elsif (@_ == @cols) { + $query = {}; + @{$query}{@cols} = @_; + } + else { + $query = {@_}; + } + + $query = $self->_build_query($query); + $self->find($query); +} + +sub find_or_create { + my $self = shift; + my $query = ref $_[0] eq 'HASH' ? shift : {@_}; + + $query = $self->_build_query($query); + $self->next::method($query); +} + +# _build_query +# +# Build a query hash. Defaults to a no-op; ColumnCase overrides. + +sub _build_query { + my ($self, $query) = @_; + + return $query; } sub retrieve_from_sql { diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm index 7e62354..e23a0b4 100644 --- a/lib/DBIx/Class/Componentised.pm +++ b/lib/DBIx/Class/Componentised.pm @@ -5,16 +5,16 @@ use strict; use warnings; use Class::C3; +use Class::Inspector; sub inject_base { my ($class, $target, @to_inject) = @_; { no strict 'refs'; - my %seen; - unshift( @{"${target}::ISA"}, - grep { !$seen{ $_ }++ && $target ne $_ && !$target->isa($_) } - @to_inject - ); + foreach my $to (reverse @to_inject) { + unshift( @{"${target}::ISA"}, $to ) + unless ($target eq $to || $target->isa($to)); + } } # Yes, this is hack. But it *does* work. Please don't submit tickets about @@ -42,10 +42,20 @@ sub load_own_components { sub _load_components { my ($class, @comp) = @_; foreach my $comp (@comp) { - eval "use $comp"; - die $@ if $@; + $class->ensure_class_loaded($comp); } $class->inject_base($class => @comp); } +# TODO: handle ->has_many('rel', 'Class'...) instead of +# ->has_many('rel', 'Some::Schema::Class'...) +sub ensure_class_loaded { + my ($class, $f_class) = @_; + eval "require $f_class"; + my $err = $@; + Class::Inspector->loaded($f_class) + or die $err || "require $f_class was successful but the package". + "is not defined"; +} + 1; diff --git a/lib/DBIx/Class/Core.pm b/lib/DBIx/Class/Core.pm index 96a6a9a..87e7dce 100644 --- a/lib/DBIx/Class/Core.pm +++ b/lib/DBIx/Class/Core.pm @@ -10,6 +10,7 @@ __PACKAGE__->load_components(qw/ Serialize::Storable InflateColumn Relationship + PK::Auto PK Row ResultSourceProxy::Table diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index aa5eeb3..9e67f5c 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -31,7 +31,7 @@ sub resultset_instance { =head1 NAME -DBIx::Class::DB - Non-recommended classdata schema component +DBIx::Class::DB - (DEPRECATED) classdata schema component =head1 SYNOPSIS @@ -54,8 +54,8 @@ DBIx::Class::DB - Non-recommended classdata schema component This class is designed to support the Class::DBI connection-as-classdata style for DBIx::Class. You are *strongly* recommended to use a DBIx::Class::Schema -instead; DBIx::Class::DB will continue to be supported but new development -will be focused on Schema-based DBIx::Class setups. +instead; DBIx::Class::DB will not undergo new development and will be moved +to being a CDBICompat-only component before 1.0. =head1 METHODS diff --git a/lib/DBIx/Class/InflateColumn/DateTime.pm b/lib/DBIx/Class/InflateColumn/DateTime.pm new file mode 100644 index 0000000..72c8844 --- /dev/null +++ b/lib/DBIx/Class/InflateColumn/DateTime.pm @@ -0,0 +1,40 @@ +package DBIx::Class::InflateColumn::DateTime; + +use strict; +use warnings; +use base qw/DBIx::Class/; + +__PACKAGE__->load_components(qw/InflateColumn/); + +__PACKAGE__->mk_group_accessors('simple' => '__datetime_parser'); + +sub register_column { + my ($self, $column, $info, @rest) = @_; + $self->next::method($column, $info, @rest); + if ($info->{data_type} =~ /^datetime$/i) { + $self->inflate_column( + $column => + { + inflate => sub { + my ($value, $obj) = @_; + $obj->_datetime_parser->parse_datetime($value); + }, + deflate => sub { + my ($value, $obj) = @_; + $obj->_datetime_parser->format_datetime($value); + }, + } + ); + } +} + +sub _datetime_parser { + my $self = shift; + if (my $parser = $self->__datetime_parser) { + return $parser; + } + my $parser = $self->result_source->storage->datetime_parser(@_); + return $self->__datetime_parser($parser); +} + +1; diff --git a/lib/DBIx/Class/Manual/Component.pod b/lib/DBIx/Class/Manual/Component.pod index 2607e36..9bbe684 100644 --- a/lib/DBIx/Class/Manual/Component.pod +++ b/lib/DBIx/Class/Manual/Component.pod @@ -90,6 +90,8 @@ L - Build forms with multiple interconnected objects. L - Like FromForm but with DBIx::Class and HTML::Widget. +L - Modify the position of objects in an ordered list. + L - Retrieve automatically created primary keys upon insert. L - Display the amount of time it takes to run queries. diff --git a/lib/DBIx/Class/Manual/Cookbook.pod b/lib/DBIx/Class/Manual/Cookbook.pod index 1cfed1d..9f2a8fa 100644 --- a/lib/DBIx/Class/Manual/Cookbook.pod +++ b/lib/DBIx/Class/Manual/Cookbook.pod @@ -783,6 +783,66 @@ It is possible to get a Schema object from a row object like so, This can be useful when you don't want to pass around a Schema object to every method. +=head2 Profiling + +When you enable L's debugging it prints the SQL +executed as well as notifications of query completion and transaction +begin/commit. If you'd like to profile the SQL you can subclass the +L class and write your own profiling +mechanism: + + package My::Profiler; + use strict; + + use base 'DBIx::Class::Storage::Statistics'; + + use Time::HiRes qw(time); + + my $start; + + sub query_start { + my $self = shift(); + my $sql = shift(); + my $params = @_; + + print "Executing $sql: ".join(', ', @params)."\n"; + $start = time(); + } + + sub query_end { + my $self = shift(); + my $sql = shift(); + my @params = @_; + + printf("Execution took %0.4f seconds.\n", time() - $start); + $start = undef; + } + + 1; + +You can then install that class as the debugging object: + + __PACKAGE__->storage()->debugobj(new My::Profiler()); + __PACKAGE__->storage()->debug(1); + +A more complicated example might involve storing each execution of SQL in an +array: + + sub query_end { + my $self = shift(); + my $sql = shift(); + my @params = @_; + + my $elapsed = time() - $start; + push(@{ $calls{$sql} }, { + params => \@params, + elapsed => $elapsed + }); + } + +You could then create average, high and low execution times for an SQL +statement and dig down to see if certain parameters cause aberrant behavior. + =head2 Getting the value of the primary key for the last database insert AKA getting last_insert_id diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm new file mode 100644 index 0000000..8e2c74d --- /dev/null +++ b/lib/DBIx/Class/Ordered.pm @@ -0,0 +1,393 @@ +# vim: ts=8:sw=4:sts=4:et +package DBIx::Class::Ordered; +use strict; +use warnings; +use base qw( DBIx::Class ); + +=head1 NAME + +DBIx::Class::Ordered - Modify the position of objects in an ordered list. + +=head1 SYNOPSIS + +Create a table for your ordered data. + + CREATE TABLE items ( + item_id INTEGER PRIMARY KEY AUTOINCREMENT, + name TEXT NOT NULL, + position INTEGER NOT NULL + ); + # Optional: group_id INTEGER NOT NULL + +In your Schema or DB class add Ordered to the top +of the component list. + + __PACKAGE__->load_components(qw( Ordered ... )); + +Specify the column that stores the position number for +each row. + + package My::Item; + __PACKAGE__->position_column('position'); + __PACKAGE__->grouping_column('group_id'); # optional + +Thats it, now you can change the position of your objects. + + #!/use/bin/perl + use My::Item; + + my $item = My::Item->create({ name=>'Matt S. Trout' }); + # If using grouping_column: + my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 }); + + my $rs = $item->siblings(); + my @siblings = $item->siblings(); + + my $sibling; + $sibling = $item->first_sibling(); + $sibling = $item->last_sibling(); + $sibling = $item->previous_sibling(); + $sibling = $item->next_sibling(); + + $item->move_previous(); + $item->move_next(); + $item->move_first(); + $item->move_last(); + $item->move_to( $position ); + +=head1 DESCRIPTION + +This module provides a simple interface for modifying the ordered +position of DBIx::Class objects. + +=head1 AUTO UPDATE + +All of the move_* methods automatically update the rows involved in +the query. This is not configurable and is due to the fact that if you +move a record it always causes other records in the list to be updated. + +=head1 METHODS + +=head2 position_column + + __PACKAGE__->position_column('position'); + +Sets and retrieves the name of the column that stores the +positional value of each record. Default to "position". + +=cut + +__PACKAGE__->mk_classdata( 'position_column' => 'position' ); + +=head2 grouping_column + + __PACKAGE__->grouping_column('group_id'); + +This method specified a column to limit all queries in +this module by. This effectively allows you to have multiple +ordered lists within the same table. + +=cut + +__PACKAGE__->mk_classdata( 'grouping_column' ); + +=head2 siblings + + my $rs = $item->siblings(); + my @siblings = $item->siblings(); + +Returns either a result set or an array of all other objects +excluding the one you called it on. + +=cut + +sub siblings { + my( $self ) = @_; + my $position_column = $self->position_column; + my $rs = $self->result_source->resultset->search( + { + $position_column => { '!=' => $self->get_column($position_column) }, + $self->_grouping_clause(), + }, + { order_by => $self->position_column }, + ); + return $rs->all() if (wantarray()); + return $rs; +} + +=head2 first_sibling + + my $sibling = $item->first_sibling(); + +Returns the first sibling object, or 0 if the first sibling +is this sibliing. + +=cut + +sub first_sibling { + my( $self ) = @_; + return 0 if ($self->get_column($self->position_column())==1); + return ($self->result_source->resultset->search( + { + $self->position_column => 1, + $self->_grouping_clause(), + }, + )->all())[0]; +} + +=head2 last_sibling + + my $sibling = $item->last_sibling(); + +Return the last sibling, or 0 if the last sibling is this +sibling. + +=cut + +sub last_sibling { + my( $self ) = @_; + my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); + return 0 if ($self->get_column($self->position_column())==$count); + return ($self->result_source->resultset->search( + { + $self->position_column => $count, + $self->_grouping_clause(), + }, + )->all())[0]; +} + +=head2 previous_sibling + + my $sibling = $item->previous_sibling(); + +Returns the sibling that resides one position back. Undef +is returned if the current object is the first one. + +=cut + +sub previous_sibling { + my( $self ) = @_; + my $position_column = $self->position_column; + my $position = $self->get_column( $position_column ); + return 0 if ($position==1); + return ($self->result_source->resultset->search( + { + $position_column => $position - 1, + $self->_grouping_clause(), + } + )->all())[0]; +} + +=head2 next_sibling + + my $sibling = $item->next_sibling(); + +Returns the sibling that resides one position foward. Undef +is returned if the current object is the last one. + +=cut + +sub next_sibling { + my( $self ) = @_; + my $position_column = $self->position_column; + my $position = $self->get_column( $position_column ); + my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); + return 0 if ($position==$count); + return ($self->result_source->resultset->search( + { + $position_column => $position + 1, + $self->_grouping_clause(), + }, + )->all())[0]; +} + +=head2 move_previous + + $item->move_previous(); + +Swaps position with the sibling on position previous in the list. +1 is returned on success, and 0 is returned if the objects is already +the first one. + +=cut + +sub move_previous { + my( $self ) = @_; + my $position = $self->get_column( $self->position_column() ); + return $self->move_to( $position - 1 ); +} + +=head2 move_next + + $item->move_next(); + +Swaps position with the sibling in the next position. 1 is returned on +success, and 0 is returned if the object is already the last in the list. + +=cut + +sub move_next { + my( $self ) = @_; + my $position = $self->get_column( $self->position_column() ); + my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); + return 0 if ($position==$count); + return $self->move_to( $position + 1 ); +} + +=head2 move_first + + $item->move_first(); + +Moves the object to the first position. 1 is returned on +success, and 0 is returned if the object is already the first. + +=cut + +sub move_first { + my( $self ) = @_; + return $self->move_to( 1 ); +} + +=head2 move_last + + $item->move_last(); + +Moves the object to the very last position. 1 is returned on +success, and 0 is returned if the object is already the last one. + +=cut + +sub move_last { + my( $self ) = @_; + my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); + return $self->move_to( $count ); +} + +=head2 move_to + + $item->move_to( $position ); + +Moves the object to the specified position. 1 is returned on +success, and 0 is returned if the object is already at the +specified position. + +=cut + +sub move_to { + my( $self, $to_position ) = @_; + my $position_column = $self->position_column; + my $from_position = $self->get_column( $position_column ); + return 0 if ( $to_position < 1 ); + return 0 if ( $from_position==$to_position ); + my @between = ( + ( $from_position < $to_position ) + ? ( $from_position+1, $to_position ) + : ( $to_position, $from_position-1 ) + ); + my $rs = $self->result_source->resultset->search({ + $position_column => { -between => [ @between ] }, + $self->_grouping_clause(), + }); + my $op = ($from_position>$to_position) ? '+' : '-'; + $rs->update({ $position_column => \"$position_column $op 1" }); + $self->update({ $position_column => $to_position }); + return 1; +} + +=head2 insert + +Overrides the DBIC insert() method by providing a default +position number. The default will be the number of rows in +the table +1, thus positioning the new record at the last position. + +=cut + +sub insert { + my $self = shift; + my $position_column = $self->position_column; + $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 ) + if (!$self->get_column($position_column)); + return $self->next::method( @_ ); +} + +=head2 delete + +Overrides the DBIC delete() method by first moving the object +to the last position, then deleting it, thus ensuring the +integrity of the positions. + +=cut + +sub delete { + my $self = shift; + $self->move_last; + return $self->next::method( @_ ); +} + +=head1 PRIVATE METHODS + +These methods are used internally. You should never have the +need to use them. + +=head2 _grouping_clause + +This method returns a name=>value pare for limiting a search +by the collection column. If the collection column is not +defined then this will return an empty list. + +=cut + +sub _grouping_clause { + my( $self ) = @_; + my $col = $self->grouping_column(); + if ($col) { + return ( $col => $self->get_column($col) ); + } + return (); +} + +1; +__END__ + +=head1 BUGS + +=head2 Unique Constraints + +Unique indexes and constraints on the position column are not +supported at this time. It would be make sense to support them, +but there are some unexpected database issues that make this +hard to do. The main problem from the author's view is that +SQLite (the DB engine that we use for testing) does not support +ORDER BY on updates. + +=head2 Race Condition on Insert + +If a position is not specified for an insert than a position +will be chosen based on COUNT(*)+1. But, it first selects the +count then inserts the record. The space of time between select +and insert introduces a race condition. To fix this we need the +ability to lock tables in DBIC. I've added an entry in the TODO +about this. + +=head2 Multiple Moves + +Be careful when issueing move_* methods to multiple objects. If +you've pre-loaded the objects then when you move one of the objects +the position of the other object will not reflect their new value +until you reload them from the database. + +There are times when you will want to move objects as groups, such +as changeing the parent of several objects at once - this directly +conflicts with this problem. One solution is for us to write a +ResultSet class that supports a parent() method, for example. Another +solution is to somehow automagically modify the objects that exist +in the current object's result set to have the new position value. + +=head1 AUTHOR + +Aran Deltac + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + diff --git a/lib/DBIx/Class/Relationship.pm b/lib/DBIx/Class/Relationship.pm index 6048fd0..f9f85c2 100644 --- a/lib/DBIx/Class/Relationship.pm +++ b/lib/DBIx/Class/Relationship.pm @@ -134,6 +134,8 @@ of C. { prefetch => [qw/book/], }); my @book_objs = $obj->books; + my $books_rs = $obj->books; + ( $books_rs ) = $obj->books_rs; $obj->add_to_books(\%col_data); @@ -142,9 +144,14 @@ foreign class store the calling class's primary key in one (or more) of its columns. You should pass the name of the column in the foreign class as the $cond argument, or specify a complete join condition. -As well as the accessor method, a method named C<< add_to_ >> -will also be added to your Row items, this allows you to insert new -related items, using the same mechanism as in L. +Three methods are created when you create a has_many relationship. The first +method is the expected accessor method. The second is almost exactly the same +as the accessor method but "_rs" is added to the end of the method name. This +method works just like the normal accessor, except that it returns a resultset +no matter what, even in list context. The third method, named +C<< add_to_ >>, will also be added to your Row items, this allows +you to insert new related items, using the same mechanism as in +L. If you delete an object in a class with a C relationship, all the related objects will be deleted as well. However, any database-level diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 035661a..b20eb16 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -48,6 +48,7 @@ sub add_relationship_accessor { ); } elsif ($acc_type eq 'multi') { $meth{$rel} = sub { shift->search_related($rel, @_) }; + $meth{"${rel}_rs"} = sub { shift->search_related_rs($rel, @_) }; $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); }; } else { $class->throw_exception("No such relationship accessor type $acc_type"); diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm index 05f4c52..0401c0a 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -175,7 +175,8 @@ sub related_resultset { =head2 search_related - $rs->search_related('relname', $cond, $attrs); + @objects = $rs->search_related('relname', $cond, $attrs); + $objects_rs = $rs->search_related('relname', $cond, $attrs); Run a search on a related resultset. The search will be restricted to the item or items represented by the L it was called @@ -187,6 +188,19 @@ sub search_related { return shift->related_resultset(shift)->search(@_); } +=head2 search_related_rs + + ( $objects_rs ) = $rs->search_related_rs('relname', $cond, $attrs); + +This method works exactly the same as search_related, except that +it garauntees a restultset, even in list context. + +=cut + +sub search_related_rs { + return shift->related_resultset(shift)->search_rs(@_); +} + =head2 count_related $obj->count_related('relname', $cond, $attrs); @@ -253,12 +267,27 @@ sub find_related { return $self->search_related($rel)->find(@_); } +=head2 find_or_new_related + + my $new_obj = $obj->find_or_new_related('relname', \%col_data); + +Find an item of a related class. If none exists, instantiate a new item of the +related class. The object will not be saved into your storage until you call +L on it. + +=cut + +sub find_or_new_related { + my $self = shift; + return $self->find_related(@_) || $self->new_related(@_); +} + =head2 find_or_create_related my $new_obj = $obj->find_or_create_related('relname', \%col_data); Find or create an item of a related class. See -L for details. +L for details. =cut @@ -268,6 +297,21 @@ sub find_or_create_related { return (defined($obj) ? $obj : $self->create_related(@_)); } +=head2 update_or_create_related + + my $updated_item = $obj->update_or_create_related('relname', \%col_data, \%attrs?); + +Update or create an item of a related class. See +L for details. + +=cut + +sub update_or_create_related { + my $self = shift; + my $rel = shift; + return $self->related_resultset($rel)->update_or_create(@_); +} + =head2 set_from_related $book->set_from_related('author', $author_obj); diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm index 535fa75..8c8ceaa 100644 --- a/lib/DBIx/Class/Relationship/BelongsTo.pm +++ b/lib/DBIx/Class/Relationship/BelongsTo.pm @@ -5,11 +5,7 @@ use warnings; sub belongs_to { my ($class, $rel, $f_class, $cond, $attrs) = @_; - eval "require $f_class"; - if ($@) { - $class->throw_exception($@) unless $@ =~ /Can't locate/; - } - + $class->ensure_class_loaded($f_class); # no join condition or just a column name if (!ref $cond) { my %f_primaries = map { $_ => 1 } eval { $f_class->primary_columns }; diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm index a709d6a..aa46486 100644 --- a/lib/DBIx/Class/Relationship/HasMany.pm +++ b/lib/DBIx/Class/Relationship/HasMany.pm @@ -6,11 +6,8 @@ use warnings; sub has_many { my ($class, $rel, $f_class, $cond, $attrs) = @_; - - eval "require $f_class"; - if ($@) { - $class->throw_exception($@) unless $@ =~ /Can't locate/; - } + + $class->ensure_class_loaded($f_class); unless (ref $cond) { my ($pri, $too_many) = $class->primary_columns; diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm index 4efbec0..aa94a08 100644 --- a/lib/DBIx/Class/Relationship/HasOne.pm +++ b/lib/DBIx/Class/Relationship/HasOne.pm @@ -14,11 +14,7 @@ sub has_one { sub _has_one { my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_; - eval "require $f_class"; - if ($@) { - $class->throw_exception($@) unless $@ =~ /Can't locate/; - } - + $class->ensure_class_loaded($f_class); unless (ref $cond) { my ($pri, $too_many) = $class->primary_columns; $class->throw_exception( "might_have/has_one can only infer join for a single primary key; ${class} has more" ) diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm index 21fc256..cc0d1ef 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -8,8 +8,10 @@ use overload fallback => 1; use Data::Page; use Storable; +use Data::Dumper; use Scalar::Util qw/weaken/; +use DBIx::Class::ResultSetColumn; use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/AccessorGroup/); __PACKAGE__->mk_group_accessors('simple' => qw/result_source result_class/); @@ -85,68 +87,6 @@ sub new { my ($source, $attrs) = @_; weaken $source; - $attrs = Storable::dclone($attrs || {}); # { %{ $attrs || {} } }; - #use Data::Dumper; warn Dumper($attrs); - my $alias = ($attrs->{alias} ||= 'me'); - - $attrs->{columns} ||= delete $attrs->{cols} if $attrs->{cols}; - delete $attrs->{as} if $attrs->{columns}; - $attrs->{columns} ||= [ $source->columns ] unless $attrs->{select}; - $attrs->{select} = [ - map { m/\./ ? $_ : "${alias}.$_" } @{delete $attrs->{columns}} - ] if $attrs->{columns}; - $attrs->{as} ||= [ - map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}} - ]; - if (my $include = delete $attrs->{include_columns}) { - push(@{$attrs->{select}}, @$include); - push(@{$attrs->{as}}, map { m/([^.]+)$/; $1; } @$include); - } - #use Data::Dumper; warn Dumper(@{$attrs}{qw/select as/}); - - $attrs->{from} ||= [ { $alias => $source->from } ]; - $attrs->{seen_join} ||= {}; - my %seen; - if (my $join = delete $attrs->{join}) { - foreach my $j (ref $join eq 'ARRAY' ? @$join : ($join)) { - if (ref $j eq 'HASH') { - $seen{$_} = 1 foreach keys %$j; - } else { - $seen{$j} = 1; - } - } - push(@{$attrs->{from}}, $source->resolve_join( - $join, $attrs->{alias}, $attrs->{seen_join}) - ); - } - - $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct}; - $attrs->{order_by} = [ $attrs->{order_by} ] if - $attrs->{order_by} and !ref($attrs->{order_by}); - $attrs->{order_by} ||= []; - - my $collapse = $attrs->{collapse} || {}; - if (my $prefetch = delete $attrs->{prefetch}) { - my @pre_order; - foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) { - if ( ref $p eq 'HASH' ) { - foreach my $key (keys %$p) { - push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias})) - unless $seen{$key}; - } - } else { - push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias})) - unless $seen{$p}; - } - my @prefetch = $source->resolve_prefetch( - $p, $attrs->{alias}, {}, \@pre_order, $collapse); - push(@{$attrs->{select}}, map { $_->[0] } @prefetch); - push(@{$attrs->{as}}, map { $_->[1] } @prefetch); - } - push(@{$attrs->{order_by}}, @pre_order); - } - $attrs->{collapse} = $collapse; -# use Data::Dumper; warn Dumper($collapse) if keys %{$collapse}; if ($attrs->{page}) { $attrs->{rows} ||= 10; @@ -154,12 +94,14 @@ sub new { $attrs->{offset} += ($attrs->{rows} * ($attrs->{page} - 1)); } + $attrs->{alias} ||= 'me'; + bless { result_source => $source, result_class => $attrs->{result_class} || $source->result_class, cond => $attrs->{where}, - from => $attrs->{from}, - collapse => $collapse, +# from => $attrs->{from}, +# collapse => $collapse, count => undef, page => delete $attrs->{page}, pager => undef, @@ -195,11 +137,51 @@ call it as C. sub search { my $self = shift; - - my $attrs = { %{$self->{attrs}} }; - my $having = delete $attrs->{having}; - $attrs = { %$attrs, %{ pop(@_) } } if @_ > 1 and ref $_[$#_] eq 'HASH'; + my $rs = $self->search_rs( @_ ); + return (wantarray ? $rs->all : $rs); +} + +=head2 search_rs + +=over 4 + +=item Arguments: $cond, \%attrs? + +=item Return Value: $resultset + +=back + +This method does the same exact thing as search() except it will +always return a resultset, even in list context. + +=cut + +sub search_rs { + my $self = shift; + + my $our_attrs = { %{$self->{attrs}} }; + my $having = delete $our_attrs->{having}; + my $attrs = {}; + $attrs = pop(@_) if @_ > 1 and ref $_[$#_] eq 'HASH'; + + # merge new attrs into old + foreach my $key (qw/join prefetch/) { + next unless (exists $attrs->{$key}); + if (exists $our_attrs->{$key}) { + $our_attrs->{$key} = $self->_merge_attr($our_attrs->{$key}, $attrs->{$key}); + } else { + $our_attrs->{$key} = $attrs->{$key}; + } + delete $attrs->{$key}; + } + + if (exists $our_attrs->{prefetch}) { + $our_attrs->{join} = $self->_merge_attr($our_attrs->{join}, $our_attrs->{prefetch}, 1); + } + + my $new_attrs = { %{$our_attrs}, %{$attrs} }; + # merge new where and having into old my $where = (@_ ? ((@_ == 1 || ref $_[0] eq "HASH") ? shift @@ -209,22 +191,23 @@ sub search { : {@_})) : undef()); if (defined $where) { - $attrs->{where} = (defined $attrs->{where} + $new_attrs->{where} = (defined $new_attrs->{where} ? { '-and' => [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ } - $where, $attrs->{where} ] } + $where, $new_attrs->{where} ] } : $where); } if (defined $having) { - $attrs->{having} = (defined $attrs->{having} + $new_attrs->{having} = (defined $new_attrs->{having} ? { '-and' => [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ } - $having, $attrs->{having} ] } + $having, $new_attrs->{having} ] } : $having); } - my $rs = (ref $self)->new($self->result_source, $attrs); + my $rs = (ref $self)->new($self->result_source, $new_attrs); + $rs->{_parent_rs} = $self->{_parent_rs} if ($self->{_parent_rs}); #XXX - hack to pass through parent of related resultsets unless (@_) { # no search, effectively just a clone my $rows = $self->get_cache; @@ -233,7 +216,7 @@ sub search { } } - return (wantarray ? $rs->all : $rs); + return $rs; } =head2 search_literal @@ -271,12 +254,17 @@ sub search_literal { =back -Finds a row based on its primary key or unique constraint. For example: +Finds a row based on its primary key or unique constraint. For example, to find +a row by its primary key: my $cd = $schema->resultset('CD')->find(5); -Also takes an optional C attribute, to search by a specific key or unique -constraint. For example: +You can also find a row by a specific unique constraint using the C +attribute. For example: + + my $cd = $schema->resultset('CD')->find('Massive Attack', 'Mezzanine', { key => 'artist_title' }); + +Additionally, you can specify the columns explicitly by name: my $cd = $schema->resultset('CD')->find( { @@ -286,51 +274,99 @@ constraint. For example: { key => 'artist_title' } ); -See also L and L. +If no C is specified and you explicitly name columns, it searches on all +unique constraints defined on the source, including the primary key. + +If the C is specified as C, it searches only on the primary key. + +See also L and L. For information on how to +declare unique constraints, see +L. =cut sub find { - my ($self, @vals) = @_; - my $attrs = (@vals > 1 && ref $vals[$#vals] eq 'HASH' ? pop(@vals) : {}); + my $self = shift; + my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + + # Parse out a hash from input + my @cols = exists $attrs->{key} + ? $self->result_source->unique_constraint_columns($attrs->{key}) + : $self->result_source->primary_columns; - my @cols = $self->result_source->primary_columns; - if (exists $attrs->{key}) { - my %uniq = $self->result_source->unique_constraints; + my $hash; + if (ref $_[0] eq 'HASH') { + $hash = { %{$_[0]} }; + } + elsif (@_ == @cols) { + $hash = {}; + @{$hash}{@cols} = @_; + } + elsif (@_) { + # For backwards compatibility + $hash = {@_}; + } + else { $self->throw_exception( - "Unknown key $attrs->{key} on '" . $self->result_source->name . "'" - ) unless exists $uniq{$attrs->{key}}; - @cols = @{ $uniq{$attrs->{key}} }; + "Arguments to find must be a hashref or match the number of columns in the " + . (exists $attrs->{key} ? "$attrs->{key} unique constraint" : "primary key") + ); } - #use Data::Dumper; warn Dumper($attrs, @vals, @cols); + + # Check the hash we just parsed against our source's unique constraints + my @constraint_names = exists $attrs->{key} + ? ($attrs->{key}) + : $self->result_source->unique_constraint_names; $self->throw_exception( "Can't find unless a primary key or unique constraint is defined" - ) unless @cols; - - my $query; - if (ref $vals[0] eq 'HASH') { - $query = { %{$vals[0]} }; - } elsif (@cols == @vals) { - $query = {}; - @{$query}{@cols} = @vals; - } else { - $query = {@vals}; - } - foreach my $key (grep { ! m/\./ } keys %$query) { - $query->{"$self->{attrs}{alias}.$key"} = delete $query->{$key}; + ) unless @constraint_names; + + my @unique_queries; + foreach my $name (@constraint_names) { + my @unique_cols = $self->result_source->unique_constraint_columns($name); + my $unique_query = $self->_build_unique_query($hash, \@unique_cols); + + # Add the ResultSet's alias + foreach my $key (grep { ! m/\./ } keys %$unique_query) { + my $alias = $self->{attrs}->{alias}; + $unique_query->{"$alias.$key"} = delete $unique_query->{$key}; + } + + push @unique_queries, $unique_query if %$unique_query; } - #warn Dumper($query); - + + # Handle cases where the ResultSet already defines the query + my $query = @unique_queries ? \@unique_queries : undef; + + # Run the query if (keys %$attrs) { - my $rs = $self->search($query,$attrs); - return keys %{$rs->{collapse}} ? $rs->next : $rs->single; - } else { - return keys %{$self->{collapse}} ? - $self->search($query)->next : - $self->single($query); + my $rs = $self->search($query, $attrs); + $rs->_resolve; + return keys %{$rs->{_attrs}->{collapse}} ? $rs->next : $rs->single; + } + else { + $self->_resolve; + return (keys %{$self->{_attrs}->{collapse}}) + ? $self->search($query)->next + : $self->single($query); } } +# _build_unique_query +# +# Constrain the specified query hash based on the specified column names. + +sub _build_unique_query { + my ($self, $query, $unique_cols) = @_; + + my %unique_query = + map { $_ => $query->{$_} } + grep { exists $query->{$_} } + @$unique_cols; + + return \%unique_query; +} + =head2 search_related =over 4 @@ -371,9 +407,11 @@ L for more information. sub cursor { my ($self) = @_; - my $attrs = { %{$self->{attrs}} }; + + $self->_resolve; + my $attrs = { %{$self->{_attrs}} }; return $self->{cursor} - ||= $self->result_source->storage->select($self->{from}, $attrs->{select}, + ||= $self->result_source->storage->select($attrs->{from}, $attrs->{select}, $attrs->{where},$attrs); } @@ -390,7 +428,7 @@ sub cursor { my $cd = $schema->resultset('CD')->single({ year => 2001 }); Inflates the first result without creating a cursor if the resultset has -any records in it; if not returns nothing. Used by find() as an optimisation. +any records in it; if not returns nothing. Used by L as an optimisation. Can optionally take an additional condition *only* - this is a fast-code-path method; if you need to add extra joins or similar call ->search and then @@ -400,7 +438,8 @@ method; if you need to add extra joins or similar call ->search and then sub single { my ($self, $where) = @_; - my $attrs = { %{$self->{attrs}} }; + $self->_resolve; + my $attrs = { %{$self->{_attrs}} }; if ($where) { if (defined $attrs->{where}) { $attrs->{where} = { @@ -412,12 +451,35 @@ sub single { $attrs->{where} = $where; } } + my @data = $self->result_source->storage->select_single( - $self->{from}, $attrs->{select}, + $attrs->{from}, $attrs->{select}, $attrs->{where},$attrs); return (@data ? $self->_construct_object(@data) : ()); } +=head2 get_column + +=over 4 + +=item Arguments: $cond? + +=item Return Value: $resultsetcolumn + +=back + + my $max_length = $rs->get_column('length')->max; + +Returns a ResultSetColumn instance for $column based on $self + +=cut + +sub get_column { + my ($self, $column) = @_; + + my $new = DBIx::Class::ResultSetColumn->new($self, $column); + return $new; +} =head2 search_like @@ -516,27 +578,164 @@ sub next { @{delete $self->{stashed_row}} : $self->cursor->next ); -# warn Dumper(\@row); use Data::Dumper; return unless (@row); return $self->_construct_object(@row); } +sub _resolve { + my $self = shift; + + return if(exists $self->{_attrs}); #return if _resolve has already been called + + my $attrs = $self->{attrs}; + my $source = ($self->{_parent_rs}) ? $self->{_parent_rs} : $self->{result_source}; + + # XXX - lose storable dclone + my $record_filter = delete $attrs->{record_filter} if (defined $attrs->{record_filter}); + $attrs = Storable::dclone($attrs || {}); # { %{ $attrs || {} } }; + $attrs->{record_filter} = $record_filter if ($record_filter); + $self->{attrs}->{record_filter} = $record_filter if ($record_filter); + + my $alias = $attrs->{alias}; + + $attrs->{columns} ||= delete $attrs->{cols} if $attrs->{cols}; + delete $attrs->{as} if $attrs->{columns}; + $attrs->{columns} ||= [ $self->{result_source}->columns ] unless $attrs->{select}; + my $select_alias = ($self->{_parent_rs}) ? $self->{attrs}->{_live_join} : $alias; + $attrs->{select} = [ + map { m/\./ ? $_ : "${select_alias}.$_" } @{delete $attrs->{columns}} + ] if $attrs->{columns}; + $attrs->{as} ||= [ + map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}} + ]; + if (my $include = delete $attrs->{include_columns}) { + push(@{$attrs->{select}}, @$include); + push(@{$attrs->{as}}, map { m/([^.]+)$/; $1; } @$include); + } + + $attrs->{from} ||= [ { $alias => $source->from } ]; + $attrs->{seen_join} ||= {}; + my %seen; + if (my $join = delete $attrs->{join}) { + foreach my $j (ref $join eq 'ARRAY' ? @$join : ($join)) { + if (ref $j eq 'HASH') { + $seen{$_} = 1 foreach keys %$j; + } else { + $seen{$j} = 1; + } + } + + push(@{$attrs->{from}}, $source->resolve_join($join, $attrs->{alias}, $attrs->{seen_join})); + } + $attrs->{group_by} ||= $attrs->{select} if delete $attrs->{distinct}; + $attrs->{order_by} = [ $attrs->{order_by} ] if + $attrs->{order_by} and !ref($attrs->{order_by}); + $attrs->{order_by} ||= []; + + if(my $seladds = delete($attrs->{'+select'})) { + my @seladds = (ref($seladds) eq 'ARRAY' ? @$seladds : ($seladds)); + $attrs->{select} = [ + @{ $attrs->{select} }, + map { (m/\./ || ref($_)) ? $_ : "${alias}.$_" } $seladds + ]; + } + if(my $asadds = delete($attrs->{'+as'})) { + my @asadds = (ref($asadds) eq 'ARRAY' ? @$asadds : ($asadds)); + $attrs->{as} = [ @{ $attrs->{as} }, @asadds ]; + } + + my $collapse = $attrs->{collapse} || {}; + if (my $prefetch = delete $attrs->{prefetch}) { + my @pre_order; + foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) { + if ( ref $p eq 'HASH' ) { + foreach my $key (keys %$p) { + push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias})) + unless $seen{$key}; + } + } else { + push(@{$attrs->{from}}, $source->resolve_join($p, $attrs->{alias})) + unless $seen{$p}; + } + my @prefetch = $source->resolve_prefetch( + $p, $attrs->{alias}, {}, \@pre_order, $collapse); + push(@{$attrs->{select}}, map { $_->[0] } @prefetch); + push(@{$attrs->{as}}, map { $_->[1] } @prefetch); + } + push(@{$attrs->{order_by}}, @pre_order); + } + $attrs->{collapse} = $collapse; + $self->{_attrs} = $attrs; +} + +sub _merge_attr { + my ($self, $a, $b, $is_prefetch) = @_; + + return $b unless $a; + if (ref $b eq 'HASH' && ref $a eq 'HASH') { + foreach my $key (keys %{$b}) { + if (exists $a->{$key}) { + $a->{$key} = $self->_merge_attr($a->{$key}, $b->{$key}, $is_prefetch); + } else { + $a->{$key} = delete $b->{$key}; + } + } + return $a; + } else { + $a = [$a] unless (ref $a eq 'ARRAY'); + $b = [$b] unless (ref $b eq 'ARRAY'); + + my $hash = {}; + my $array = []; + foreach ($a, $b) { + foreach my $element (@{$_}) { + if (ref $element eq 'HASH') { + $hash = $self->_merge_attr($hash, $element, $is_prefetch); + } elsif (ref $element eq 'ARRAY') { + $array = [@{$array}, @{$element}]; + } else { + if (($b == $_) && $is_prefetch) { + $self->_merge_array($array, $element, $is_prefetch); + } else { + push(@{$array}, $element); + } + } + } + } + + if ((keys %{$hash}) && (scalar(@{$array} > 0))) { + return [$hash, @{$array}]; + } else { + return (keys %{$hash}) ? $hash : $array; + } + } +} + +sub _merge_array { + my ($self, $a, $b) = @_; + + $b = [$b] unless (ref $b eq 'ARRAY'); + # add elements from @{$b} to @{$a} which aren't already in @{$a} + foreach my $b_element (@{$b}) { + push(@{$a}, $b_element) unless grep {$b_element eq $_} @{$a}; + } +} + sub _construct_object { my ($self, @row) = @_; - my @as = @{ $self->{attrs}{as} }; - + my @as = @{ $self->{_attrs}{as} }; + my $info = $self->_collapse_result(\@as, \@row); - my $new = $self->result_class->inflate_result($self->result_source, @$info); - - $new = $self->{attrs}{record_filter}->($new) - if exists $self->{attrs}{record_filter}; + $new = $self->{_attrs}{record_filter}->($new) + if exists $self->{_attrs}{record_filter}; return $new; } sub _collapse_result { my ($self, $as, $row, $prefix) = @_; + my $live_join = $self->{attrs}->{_live_join} ||=""; my %const; my @copy = @$row; @@ -556,7 +755,7 @@ sub _collapse_result { my $info = [ {}, {} ]; foreach my $key (keys %const) { - if (length $key) { + if (length $key && $key ne $live_join) { my $target = $info; my @parts = split(/\./, $key); foreach my $p (@parts) { @@ -572,9 +771,9 @@ sub _collapse_result { if (defined $prefix) { @collapse = map { m/^\Q${prefix}.\E(.+)$/ ? ($1) : () - } keys %{$self->{collapse}} + } keys %{$self->{_attrs}->{collapse}} } else { - @collapse = keys %{$self->{collapse}}; + @collapse = keys %{$self->{_attrs}->{collapse}}; }; if (@collapse) { @@ -584,7 +783,7 @@ sub _collapse_result { $target = $target->[1]->{$p} ||= []; } my $c_prefix = (defined($prefix) ? "${prefix}.${c}" : $c); - my @co_key = @{$self->{collapse}{$c_prefix}}; + my @co_key = @{$self->{_attrs}->{collapse}{$c_prefix}}; my %co_check = map { ($_, $target->[0]->{$_}); } @co_key; my $tree = $self->_collapse_result($as, $row, $c_prefix); my (@final, @raw); @@ -597,10 +796,9 @@ sub _collapse_result { $row = $self->{stashed_row} = \@raw; $tree = $self->_collapse_result($as, $row, $c_prefix); } - @$target = (@final ? @final : [ {}, {} ]); + @$target = (@final ? @final : [ {}, {} ]); # single empty result to indicate an empty prefetched has_many } - return $info; } @@ -659,7 +857,9 @@ sub count { sub _count { # Separated out so pager can get the full count my $self = shift; my $select = { count => '*' }; - my $attrs = { %{ $self->{attrs} } }; + + $self->_resolve; + my $attrs = { %{ $self->{_attrs} } }; if (my $group_by = delete $attrs->{group_by}) { delete $attrs->{having}; my @distinct = (ref $group_by ? @$group_by : ($group_by)); @@ -675,7 +875,6 @@ sub _count { # Separated out so pager can get the full count } $select = { count => { distinct => \@distinct } }; - #use Data::Dumper; die Dumper $select; } $attrs->{select} = $select; @@ -683,7 +882,6 @@ sub _count { # Separated out so pager can get the full count # offset, order by and page are not needed to count. record_filter is cdbi delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/; - my ($count) = (ref $self)->new($self->result_source, $attrs)->cursor->next; return $count; } @@ -726,12 +924,14 @@ sub all { my @obj; - if (keys %{$self->{collapse}}) { + # TODO: don't call resolve here + $self->_resolve; + if (keys %{$self->{_attrs}->{collapse}}) { +# if ($self->{attrs}->{prefetch}) { # Using $self->cursor->all is really just an optimisation. # If we're collapsing has_many prefetches it probably makes # very little difference, and this is cleaner than hacking # _construct_object to survive the approach - $self->cursor->reset; my @row = $self->cursor->next; while (@row) { push(@obj, $self->_construct_object(@row)); @@ -763,6 +963,8 @@ Resets the resultset's cursor, so you can iterate through the elements again. sub reset { my ($self) = @_; + delete $self->{_attrs} if (exists $self->{_attrs}); + $self->{all_cache_position} = 0; $self->cursor->reset; return $self; @@ -817,7 +1019,7 @@ sub _cond_for_update_delete { $cond->{-and} = []; my @cond = @{$self->{cond}{-and}}; - for (my $i = 0; $i < @cond - 1; $i++) { + for (my $i = 0; $i <= @cond - 1; $i++) { my $entry = $cond[$i]; my %hash; @@ -829,7 +1031,7 @@ sub _cond_for_update_delete { } else { $entry =~ /([^.]+)$/; - $hash{$entry} = $cond[++$i]; + $hash{$1} = $cond[++$i]; } push @{$cond->{-and}}, \%hash; @@ -1031,6 +1233,32 @@ sub new_result { return $obj; } +=head2 find_or_new + +=over 4 + +=item Arguments: \%vals, \%attrs? + +=item Return Value: $object + +=back + +Find an existing record from this resultset. If none exists, instantiate a new +result object and return it. The object will not be saved into your storage +until you call L on it. + +If you want objects to be saved immediately, use L instead. + +=cut + +sub find_or_new { + my $self = shift; + my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); + my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; + my $exists = $self->find($hash, $attrs); + return defined $exists ? $exists : $self->new_result($hash); +} + =head2 create =over 4 @@ -1087,7 +1315,8 @@ constraint. For example: { key => 'artist_title' } ); -See also L and L. +See also L and L. For information on how to declare +unique constraints, see L. =cut @@ -1134,7 +1363,8 @@ source, including the primary key. If the C is specified as C, it searches only on the primary key. -See also L and L. +See also L and L. For information on how to declare +unique constraints, see L. =cut @@ -1143,29 +1373,10 @@ sub update_or_create { my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {}); my $hash = ref $_[0] eq 'HASH' ? shift : {@_}; - my %unique_constraints = $self->result_source->unique_constraints; - my @constraint_names = (exists $attrs->{key} - ? ($attrs->{key}) - : keys %unique_constraints); - - my @unique_hashes; - foreach my $name (@constraint_names) { - my @unique_cols = @{ $unique_constraints{$name} }; - my %unique_hash = - map { $_ => $hash->{$_} } - grep { exists $hash->{$_} } - @unique_cols; - - push @unique_hashes, \%unique_hash - if (scalar keys %unique_hash == scalar @unique_cols); - } - - if (@unique_hashes) { - my $row = $self->single(\@unique_hashes); - if (defined $row) { - $row->update($hash); - return $row; - } + my $row = $self->find($hash, $attrs); + if (defined $row) { + $row->update($hash); + return $row; } return $self->create($hash); @@ -1209,7 +1420,7 @@ than re-querying the database even if the cache attr is not set. sub set_cache { my ( $self, $data ) = @_; $self->throw_exception("set_cache requires an arrayref") - if defined($data) && (ref $data ne 'ARRAY'); + if defined($data) && (ref $data ne 'ARRAY'); $self->{all_cache} = $data; } @@ -1249,28 +1460,28 @@ Returns a related resultset for the supplied relationship name. sub related_resultset { my ( $self, $rel ) = @_; + $self->{related_resultsets} ||= {}; return $self->{related_resultsets}{$rel} ||= do { - #warn "fetching related resultset for rel '$rel'"; + #warn "fetching related resultset for rel '$rel' " . $self->result_source->{name}; my $rel_obj = $self->result_source->relationship_info($rel); $self->throw_exception( "search_related: result source '" . $self->result_source->name . "' has no such relationship ${rel}") unless $rel_obj; #die Dumper $self->{attrs}; - my $rs = $self->search(undef, { join => $rel }); - my $alias = defined $rs->{attrs}{seen_join}{$rel} - && $rs->{attrs}{seen_join}{$rel} > 1 - ? join('_', $rel, $rs->{attrs}{seen_join}{$rel}) - : $rel; - - $self->result_source->schema->resultset($rel_obj->{class} + my $rs = $self->result_source->schema->resultset($rel_obj->{class} )->search( undef, - { %{$rs->{attrs}}, - alias => $alias, + { %{$self->{attrs}}, select => undef, - as => undef } + as => undef, + join => $rel, + _live_join => $rel } ); + + # keep reference of the original resultset + $rs->{_parent_rs} = $self->result_source; + return $rs; }; } @@ -1364,6 +1575,23 @@ When you use function/stored procedure names and do not supply an C attribute, the column names returned are storage-dependent. E.g. MySQL would return a column named C in the above example. +=head2 +select + +=over 4 + +Indicates additional columns to be selected from storage. Works the same as +L