From: Aran Deltac Date: Fri, 31 Mar 2006 19:21:38 +0000 (+0000) Subject: Tests for adjacency list as well as a bunch of fixes. X-Git-Tag: 0.03001~18 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8295812709d2b2fdc8dba6d448d5fa58011c4166;p=dbsrgits%2FDBIx-Class-Tree.git Tests for adjacency list as well as a bunch of fixes. --- diff --git a/lib/DBIx/Class/Tree.pm b/lib/DBIx/Class/Tree.pm index d392843..34f91cc 100644 --- a/lib/DBIx/Class/Tree.pm +++ b/lib/DBIx/Class/Tree.pm @@ -10,3 +10,21 @@ use base qw( DBIx::Class ); $VERSION = '0.01000'; 1; +__END__ + +=head1 NAME + +DBIx::Class::Tree - Manipulate and anaylze tree structured data. (EXPERIMENTAL) + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 AUTHOR + +Aran Clary Deltac + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + diff --git a/lib/DBIx/Class/Tree/AdjacencyList.pm b/lib/DBIx/Class/Tree/AdjacencyList.pm index af8c26e..99f32ad 100644 --- a/lib/DBIx/Class/Tree/AdjacencyList.pm +++ b/lib/DBIx/Class/Tree/AdjacencyList.pm @@ -15,7 +15,7 @@ Create a table for your tree data. CREATE TABLE employees ( employee_id INTEGER PRIMARY KEY AUTOINCREMENT, - parent_id INTEGER NOT NULL, + parent_id INTEGER NOT NULL DEFAULT 0, name TEXT NOT NULL ); @@ -31,7 +31,7 @@ Specify the column that contains the parent ID of each row. Thats it, now you can modify and analyze the tree. - #!/use/bin/perl + #!/usr/bin/perl use My::Employee; my $employee = My::Employee->create({ name=>'Matt S. Trout' }); @@ -59,11 +59,26 @@ other rows. __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". +ID which defines the parent row. Defaults to "parent_id". This +will create a has_many (children) and belongs_to (parent) +relationship. =cut -__PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' ); +__PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' ); + +sub parent_column { + my $class = shift; + if (@_) { + my $parent_col = shift; + my $primary_col = ($class->primary_columns())[0]; + $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } ); + $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } ); + $class->_parent_column( $parent_col ); + return 1; + } + return $class->_parent_column(); +} =head2 parent @@ -71,28 +86,25 @@ __PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' ); $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. +Retrieves the object's parent object, or changes the object's +parent to the specified parent or parent ID. =cut sub parent { - my( $self, $new_parent ) = @_; - my $parent_column = $self->parent_column(); - if ($new_parent) { + my $self = shift; + if (@_) { + my $new_parent = shift; + my $parent_col = $self->_parent_column(); if (ref($new_parent)) { - $new_parent = $new_parent->id() || 0; + $new_parent = $new_parent->id() || croak('Parent object does not have an ID');; } - return 0 if ($new_parent == ($self->get_column($parent_column)||0)); - $self->set_column( $parent_column => $new_parent ); + return 0 if ($new_parent == ($self->get_column($parent_col)||0)); + $self->set_column( $parent_col => $new_parent ); $self->update(); return 1; } - else { - return $self->result_source->resultset->find( $self->get_column( $parent_column ) ); - } + return $self->_parent(); } =head2 children @@ -101,18 +113,9 @@ sub parent { my @children = $employee->children(); Returns a list or record set, depending on context, of all -the objects one level below the current one. - -=cut - -sub children { - my( $self ) = @_; - my $rs = $self->result_source->resultset->search( - { $self->parent_column()=>$self->id() } - ); - return $rs->all() if (wantarray()); - return $rs; -} +the objects one level below the current one. This method +is created when parent_column() is called, which sets up a +has_many relationship called children. =head2 attach_child @@ -124,9 +127,35 @@ Sets the child to the new parent. sub attach_child { my( $self, $child ) = @_; - $child->parent( $self ); + return $child->parent( $self ); } +=head2 siblings + + my $rs = $node->siblings(); + my @siblings = $node->siblings(); + +Returns either a result set or an array of all other objects +with the same parent as the calling object. + +=cut + +sub siblings { + my( $self ) = @_; + my $parent_col = $self->_parent_column; + my $primary_col = ($self->primary_columns())[0]; + my $rs = $self->result_source->resultset->search( + { + $parent_col => $self->get_column($parent_col), + $primary_col => { '!=' => $self->get_column($primary_col) }, + }, + ); + return $rs->all() if (wantarray()); + return $rs; +} + +=cut + =head2 attach_sibling $this->attach_sibling( $that ); @@ -137,8 +166,8 @@ as the calling object. =cut sub attach_sibling { - my( $self, $child ) = @_; - $child->parent( $self->parent() ); + my( $self, $node ) = @_; + return $node->parent( $self->parent() ); } 1; diff --git a/lib/DBIx/Class/Tree/AdjacencyList/Positional.pm b/lib/DBIx/Class/Tree/AdjacencyList/Positional.pm index ebe0f85..7112ad2 100644 --- a/lib/DBIx/Class/Tree/AdjacencyList/Positional.pm +++ b/lib/DBIx/Class/Tree/AdjacencyList/Positional.pm @@ -20,7 +20,7 @@ Create a table for your tree data. CREATE TABLE employees ( employee_id INTEGER PRIMARY KEY AUTOINCREMENT, - parent_id INTEGER NOT NULL, + parent_id INTEGER NOT NULL DEFAULT 0, position INTEGER NOT NULL, name TEXT NOT NULL ); @@ -34,15 +34,15 @@ Specify the column that contains the parent ID and position of each row. package My::Employee; __PACKAGE__->parent_column('parent_id'); - __PACAKGE__->position_column('position'); + __PACKAGE__->position_column('position'); This module provides a few extra methods beyond what L and L already provide. my $parent = $employee->parent(); - $employee->parent( $parent_obj ); - $employee->parent( $parent_id ); + $employee->set_parent( $parent_obj ); + $employee->set_parent( $parent_id ); my $children_rs = $employee->children(); my @children = $employee->children(); @@ -62,32 +62,53 @@ If you =head1 METHODS +=head2 parent_column + + __PACKAGE__->parent_column('parent_id'); + +Works the same as AdjacencyList's parent_column() method, but it +declares the children() has many relationship to be ordered by the +position column. + +=cut + +sub parent_column { + my $class = shift; + if (@_) { + my $parent_col = shift; + my $primary_col = ($class->primary_columns())[0]; + $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } ); + $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" }, { order_by=>$self->position_column() } ); + $class->_parent_column( $parent_col ); + return 1; + } + return $class->_parent_column(); +} + =head2 parent my $parent = $employee->parent(); $employee->parent( $parent_obj ); $employee->parent( $parent_id ); - - my $children_rs = $employee->children(); - my @children = $employee->children(); -This method works exactly like it does in the -DBIx::Class::Tree::AdjacencyList module except that it 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. +This method overrides AdjacencyList's parent() method but +modifies it so that the object is moved to the last position, +then the parent is changed, and then it is moved to the last +position of the new list. =cut sub parent { - my( $self, $new_parent ) = @_; - if ($new_parent) { + my $self = shift; + if (@_) { + my $new_parent = shift; + my $parent_col = $self->_parent_column(); if (ref($new_parent)) { - $new_parent = $new_parent->id() || croak('Parent object does not have an id'); + $new_parent = $new_parent->id() || croak('Parent object does not have an ID');; } - return 0 if ($new_parent == ($self->get_column($self->parent_column())||0)); - $self->move_last(); - return 0 if (!$self->next::method( $new_parent )); + return 0 if ($new_parent == ($self->get_column($parent_col)||0)); + $self->move_last; + $self->set_column( $parent_col => $new_parent ); $self->set_column( $self->position_column() => $self->result_source->resultset->search( @@ -97,9 +118,7 @@ sub parent { $self->update(); return 1; } - else { - return $self->next::method(); - } + return $self->_parent(); } =head2 children @@ -111,18 +130,6 @@ This method works just like it does in the DBIx::Class::Tree::AdjacencyList module except it orders the children by there position. -=cut - -sub children { - my( $self ) = @_; - my $rs = $self->result_source->resultset->search( - { $self->parent_column() => $self->id() }, - { order_by => $self->position_column() } - ); - return $rs->all() if (wantarray()); - return $rs; -} - =head2 append_child $parent->append_child( $child ); @@ -210,8 +217,8 @@ glue between AdjacencyList and Positional. sub _collection_clause { my( $self ) = @_; return ( - $self->parent_column() => - $self->get_column($self->parent_column()) + $self->_parent_column() => + $self->get_column($self->_parent_column()) ); } diff --git a/t/10_adjacencylist.t b/t/10_adjacencylist.t new file mode 100644 index 0000000..42b80cf --- /dev/null +++ b/t/10_adjacencylist.t @@ -0,0 +1,19 @@ +# vim: filetype=perl:ts=8:sw=4:sts=4:et +use strict; +use warnings; +use lib 't/lib'; + +use Test::More; +use TreeTest; + +TreeTest::Schema::Node->load_components(qw( + Tree::AdjacencyList +)); + +TreeTest::Schema::Node->parent_column( 'parent_id' ); + +my $tests = TreeTest::count_tests(); +plan tests => $tests; +TreeTest::run_tests(); + +1; diff --git a/t/lib/TreeTest.pm b/t/lib/TreeTest.pm new file mode 100644 index 0000000..95a0dec --- /dev/null +++ b/t/lib/TreeTest.pm @@ -0,0 +1,46 @@ +package TreeTest; +use strict; +use warnings; + +use Test::More; +use TreeTest::Schema; + +our $NODE_COUNT = 80; + +sub count_tests { + return 11; +} + +sub run_tests { + my $schema = TreeTest::Schema->connect(); + my $nodes = $schema->resultset('Node'); + my $root = $nodes->create({ name=>'root' }); + my @parents = ( + 1,1,3,4,4,3,3,8,8,10,10,8,8,3,3,16,3,3,1,20,1,22,22,24,24,22,27,27,29,29,27,32,32,34,34,36,34,38,38,40,40,42,42,44,44,46,44,44,49,44,51,51,53,51,55,55,57,57,55,60,55,62,55,64,64,55,67,67,55,70,70,55,55,51,51,76,76,78,78,76 + ); + + foreach my $parent_id (@parents) { + my $node = $nodes->create({ name=>'child' }); + $node->parent( $parent_id ); + } + ok( ($nodes->count()==81), 'correct number of nodes in random tree' ); + ok( ($nodes->find(3)->children->count()==7), 'node 3 has correct number of children' ); + ok( ($nodes->find(22)->children->count()==3), 'node 22 has correct number of children' ); + + my $child = ($nodes->find(22)->children->all())[0]; + $child->parent( $nodes->find(3) ); + ok( ($nodes->find(3)->children->count()==8), 'node 3 has correct number of children' ); + ok( ($nodes->find(3)->siblings->count()==3), 'node 3 has correct number of siblings' ); + ok( ($nodes->find(22)->children->count()==2), 'node 22 has correct number of children' ); + ok( ($nodes->find(22)->siblings->count()==3), 'node 22 has correct number of siblings' ); + + $nodes->find(22)->attach_child( $nodes->find(3) ); + ok( ($nodes->find(22)->children->count()==3), 'node 22 has correct number of children' ); + ok( ($nodes->find(22)->siblings->count()==2), 'node 22 has correct number of siblings' ); + + $nodes->find(22)->attach_sibling( $nodes->find(3) ); + ok( ($nodes->find(22)->children->count()==2), 'node 22 has correct number of children' ); + ok( ($nodes->find(22)->siblings->count()==3), 'node 22 has correct number of siblings' ); +} + +1; diff --git a/t/lib/TreeTest/Schema.pm b/t/lib/TreeTest/Schema.pm new file mode 100644 index 0000000..9167026 --- /dev/null +++ b/t/lib/TreeTest/Schema.pm @@ -0,0 +1,35 @@ +package TreeTest::Schema; +use strict; +use warnings; + +use base qw( DBIx::Class::Schema ); + +__PACKAGE__->load_classes(); + +sub connect { + my $self = shift; + + my $db_file = 't/var/test.db'; + + unlink($db_file) if -e $db_file; + unlink($db_file . '-journal') if -e $db_file . '-journal'; + mkdir("t/var") unless -d "t/var"; + + my $dsn = "dbi:SQLite:$db_file"; + my $schema = $self->next::method( $dsn ); + + $schema->storage->on_connect_do([ "PRAGMA synchronous = OFF" ]); + + my $dbh = $schema->storage->dbh; + open SQL, "t/lib/sqlite.sql"; + my $sql; + { local $/ = undef; $sql = ; } + close SQL; + $dbh->do($_) for split(/\n\n/, $sql); + + $schema->storage->dbh->do("PRAGMA synchronous = OFF"); + + return $schema; +} + +1; diff --git a/t/lib/TreeTest/Schema/Node.pm b/t/lib/TreeTest/Schema/Node.pm new file mode 100644 index 0000000..9c36d9e --- /dev/null +++ b/t/lib/TreeTest/Schema/Node.pm @@ -0,0 +1,27 @@ +package TreeTest::Schema::Node; +use strict; +use warnings; + +use Carp qw( croak ); + +use base qw( DBIx::Class ); + +__PACKAGE__->load_components(qw( + PK::Auto + Core +)); + +__PACKAGE__->table('nodes'); + +__PACKAGE__->add_columns(qw( + node_id + name + parent_id + position + lft + rgt +)); + +__PACKAGE__->set_primary_key( 'node_id' ); + +1; diff --git a/t/lib/sqlite.sql b/t/lib/sqlite.sql new file mode 100644 index 0000000..b66dac1 --- /dev/null +++ b/t/lib/sqlite.sql @@ -0,0 +1,10 @@ + +CREATE TABLE nodes ( + node_id INTEGER PRIMARY KEY AUTOINCREMENT, + name STRING, + parent_id INTEGER, + position INTEGER, + lft INTEGER, + rgt INTEGER +); +