--- /dev/null
+# vim: ts=8:sw=4:sts=4:et
+package DBIx::Class::Positioned;
+use strict;
+use warnings;
+use base qw( DBIx::Class );
+
+=head1 NAME
+
+DBIx::Class::Positioned - 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
+ );
+
+In your Schema or DB class add Positioned to the top
+of the component list.
+
+ __PACKAGE__->load_components(qw( Positioned ... ));
+
+Specify the column that stores the position number for
+each row.
+
+ package My::Employee;
+ __PACKAGE__->position_column('position');
+
+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' });
+
+ 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 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 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->search(
+ {
+ $position_column => { '!=' => $self->get_column($position_column) },
+ $self->_parent_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.
+
+=cut
+
+sub first_sibling {
+ my( $self ) = @_;
+ return ($self->search(
+ { $self->_parent_clause() },
+ { rows=>1, order_by => $self->position_column },
+ )->all())[0];
+}
+
+=head2 last_sibling
+
+ my $sibling = $employee->last_sibling();
+
+Return the last sibling.
+
+=cut
+
+sub last_sibling {
+ my( $self ) = @_;
+ return ($self->search(
+ { $self->_parent_clause() },
+ { rows=>1, order_by => $self->position_column.' DESC' },
+ )->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;
+ return ($self->search(
+ {
+ $position_column => { '<' => $self->get_column($position_column) },
+ $self->_parent_clause(),
+ },
+ { rows=>1, order_by => $position_column.' DESC' },
+ )->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;
+ return ($self->search(
+ {
+ $position_column => { '>' => $self->get_column($position_column) },
+ $self->_parent_clause(),
+ },
+ { rows=>1, order_by => $position_column },
+ )->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 $previous = $self->previous_sibling();
+ return undef if (!$previous);
+ my $position_column = $self->position_column;
+ my $self_position = $self->get_column( $position_column );
+ $self->set_column( $position_column, $previous->get_column($position_column) );
+ $previous->set_column( $position_column, $self_position );
+ $self->update();
+ $previous->update();
+ return 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 $next = $self->next_sibling();
+ return undef if (!$next);
+ my $position_column = $self->position_column;
+ my $self_position = $self->get_column( $position_column );
+ $self->set_column( $position_column, $next->get_column($position_column) );
+ $next->set_column( $position_column, $self_position );
+ $self->update();
+ $next->update();
+ return 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->search({$self->_parent_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 undef if ( $from_position==$to_position );
+ my $rs = $self->search({
+ -and => [
+ $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
+ $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
+ ],
+ $self->_parent_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->search( {$self->_parent_clause()} )->count()+1 )
+ if (!$self->get_column($position_column));
+ $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;
+ $self->next::method( @_ );
+}
+
+=head1 PRIVATE METHODS
+
+These methods are used internally. You should never have the
+need to use them.
+
+=head2 _parent_clause
+
+ sub _parent_clause {
+ my( $self ) = @_;
+ return ( parent_id => $self->parent_id );
+ }
+
+This method is a placeholder for you, or another component, to
+provide additional limits for all the various queries in this
+module. This allows for more than one positionable list within
+the same table since any move_* method will adhere to the clause
+that you specify.
+
+=cut
+
+sub _parent_clause {
+ return ();
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+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.
+
+=head1 AUTHOR
+
+Aran Deltac <bluefeet@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
--- /dev/null
+# vim: ts=8:sw=4:sts=4:et
+package DBIx::Class::Tree::AdjacencyList;
+use strict;
+use warnings;
+use base qw( DBIx::Class );
+
+=head1 NAME
+
+DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model.
+
+=head1 SYNOPSIS
+
+Create a table for your tree data.
+
+ CREATE TABLE employees (
+ employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
+ parent_id INTEGER NOT NULL,
+ name TEXT NOT NULL
+ );
+
+In your Schema or DB class add Tree::AdjacencyList to the top
+of the component list.
+
+ __PACKAGE__->load_components(qw( Tree::AdjacencyList ... ));
+ # If you want positionable data make sure this
+ # module comes first, as in:
+ __PACKAGE__->load_components(qw( Tree::AdjacencyList Positioned ... ));
+
+Specify the column that contains the parent ID each row.
+
+ package My::Employee;
+ __PACKAGE__->parent_column('parent_id');
+
+Thats it, now you can modify and analyze the tree.
+
+ #!/use/bin/perl
+ use My::Employee;
+
+ my $employee = My::Employee->create({ name=>'Matt S. Trout' });
+
+ my $rs = $employee->children();
+ my @siblings = $employee->children();
+
+ my $parent = $employee->parent();
+ $employee->parent( 7 );
+
+=head1 DESCRIPTION
+
+This module provides methods for working with adjacency lists. The
+adjacency list model is a very common way of representing a tree structure.
+In this model each row in a table has a prent ID column that references the
+primary key of another row in the same table. Because of this the primary
+key must only be one column and is usually some sort of integer. The row
+with a parent ID of 0 is the root row and is usually the parent of all
+other rows.
+
+=head1 METHODS
+
+=head2 parent_column
+
+ __PACKAGE__->parent_column('parent_id');
+
+Declares the name of the column that contains the self-referential
+ID which defines the parent row. Defaults to "parent_id".
+
+=cut
+
+__PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' );
+
+=head2 parent
+
+ my $parent = $employee->parent();
+ $employee->parent( $parent_obj );
+ $employee->parent( $parent_id );
+
+Retrieves the object's parent ID, or sets the object's
+parent ID. If setting the parent ID then 0 will be returned
+if the object already has the specified parent, and 1 on
+success.
+
+If you are using the Positioned component this
+module will first move the object to the last position of
+the list, change the parent ID, then move the object to the
+last position of the new list. This ensures the intergrity
+of the positions.
+
+=cut
+
+sub parent {
+ my( $self, $new_parent ) = @_;
+ my $parent_column = $self->parent_column();
+ if ($new_parent) {
+ if (ref($new_parent)) {
+ $new_parent = $new_parent->id() || 0;
+ }
+ return 0 if ($new_parent == ($self->get_column($parent_column)||0));
+ my $positioned = $self->can('position_column');
+ $self->move_last if ($positioned);
+ $self->set_column( $parent_column => $new_parent );
+ if ($positioned) {
+ $self->set_column(
+ $self->position_column() => $self->search( {$self->_parent_clause()} )->count() + 1
+ );
+ }
+ $self->update();
+ return 1;
+ }
+ else {
+ return $self->find( $self->get_column( $parent_column ) );
+ }
+}
+
+=head2 children
+
+ my $children_rs = $employee->children();
+ my @children = $employee->children();
+
+Returns a list or record set, depending on context, of all
+the objects one level below the current one.
+
+If you are using the Positioned component then this method
+will return the children sorted by the position column.
+
+=cut
+
+sub children {
+ my( $self ) = @_;
+ my $rs = $self->search(
+ { $self->parent_column()=>$self->id() },
+ ( $self->can('position_column') ? {order_by=>$self->position_column()} : () )
+ );
+ return $rs->all() if (wantarray());
+ return $rs;
+}
+
+=head2 descendents
+
+Same as children. Declared so that this module is
+compatible with the Tree::NestedSet module.
+
+=cut
+
+#*descendants = \&children;
+
+=head1 PRIVATE METHODS
+
+These methods are used internally. You should never have the
+need to use them.
+
+=head2 _parent_clause
+
+This method is provided as an override of the method in
+DBIC::Positioned. This way Positioned and Tree::AdjacencyList
+may be used together without conflict. Make sure that in
+you component list that you load Tree::AdjacencyList before you
+load Positioned.
+
+This method assumes a parent ID of 0 if none is defined. This
+usually comes in to play if you are just createing the object
+and it has not yet been assigned a parent.
+
+=cut
+
+sub _parent_clause {
+ my( $self ) = @_;
+ return (
+ $self->parent_column() =>
+ $self->get_column($self->parent_column())
+ );
+}
+
+1;
+__END__
+
+=head1 AUTHOR
+
+Aran Deltac <bluefeet@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
--- /dev/null
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/26positioned.tl";
+run_tests(DBICTest->schema);
__PACKAGE__->load_classes(qw/
Artist
+ Employee::Positioned
+ Employee::AdjacencyList
+ Employee::PositionedAdjacencyList
CD
#dummy
Track
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Employee::AdjacencyList;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components(qw(
+ Tree::AdjacencyList
+ PK::Auto
+ Core
+));
+
+__PACKAGE__->table('employees_adjacencylist');
+
+__PACKAGE__->add_columns(
+ employee_id => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ parent_id => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
+ name => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('employee_id');
+__PACKAGE__->parent_column('parent_id');
+
+__PACKAGE__->mk_classdata('field_name_for', {
+ employee_id => 'primary key',
+ parent_id => 'parent id',
+ name => 'employee name',
+});
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Employee::Positioned;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components(qw( Positioned PK::Auto Core ));
+
+__PACKAGE__->table('employees_positioned');
+
+__PACKAGE__->add_columns(
+ employee_id => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ position => {
+ data_type => 'integer',
+ },
+ 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',
+ name => 'employee name',
+});
+
+1;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::Employee::PositionedAdjacencyList;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components(qw(
+ Tree::AdjacencyList
+ Positioned
+ PK::Auto
+ Core
+));
+
+__PACKAGE__->table('employees_positioned_adjacencylist');
+
+__PACKAGE__->add_columns(
+ employee_id => {
+ data_type => 'integer',
+ is_auto_increment => 1
+ },
+ parent_id => {
+ data_type => 'integer',
+ is_nullable => 1,
+ },
+ position => {
+ data_type => 'integer',
+ },
+ name => {
+ data_type => 'varchar',
+ size => 100,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('employee_id');
+__PACKAGE__->position_column('position');
+__PACKAGE__->parent_column('parent_id');
+
+__PACKAGE__->mk_classdata('field_name_for', {
+ employee_id => 'primary key',
+ parent_id => 'parent id',
+ position => 'list position',
+ name => 'employee name',
+});
+
+1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Sun Mar 19 19:16:50 2006
+-- Created on Tue Mar 21 12:11:03 2006
--
BEGIN TRANSACTION;
--
+-- Table: employees_positioned
+--
+CREATE TABLE employees_positioned (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
+ position integer NOT NULL,
+ 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
+-- Table: employees_adjacencylist
--
-CREATE TABLE cd_to_producer (
- cd integer NOT NULL,
- producer integer NOT NULL,
- PRIMARY KEY (cd, producer)
+CREATE TABLE employees_adjacencylist (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
+ parent_id integer,
+ name varchar(100)
);
--
);
--
+-- Table: employees_positioned_adjacencylist
+--
+CREATE TABLE employees_positioned_adjacencylist (
+ employee_id INTEGER PRIMARY KEY NOT NULL,
+ parent_id integer,
+ position integer NOT NULL,
+ name varchar(100)
+);
+
+--
-- Table: self_ref_alias
--
CREATE TABLE self_ref_alias (
);
--
--- 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: treelike
--
-CREATE TABLE producer (
- producerid INTEGER PRIMARY KEY NOT NULL,
+CREATE TABLE treelike (
+ id INTEGER PRIMARY KEY NOT NULL,
+ parent integer NOT NULL,
name varchar(100) NOT NULL
);
);
--
--- Table: treelike
+-- Table: twokeys
--
-CREATE TABLE treelike (
+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: onekey
+--
+CREATE TABLE onekey (
id INTEGER PRIMARY KEY NOT NULL,
- parent integer NOT NULL,
+ artist integer NOT NULL,
+ cd integer NOT NULL
+);
+
+--
+-- Table: producer
+--
+CREATE TABLE producer (
+ producerid INTEGER PRIMARY KEY NOT NULL,
name varchar(100) NOT NULL
);
'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 => 96;
+ my $schema = shift;
+
+ foreach my $class ( 'Positioned', 'PositionedAdjacencyList', 'AdjacencyList' ) {
+
+ my $employees = $schema->resultset('Employee::'.$class);
+
+ if ($employees->result_class->can('position_column')) {
+
+ $employees->delete();
+ foreach (1..5) {
+ $employees->create({ name=>'temp' });
+ }
+
+ $employees = $employees->search(undef,{order_by=>'position'});
+ ok( check_positions($employees), "$class: intial positions" );
+
+ my $employee;
+
+ foreach my $position (1..$employees->count()) {
+
+ $employee = $employees->find({ position=>$position });
+ $employee->move_previous();
+ ok( check_positions($employees), "$class: move_previous( $position )" );
+
+ $employee = $employees->find({ position=>$position });
+ $employee->move_next();
+ ok( check_positions($employees), "$class: move_next( $position )" );
+
+ $employee = $employees->find({ position=>$position });
+ $employee->move_first();
+ ok( check_positions($employees), "$class: move_first( $position )" );
+
+ $employee = $employees->find({ position=>$position });
+ $employee->move_last();
+ ok( check_positions($employees), "$class: move_last( $position )" );
+
+ foreach my $to_position (1..$employees->count()) {
+ $employee = $employees->find({ position=>$position });
+ $employee->move_to($to_position);
+ ok( check_positions($employees), "$class: move_to( $position => $to_position )" );
+ }
+
+ }
+ }
+ if ($employees->result_class->can('parent_column')) {
+
+ $employees->delete();
+ my $mom = $employees->create({ name=>'temp' });
+ foreach (1..14) {
+ $employees->create({ name=>'temp', parent_id=>$mom->id() });
+ }
+
+ my $children = $mom->children();
+ ok( ($children->count()==14), 'correct number of children' );
+
+ my $grandma = $mom;
+ my @children = $children->all();
+ $mom = pop(@children);
+ foreach my $child (@children) {
+ $child->parent( $mom );
+ }
+
+ ok( ($mom->children->count() == 13), 'correct number of grandchildren' );
+
+ if ($employees->result_class->can('position_column')) {
+ # TODO: Test positioning within a tree.
+ }
+ }
+ }
+
+}
+
+sub check_positions {
+ my( $employees ) = @_;
+ $employees->reset();
+ my $expected_position = 0;
+ my $is_ok = 1;
+ while (my $employee = $employees->next()) {
+ $expected_position ++;
+ if ($employee->position()!=$expected_position) {
+ $is_ok = 0;
+ last;
+ }
+ }
+ return $is_ok;
+}
+
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff