-# vim: ts=8:sw=4:sts=4:et
package DBIx::Class::Tree::AdjacencyList;
+# vim: ts=8:sw=4:sts=4:et
+
use strict;
use warnings;
+
use base qw( DBIx::Class );
use Carp qw( croak );
=head1 NAME
-DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model. (EXPERIMENTAL)
+DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model.
=head1 SYNOPSIS
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
);
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 Positional ... ));
-Specify the column that contains the parent ID each row.
+Specify the column that contains the parent ID of each row.
package My::Employee;
__PACKAGE__->parent_column('parent_id');
+Optionally, automatically maintane a consistent tree structure.
+
+ __PACKAGE__->repair_tree( 1 );
+
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' });
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.
+with a parent ID of 0 is the root node and is usually the parent of all
+other rows. Although, there is no limitation in this module that would
+stop you from having multiple root nodes.
=head1 METHODS
__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.
+
+This method also setups an additional has_many relationship called
+parents which is useful when you want to treat an adjacency list
+as a DAG.
+
+=cut
+
+__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->has_many( 'parents' => $class => { "foreign.$primary_col" => "self.$parent_col" }, { cascade_delete => 0 } );
+ $class->_parent_column( $parent_col );
+ return 1;
+ }
+ return $class->_parent_column();
+}
+
+=head2 repair_tree
+
+ __PACKAGE__->repair_tree( 1 );
+
+When set a true value this flag causes all changes to a node's parent to
+trigger an integrity check on the tree. If, when changing a node's parent
+to one of it's descendents then all its children will first be moved to have
+the same current parent, and then the node's parent is changed.
+
+So, for example, if the tree is like this:
-If you are useing the L<DBIx::Class::Positional> component then this
-parent_column will automatically be used as the collection_column.
+ A
+ B
+ C
+ D
+ E
+ F
+
+And you execute:
+
+ $b->parent( $d );
+
+Since D is a descendant of B then all of B's siblings get their parent
+changed to A. Then B's parent is set to D.
+
+ A
+ C
+ D
+ B
+ E
+ F
=cut
-__PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' );
+__PACKAGE__->mk_classdata( 'repair_tree' => 0 );
=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. If you would like
+to make the object the root node, just set the parent to 0.
-If you are using the L<DBIx::Class::Positional> 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.
+If you are setting the parent then 0 will be returned if the
+specified parent is already the object's parent and 1 on
+success.
=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->move_last() if ($self->positional());
- $self->set_column( $parent_column => $new_parent );
- if ($self->positional()) {
- $self->set_column(
- $self->position_column() => $self->search( {$self->_collection_clause()} )->count() + 1
- );
+ return 0 if ($new_parent == ($self->get_column($parent_col)||0));
+
+ if ($self->repair_tree()) {
+ my $found = $self->has_descendant( $new_parent );
+ if ($found) {
+ my $children = $self->children();
+
+ while (my $child = $children->next()) {
+ $child->parent( $self->$parent_col() );
+ }
+ }
}
+
+ $self->set_column( $parent_col => $new_parent );
$self->update();
return 1;
}
- else {
- return $self->find( $self->get_column( $parent_column ) );
+ return $self->_parent();
+}
+
+=head2 has_descendant
+
+ if ($employee->has_descendant( $id )) { ... }
+
+Returns true if the object has a descendant with the
+specified ID.
+
+=cut
+
+sub has_descendant {
+ my ($self, $find_id) = @_;
+
+ my $children = $self->children();
+ while (my $child = $children->next()) {
+ if ($child->id() eq $find_id) {
+ return 1;
+ }
+ return 1 if ($child->has_descendant( $find_id ));
}
+
+ return 0;
}
+=head2 parents
+
+ my $parents = $node->parents();
+ my @parents = $node->parents();
+
+This has_many relationship is not that useful as it will
+never return more than one parent due to the one-to-many
+structure of adjacency lists. The reason this relationship
+is defined is so that this tree type may be treated as if
+it was a DAG.
+
=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.
+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
+
+ $parent->attach_child( $child );
+ $parent->attach_child( $child, $child, ... );
-If you are using the L<DBIx::Class::Positional> component then this method
-will return the children sorted by the position column.
+Sets the child, or children, to the new parent. Returns 1
+on success and returns 0 if the parent object already has
+the child.
=cut
-sub children {
- my( $self ) = @_;
- my $rs = $self->search(
- { $self->parent_column()=>$self->id() },
- ( $self->isa('DBIx::Class::Position') ? {order_by=>$self->position_column()} : () )
- );
- return $rs->all() if (wantarray());
- return $rs;
+sub attach_child {
+ my $self = shift;
+ my $return = 1;
+ foreach my $child (@_) {
+ $child->parent( $self );
+ }
+ return $return;
}
-=head2 attach_child
+=head2 siblings
- $parent->attach_child( $child );
+ my $rs = $node->siblings();
+ my @siblings = $node->siblings();
-Sets (or moves) the child to the new parent.
+Returns either a result set or an array of all other objects
+with the same parent as the calling object.
=cut
-sub attach_child {
- my( $self, $child ) = @_;
- $child->parent( $self );
+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;
}
=head2 attach_sibling
- $this->attach_sibling( $that );
+ $obj->attach_sibling( $sibling );
+ $obj->attach_sibling( $sibling, $sibling, ... );
-Sets the passed in object to have the same parent
-as the calling object.
+Sets the passed in object(s) to have the same parent
+as the calling object. Returns 1 on success and
+0 if the sibling already has the same parent.
=cut
sub attach_sibling {
- my( $self, $child ) = @_;
- $child->parent( $self->parent() );
+ my $self = shift;
+ my $return = 1;
+ foreach my $node (@_) {
+ $return = 0 if (!$node->parent( $self->parent() ));
+ }
+ return $return;
}
-=head1 POSITIONAL METHODS
+=head2 is_leaf
-If you are useing the L<DBIx::Class::Postional> component
-in conjunction with this module then you will also have
-these methods available to you.
+ if ($obj->is_leaf()) { ... }
-=head2 append_child
+Returns 1 if the object has no children, and 0 otherwise.
- $parent->append_child( $child );
+=cut
-Sets the child to have the specified parent and moves the
-child to the last position.
+sub is_leaf {
+ my( $self ) = @_;
-=cut
+ my $has_child = $self->result_source->resultset->search(
+ { $self->_parent_column => $self->id() },
+ { limit => 1 }
+ )->count();
-sub append_child {
- my( $self, $child ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $child->parent( $self );
+ return $has_child ? 0 : 1;
}
-=head2 prepend_child
+=head2 is_root
- $parent->prepend_child( $child );
+ if ($obj->is_root()) { ... }
-Sets the child to have the specified parent and moves the
-child to the first position.
+Returns 1 if the object has no parent, and 0 otherwise.
=cut
-sub prepend_child {
- my( $self, $child ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $child->parent( $self );
- $child->move_first();
+sub is_root {
+ my( $self ) = @_;
+ return ( $self->get_column( $self->_parent_column ) ? 0 : 1 );
}
-=head2 attach_before
+=head2 is_branch
- $this->attach_before( $that );
+ if ($obj->is_branch()) { ... }
-Attaches the object at the position just before the
-calling object's position.
+Returns 1 if the object has a parent and has children.
+Returns 0 otherwise.
=cut
-sub attach_before {
- my( $self, $sibling ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $sibling->parent( $self->parent() );
- $sibling->move_to( $self->get_column($self->position_column()) );
+sub is_branch {
+ my( $self ) = @_;
+ return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 );
}
-=head2 attach_after
-
- $this->attach_after( $that );
+=head2 set_primary_key
-Attaches the object at the position just after the
-calling object's position.
+This method is an override of DBIx::Class' method for setting the
+class' primary key column(s). This method passes control right on
+to the normal method after first validating that only one column is
+being selected as a primary key. If more than one column is then
+an error will be thrown.
=cut
-sub attach_after {
- my( $self, $sibling ) = @_;
- croak('This method may only be used with the Positional component') if (!$self->positional());
- $sibling->parent( $self->parent() );
- $sibling->move_to( $self->get_column($self->position_column()) + 1 );
+sub set_primary_key {
+ my $self = shift;
+ if (@_>1) {
+ croak('You may only specify a single column as the primary key for adjacency tree classes');
+ }
+ return $self->next::method( @_ );
}
-=head2 positional
+1;
+__END__
- if ($object->positional()) { ... }
+=head1 INHERITED METHODS
-Returns true if the object is a DBIx::Class::Positional
-object.
+=head2 DBIx::Class
-=cut
+=over 4
-sub positional {
- my( $self ) = @_;
- return $self->isa('DBIx::Class::Positional');
-}
+=item *
-=head1 PRIVATE METHODS
+L<mk_classdata|DBIx::Class/mk_classdata>
-These methods are used internally. You should never have the
-need to use them.
+=item *
-=head2 _collection_clause
+L<component_base_class|DBIx::Class/component_base_class>
-This method is provided as an override of the method in
-L<DBIx::Class::Positional>. This way Positional and Tree::AdjacencyList
-may be used together without conflict. Make sure that in
-your component list that you load Tree::AdjacencyList before you
-load Positional.
+=back
-=cut
+=head2 DBIx::Class::Componentised
-sub _collection_clause {
- my( $self ) = @_;
- return (
- $self->parent_column() =>
- $self->get_column($self->parent_column())
- );
-}
+=over 4
-1;
-__END__
+=item *
+
+L<inject_base|DBIx::Class::Componentised/inject_base>
+
+=item *
+
+L<load_components|DBIx::Class::Componentised/load_components>
+
+=item *
+
+L<load_own_components|DBIx::Class::Componentised/load_own_components>
+
+=back
+
+=head2 Class::Data::Accessor
+
+=over 4
+
+=item *
+
+L<mk_classaccessor|Class::Data::Accessor/mk_classaccessor>
+
+=back
=head1 AUTHOR
projects / dbsrgits/DBIx-Class-Tree.git / blobdiff