+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
component would provide a new syntax for filtering column update and
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 <dbname>.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
+
L<DBIx::Class::PK::Auto> - Retrieve automatically created primary keys upon insert.
+L<DBIx::Class::Positional> - Modify the position of objects in an ordered list.
+
L<DBIx::Class::QueriesTime> - Display the amount of time it takes to run queries.
L<DBIx::Class::RandomStringColumns> - Declare virtual columns that return random strings.
L<DBIx::Class::Validation> - Validate all data before submitting to your database.
+L<DBIx::Class::Tree::AdjacencyList> - Manage a tree of data using the common adjacency list model.
+
+L<DBIx::Class::Tree::NestedSet> - Manage a positional tree of data using the nested set model.
+
+L<DBIx::Class::TokenGroup> - Search for tokens in a tree of groups.
+
=head2 Core
These are the components that all, or nearly all, people will use
--- /dev/null
+# vim: ts=8:sw=4:sts=4:et
+package DBIx::Class::Positional;
+use strict;
+use warnings;
+use base qw( DBIx::Class );
+
+=head1 NAME
+
+DBIx::Class::Positional - Modify the position of objects in an ordered list.
+
+=head1 SYNOPSIS
+
+Create a table for your positionable data.
+
+ CREATE TABLE employees (
+ employee_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 Positional to the top
+of the component list.
+
+ __PACKAGE__->load_components(qw( Positional ... ));
+
+Specify the column that stores the position number for
+each row.
+
+ package My::Employee;
+ __PACKAGE__->position_column('position');
+ __PACKAGE__->collection_column('group_id'); # optional
+
+Thats it, now you can change the position of your objects.
+
+ #!/use/bin/perl
+ use My::Employee;
+
+ my $employee = My::Employee->create({ name=>'Matt S. Trout' });
+ # If using collection_column:
+ my $employee = My::Employee->create({ name=>'Matt S. Trout', group_id=>1 });
+
+ my $rs = $employee->siblings();
+ my @siblings = $employee->siblings();
+
+ my $sibling;
+ $sibling = $employee->first_sibling();
+ $sibling = $employee->last_sibling();
+ $sibling = $employee->previous_sibling();
+ $sibling = $employee->next_sibling();
+
+ $employee->move_previous();
+ $employee->move_next();
+ $employee->move_first();
+ $employee->move_last();
+ $employee->move_to( $position );
+
+=head1 DESCRIPTION
+
+This module provides a simple interface for modifying the 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 collection_column
+
+ __PACKAGE__->collection_column('thing_id');
+
+This method specified a column to limit all queries in
+this module by. This effectively allows you to have multiple
+positional lists within the same table.
+
+=cut
+
+__PACKAGE__->mk_classdata( 'collection_column' );
+
+=head2 siblings
+
+ my $rs = $employee->siblings();
+ my @siblings = $employee->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->_collection_clause(),
+ },
+ { order_by => $self->position_column },
+ );
+ return $rs->all() if (wantarray());
+ return $rs;
+}
+
+=head2 first_sibling
+
+ my $sibling = $employee->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->_collection_clause(),
+ },
+ )->all())[0];
+}
+
+=head2 last_sibling
+
+ my $sibling = $employee->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->_collection_clause()})->count();
+ return 0 if ($self->get_column($self->position_column())==$count);
+ return ($self->result_source->resultset->search(
+ {
+ $self->position_column => $count,
+ $self->_collection_clause(),
+ },
+ )->all())[0];
+}
+
+=head2 previous_sibling
+
+ my $sibling = $employee->previous_sibling();
+
+Returns the sibling that resides one position higher. 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->_collection_clause(),
+ }
+ )->all())[0];
+}
+
+=head2 next_sibling
+
+ my $sibling = $employee->next_sibling();
+
+Returns the sibling that resides one position lower. 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->_collection_clause()})->count();
+ return 0 if ($position==$count);
+ return ($self->result_source->resultset->search(
+ {
+ $position_column => $position + 1,
+ $self->_collection_clause(),
+ },
+ )->all())[0];
+}
+
+=head2 move_previous
+
+ $employee->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
+
+ $employee->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->_collection_clause()})->count();
+ return 0 if ($position==$count);
+ return $self->move_to( $position + 1 );
+}
+
+=head2 move_first
+
+ $employee->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
+
+ $employee->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->_collection_clause()})->count();
+ return $self->move_to( $count );
+}
+
+=head2 move_to
+
+ $employee->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 $rs = $self->result_source->resultset->search({
+ -and => [
+ $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
+ $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
+ ],
+ $self->_collection_clause(),
+ });
+ my $op = ($from_position>$to_position) ? '+' : '-';
+ $rs->update({
+ $position_column => \"$position_column $op 1",
+ });
+ $self->set_column( $position_column => $to_position );
+ $self->update();
+ 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->_collection_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 _collection_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 _collection_clause {
+ my( $self ) = @_;
+ if ($self->collection_column()) {
+ return ( $self->collection_column() => $self->get_column($self->collection_column()) );
+ }
+ return ();
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+=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.
+
+The 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 <bluefeet@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
=head2 is_changed
- my @changed_col_names = $obj->is_changed
+ my @changed_col_names = $obj->is_changed();
+ if ($obj->is_changed()) { ... }
=cut
return keys %{shift->{_dirty_columns} || {}};
}
+=head2 is_column_changed
+
+ if ($obj->is_column_changed('col')) { ... }
+
+=cut
+
+sub is_column_changed {
+ my( $self, $col ) = @_;
+ return exists $self->{_dirty_columns}->{$col};
+}
+
=head2 result_source
Accessor to the ResultSource this object was created from
__PACKAGE__->load_components(qw/AccessorGroup/);
__PACKAGE__->mk_group_accessors('simple' =>
- qw/connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugfh
+ qw/_connect_info _dbh _sql_maker _conn_pid _conn_tid debug debugfh
cursor on_connect_do transaction_depth/);
sub new {
=cut
+=head2 connect_info
+
+Connection information arrayref. Can either be the same arguments
+one would pass to DBI->connect, or a code-reference which returns
+a connected database handle. In either case, there is an optional
+final element in the arrayref, which can hold a hashref of
+connection-specific Storage::DBI options. These include
+C<on_connect_do>, and the sql_maker options C<limit_dialect>,
+C<quote_char>, and C<name_sep>. Examples:
+
+ ->connect_info([ 'dbi:SQLite:./foo.db' ]);
+ ->connect_info(sub { DBI->connect(...) });
+ ->connect_info([ 'dbi:Pg:dbname=foo',
+ 'postgres',
+ '',
+ { AutoCommit => 0 },
+ { quote_char => q{`}, name_sep => q{@} },
+ ]);
+
=head2 on_connect_do
Executes the sql statements given as a listref on every db connect.
return $self->_sql_maker;
}
+sub connect_info {
+ my ($self, $info_arg) = @_;
+
+ if($info_arg) {
+ my $info = [ @$info_arg ]; # copy because we can alter it
+ my $last_info = $info->[-1];
+ if(ref $last_info eq 'HASH') {
+ my $used;
+ if(my $on_connect_do = $last_info->{on_connect_do}) {
+ $used = 1;
+ $self->on_connect_do($on_connect_do);
+ }
+ for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
+ if(my $opt_val = $last_info->{$sql_maker_opt}) {
+ $used = 1;
+ $self->sql_maker->$sql_maker_opt($opt_val);
+ }
+ }
+
+ # remove our options hashref if it was there, to avoid confusing
+ # DBI in the case the user didn't use all 4 DBI options, as in:
+ # [ 'dbi:SQLite:foo.db', { quote_char => q{`} } ]
+ pop(@$info) if $used;
+ }
+
+ $self->_connect_info($info);
+ }
+
+ $self->_connect_info;
+}
+
sub _populate_dbh {
my ($self) = @_;
- my @info = @{$self->connect_info || []};
+ my @info = @{$self->_connect_info || []};
$self->_dbh($self->_connect(@info));
my $driver = $self->_dbh->{Driver}->{Name};
eval "require DBIx::Class::Storage::DBI::${driver}";
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/26positional.tl";
+run_tests(DBICTest->schema);
__PACKAGE__->load_classes(qw/
Artist
+ Employee
CD
#dummy
Track
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Employee;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components(qw( Positional PK::Auto Core ));
+
+__PACKAGE__->table('employees');
+
+__PACKAGE__->add_columns(
+ employee_id => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ position => {
+ data_type => 'integer',
+ },
+ group_id => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
+ name => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('employee_id');
+__PACKAGE__->position_column('position');
+
+__PACKAGE__->mk_classdata('field_name_for', {
+ employee_id => 'primary key',
+ position => 'list position',
+ group_id => 'collection column',
+ name => 'employee name',
+});
+
+1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Sun Mar 19 19:16:50 2006
+-- Created on Fri Mar 24 15:47:00 2006
--
BEGIN TRANSACTION;
--
+-- Table: employees
+--
+CREATE TABLE employees (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
+ position integer NOT NULL,
+ group_id integer,
+ name varchar(100)
+);
+
+--
-- Table: serialized
--
CREATE TABLE serialized (
);
--
--- Table: twokeys
+-- Table: cd_to_producer
--
-CREATE TABLE twokeys (
- artist integer NOT NULL,
+CREATE TABLE cd_to_producer (
cd integer NOT NULL,
- PRIMARY KEY (artist, cd)
+ producer integer NOT NULL,
+ PRIMARY KEY (cd, producer)
);
--
);
--
--- Table: cd_to_producer
---
-CREATE TABLE cd_to_producer (
- cd integer NOT NULL,
- producer integer NOT NULL,
- PRIMARY KEY (cd, producer)
-);
-
---
-- Table: artist
--
CREATE TABLE artist (
);
--
--- Table: fourkeys
---
-CREATE TABLE fourkeys (
- foo integer NOT NULL,
- bar integer NOT NULL,
- hello integer NOT NULL,
- goodbye integer NOT NULL,
- PRIMARY KEY (foo, bar, hello, goodbye)
-);
-
---
-- Table: cd
--
CREATE TABLE cd (
);
--
--- Table: artist_undirected_map
---
-CREATE TABLE artist_undirected_map (
- id1 integer NOT NULL,
- id2 integer NOT NULL,
- PRIMARY KEY (id1, id2)
-);
-
---
--- Table: onekey
---
-CREATE TABLE onekey (
- id INTEGER PRIMARY KEY NOT NULL,
- artist integer NOT NULL,
- cd integer NOT NULL
-);
-
---
-- Table: track
--
CREATE TABLE track (
);
--
--- Table: producer
+-- Table: self_ref
--
-CREATE TABLE producer (
- producerid INTEGER PRIMARY KEY NOT NULL,
+CREATE TABLE self_ref (
+ id INTEGER PRIMARY KEY NOT NULL,
+ name varchar(100) NOT NULL
+);
+
+--
+-- Table: treelike
+--
+CREATE TABLE treelike (
+ id INTEGER PRIMARY KEY NOT NULL,
+ parent integer NOT NULL,
name varchar(100) NOT NULL
);
);
--
--- Table: self_ref
+-- Table: twokeys
--
-CREATE TABLE self_ref (
- id INTEGER PRIMARY KEY NOT NULL,
+CREATE TABLE twokeys (
+ artist integer NOT NULL,
+ cd integer NOT NULL,
+ PRIMARY KEY (artist, cd)
+);
+
+--
+-- Table: fourkeys
+--
+CREATE TABLE fourkeys (
+ foo integer NOT NULL,
+ bar integer NOT NULL,
+ hello integer NOT NULL,
+ goodbye integer NOT NULL,
+ PRIMARY KEY (foo, bar, hello, goodbye)
+);
+
+--
+-- Table: artist_undirected_map
+--
+CREATE TABLE artist_undirected_map (
+ id1 integer NOT NULL,
+ id2 integer NOT NULL,
+ PRIMARY KEY (id1, id2)
+);
+
+--
+-- Table: producer
+--
+CREATE TABLE producer (
+ producerid INTEGER PRIMARY KEY NOT NULL,
name varchar(100) NOT NULL
);
--
--- Table: treelike
+-- Table: onekey
--
-CREATE TABLE treelike (
+CREATE TABLE onekey (
id INTEGER PRIMARY KEY NOT NULL,
- parent integer NOT NULL,
- name varchar(100) NOT NULL
+ artist integer NOT NULL,
+ cd integer NOT NULL
);
COMMIT;
'name' => {
'data_type' => 'varchar',
'is_nullable' => 0,
- }
+ },
};
is_deeply($type_info, $test_type_info, 'columns_info_for - column data types');
my $dbh = DB2Test->schema->storage->dbh;
-{
- local $SIG{__WARN__} = sub {};
- $dbh->do("DROP TABLE artist;");
-}
+$dbh->do("DROP TABLE artist", { RaiseError => 0, PrintError => 0 });
$dbh->do("CREATE TABLE artist (artistid INTEGER GENERATED BY DEFAULT AS IDENTITY (START WITH 1, INCREMENT BY 1), name VARCHAR(255), charfield CHAR(10));");
--- /dev/null
+# vim: filetype=perl
+
+sub run_tests {
+
+ plan tests => 321;
+ my $schema = shift;
+
+ my $employees = $schema->resultset('Employee');
+ $employees->delete();
+
+ foreach (1..5) {
+ $employees->create({ name=>'temp' });
+ }
+ $employees = $employees->search(undef,{order_by=>'position'});
+ ok( check_rs($employees), "intial positions" );
+
+ hammer_rs( $employees );
+
+ DBICTest::Employee->collection_column('group_id');
+ $employees->delete();
+ foreach my $group_id (1..3) {
+ foreach (1..6) {
+ $employees->create({ name=>'temp', group_id=>$group_id });
+ }
+ }
+ $employees = $employees->search(undef,{order_by=>'group_id,position'});
+
+ foreach my $group_id (1..3) {
+ my $group_employees = $employees->search({group_id=>$group_id});
+ $group_employees->all();
+ ok( check_rs($group_employees), "group intial positions" );
+ hammer_rs( $group_employees );
+ }
+
+}
+
+sub hammer_rs {
+ my $rs = shift;
+ my $employee;
+ my $count = $rs->count();
+ my $position_column = $rs->result_class->position_column();
+
+ foreach my $position (1..$count) {
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_previous();
+ ok( check_rs($rs), "move_previous( $position )" );
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_next();
+ ok( check_rs($rs), "move_next( $position )" );
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_first();
+ ok( check_rs($rs), "move_first( $position )" );
+
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_last();
+ ok( check_rs($rs), "move_last( $position )" );
+
+ foreach my $to_position (1..$count) {
+ $row = $rs->find({ $position_column=>$position });
+ $row->move_to($to_position);
+ ok( check_rs($rs), "move_to( $position => $to_position )" );
+ }
+
+ $row = $rs->find({ position=>$position });
+ if ($position==1) {
+ ok( !$row->previous_sibling(), 'no previous sibling' );
+ ok( !$row->first_sibling(), 'no first sibling' );
+ }
+ else {
+ ok( $row->previous_sibling(), 'previous sibling' );
+ ok( $row->first_sibling(), 'first sibling' );
+ }
+ if ($position==$count) {
+ ok( !$row->next_sibling(), 'no next sibling' );
+ ok( !$row->last_sibling(), 'no last sibling' );
+ }
+ else {
+ ok( $row->next_sibling(), 'next sibling' );
+ ok( $row->last_sibling(), 'last sibling' );
+ }
+
+ }
+}
+
+sub check_rs {
+ my( $rs ) = @_;
+ $rs->reset();
+ my $position_column = $rs->result_class->position_column();
+ my $expected_position = 0;
+ while (my $row = $rs->next()) {
+ $expected_position ++;
+ if ($row->get_column($position_column)!=$expected_position) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff