1 package DBIx::Class::Tree::AdjacencyList;
2 # vim: ts=8:sw=4:sts=4:et
7 use base qw( DBIx::Class );
12 DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model.
16 Create a table for your tree data.
18 CREATE TABLE employees (
19 employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
20 parent_id INTEGER NOT NULL DEFAULT 0,
24 In your Schema or DB class add Tree::AdjacencyList to the top
25 of the component list.
27 __PACKAGE__->load_components(qw( Tree::AdjacencyList ... ));
29 Specify the column that contains the parent ID of each row.
32 __PACKAGE__->parent_column('parent_id');
34 Optionally, automatically maintane a consistent tree structure.
36 __PACKAGE__->repair_tree( 1 );
38 Thats it, now you can modify and analyze the tree.
43 my $employee = My::Employee->create({ name=>'Matt S. Trout' });
45 my $rs = $employee->children();
46 my @siblings = $employee->children();
48 my $parent = $employee->parent();
49 $employee->parent( 7 );
53 This module provides methods for working with adjacency lists. The
54 adjacency list model is a very common way of representing a tree structure.
55 In this model each row in a table has a prent ID column that references the
56 primary key of another row in the same table. Because of this the primary
57 key must only be one column and is usually some sort of integer. The row
58 with a parent ID of 0 is the root node and is usually the parent of all
59 other rows. Although, there is no limitation in this module that would
60 stop you from having multiple root nodes.
66 __PACKAGE__->parent_column('parent_id');
68 Declares the name of the column that contains the self-referential
69 ID which defines the parent row. This will create a has_many (children)
70 and belongs_to (parent) relationship.
72 This method also sets up an additional has_many relationship called
73 parents which is useful when you want to treat an adjacency list
78 __PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );
83 my $parent_col = shift;
84 my $primary_col = ($class->primary_columns())[0];
85 $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
86 $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } );
87 $class->has_many( 'parents' => $class => { "foreign.$primary_col" => "self.$parent_col" }, { cascade_delete => 0, cascade_copy => 0 } );
88 $class->_parent_column( $parent_col );
91 return $class->_parent_column();
96 __PACKAGE__->repair_tree( 1 );
98 When set a true value this flag causes all changes to a node's parent to
99 trigger an integrity check on the tree. If, when changing a node's parent
100 to one of it's descendents then all its children will first be moved to have
101 the same current parent, and then the node's parent is changed.
103 So, for example, if the tree is like this:
116 Since D is a descendant of B then all of D's siblings get their parent
117 changed to A. Then B's parent is set to D.
128 __PACKAGE__->mk_classdata( 'repair_tree' => 0 );
132 my $parent = $employee->parent();
133 $employee->parent( $parent_obj );
134 $employee->parent( $parent_id );
136 Retrieves the object's parent object, or changes the object's
137 parent to the specified parent or parent ID. If you would like
138 to make the object the root node, just set the parent to 0.
140 If you are setting the parent then 0 will be returned if the
141 specified parent is already the object's parent and 1 on
149 my $new_parent = shift;
150 my $parent_col = $self->_parent_column();
151 if (ref($new_parent)) {
152 $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
154 return 0 if ($new_parent == ($self->get_column($parent_col)||0));
156 if ($self->repair_tree()) {
157 my $found = $self->has_descendant( $new_parent );
159 my $children = $self->children();
161 while (my $child = $children->next()) {
162 $child->parent( $self->$parent_col() );
167 $self->set_column( $parent_col => $new_parent );
171 return $self->_parent();
175 @list = $employee->ancestors();
177 Returns a list of ancestors starting with a record's
178 parent and moving toward the tree root.
186 while ($rec = $rec->parent) {
187 push(@ancestors, $rec);
193 =head2 has_descendant
195 if ($employee->has_descendant( $id )) { ... }
197 Returns true if the object has a descendant with the
203 my ($self, $find_id) = @_;
205 my $children = $self->children();
206 while (my $child = $children->next()) {
207 if ($child->id() eq $find_id) {
210 return 1 if ($child->has_descendant( $find_id ));
218 my $parents = $node->parents();
219 my @parents = $node->parents();
221 This has_many relationship is not that useful as it will
222 never return more than one parent due to the one-to-many
223 structure of adjacency lists. The reason this relationship
224 is defined is so that this tree type may be treated as if
229 my $children_rs = $employee->children();
230 my @children = $employee->children();
232 Returns a list or record set, depending on context, of all
233 the objects one level below the current one. This method
234 is created when parent_column() is called, which sets up a
235 has_many relationship called children.
239 $parent->attach_child( $child );
240 $parent->attach_child( $child, $child, ... );
242 Sets the child, or children, to the new parent. Returns 1
243 on success and returns 0 if the parent object already has
251 foreach my $child (@_) {
252 $child->parent( $self );
259 my $rs = $node->siblings();
260 my @siblings = $node->siblings();
262 Returns either a result set or an array of all other objects
263 with the same parent as the calling object.
269 my $parent_col = $self->_parent_column;
270 my $primary_col = ($self->primary_columns())[0];
271 my $rs = $self->result_source->resultset->search(
273 $parent_col => $self->get_column($parent_col),
274 $primary_col => { '!=' => $self->get_column($primary_col) },
277 return $rs->all() if (wantarray());
281 =head2 attach_sibling
283 $obj->attach_sibling( $sibling );
284 $obj->attach_sibling( $sibling, $sibling, ... );
286 Sets the passed in object(s) to have the same parent
287 as the calling object. Returns 1 on success and
288 0 if the sibling already has the same parent.
295 foreach my $node (@_) {
296 $return = 0 if (!$node->parent( $self->parent() ));
303 if ($obj->is_leaf()) { ... }
305 Returns 1 if the object has no children, and 0 otherwise.
312 my $has_child = $self->result_source->resultset->search(
313 { $self->_parent_column => $self->id() },
317 return $has_child ? 0 : 1;
322 if ($obj->is_root()) { ... }
324 Returns 1 if the object has no parent, and 0 otherwise.
330 return ( $self->get_column( $self->_parent_column ) ? 0 : 1 );
335 if ($obj->is_branch()) { ... }
337 Returns 1 if the object has a parent and has children.
344 return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 );
347 =head2 set_primary_key
349 This method is an override of DBIx::Class' method for setting the
350 class' primary key column(s). This method passes control right on
351 to the normal method after first validating that only one column is
352 being selected as a primary key. If more than one column is then
353 an error will be thrown.
357 sub set_primary_key {
360 croak('You may only specify a single column as the primary key for adjacency tree classes');
362 return $self->next::method( @_ );
368 =head1 INHERITED METHODS
376 L<mk_classdata|DBIx::Class/mk_classdata>
380 L<component_base_class|DBIx::Class/component_base_class>
384 =head2 DBIx::Class::Componentised
390 L<inject_base|DBIx::Class::Componentised/inject_base>
394 L<load_components|DBIx::Class::Componentised/load_components>
398 L<load_own_components|DBIx::Class::Componentised/load_own_components>
402 =head2 Class::Data::Accessor
408 L<mk_classaccessor|Class::Data::Accessor/mk_classaccessor>
414 Aran Clary Deltac <bluefeet@cpan.org>
418 You may distribute this code under the same terms as Perl itself.