$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 <bluefeet@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
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
);
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' });
__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
$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
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
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 );
=cut
sub attach_sibling {
- my( $self, $child ) = @_;
- $child->parent( $self->parent() );
+ my( $self, $node ) = @_;
+ return $node->parent( $self->parent() );
}
1;
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
);
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<DBIx::Class::Positional> and L<DBIx::Class::Tree::AdjacencyList>
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();
=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(
$self->update();
return 1;
}
- else {
- return $self->next::method();
- }
+ return $self->_parent();
}
=head2 children
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 );
sub _collection_clause {
my( $self ) = @_;
return (
- $self->parent_column() =>
- $self->get_column($self->parent_column())
+ $self->_parent_column() =>
+ $self->get_column($self->_parent_column())
);
}
--- /dev/null
+# 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;
--- /dev/null
+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;
--- /dev/null
+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 = <SQL>; }
+ close SQL;
+ $dbh->do($_) for split(/\n\n/, $sql);
+
+ $schema->storage->dbh->do("PRAGMA synchronous = OFF");
+
+ return $schema;
+}
+
+1;
--- /dev/null
+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;
--- /dev/null
+
+CREATE TABLE nodes (
+ node_id INTEGER PRIMARY KEY AUTOINCREMENT,
+ name STRING,
+ parent_id INTEGER,
+ position INTEGER,
+ lft INTEGER,
+ rgt INTEGER
+);
+
projects / dbsrgits/DBIx-Class-Tree.git / commitdiff