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. (EXPERIMENTAL)
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 Thats it, now you can modify and analyze the tree.
39 my $employee = My::Employee->create({ name=>'Matt S. Trout' });
41 my $rs = $employee->children();
42 my @siblings = $employee->children();
44 my $parent = $employee->parent();
45 $employee->parent( 7 );
49 This module provides methods for working with adjacency lists. The
50 adjacency list model is a very common way of representing a tree structure.
51 In this model each row in a table has a prent ID column that references the
52 primary key of another row in the same table. Because of this the primary
53 key must only be one column and is usually some sort of integer. The row
54 with a parent ID of 0 is the root node and is usually the parent of all
55 other rows. Although, there is no limitation in this module that would
56 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. Defaults to "parent_id". This
70 will create a has_many (children) and belongs_to (parent)
73 This method also setups an additional has_many relationship called
74 parents which is useful when you want to treat an adjacency list
79 __PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );
84 my $parent_col = shift;
85 my $primary_col = ($class->primary_columns())[0];
86 $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
87 $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } );
88 $class->has_many( 'parents' => $class => { "foreign.$primary_col" => "self.$parent_col" }, {cascade_delete=>0} );
89 $class->_parent_column( $parent_col );
92 return $class->_parent_column();
99 my $parent = $employee->parent();
100 $employee->parent( $parent_obj );
101 $employee->parent( $parent_id );
103 Retrieves the object's parent object, or changes the object's
104 parent to the specified parent or parent ID. If you would like
105 to make the object the root node, just set the parent to 0.
107 If you are setting the parent then 0 will be returned if the
108 specified parent is already the object's parent and 1 on
116 my $new_parent = shift;
117 my $parent_col = $self->_parent_column();
118 if (ref($new_parent)) {
119 $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
121 return 0 if ($new_parent == ($self->get_column($parent_col)||0));
122 $self->set_column( $parent_col => $new_parent );
126 return $self->_parent();
133 $employee->set_parent($boss_obj);
134 $employee->set_parent($boss_id);
136 A syntactic alternative to ->parent() for setting only.
143 my $new_parent = shift;
144 my $parent_col = $self->_parent_column();
145 if (ref($new_parent)) {
146 $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
148 return 0 if ($new_parent == ($self->get_column($parent_col)||0));
149 $self->set_column( $parent_col => $new_parent );
159 my $parents = $node->parents();
160 my @parents = $node->parents();
162 This has_many relationship is not that useful as it will
163 never return more than one parent due to the one-to-many
164 structure of adjacency lists. The reason this relationship
165 is defined is so that this tree type may be treated as if
170 my $children_rs = $employee->children();
171 my @children = $employee->children();
173 Returns a list or record set, depending on context, of all
174 the objects one level below the current one. This method
175 is created when parent_column() is called, which sets up a
176 has_many relationship called children.
180 $parent->add_child( $child );
181 $parent->add_child( $child, $child, ... );
183 Sets the child, or children, to the new parent. Returns 1
184 on success and returns 0 if the parent object already has
192 foreach my $child (@_) {
193 $child->parent( $self );
202 An alias for add_child.
208 return $self->add_child(@_);
215 my $rs = $node->siblings();
216 my @siblings = $node->siblings();
218 Returns either a result set or an array of all other objects
219 with the same parent as the calling object.
225 my $parent_col = $self->_parent_column;
226 my $primary_col = ($self->primary_columns())[0];
227 my $rs = $self->result_source->resultset->search(
229 $parent_col => $self->get_column($parent_col),
230 $primary_col => { '!=' => $self->get_column($primary_col) },
233 return $rs->all() if (wantarray());
241 $obj->add_sibling( $sibling );
242 $obj->add_sibling( $sibling, $sibling, ... );
244 Sets the passed in object(s) to have the same parent
245 as the calling object. Returns 1 on success and
246 0 if the sibling already has the same parent.
253 foreach my $node (@_) {
254 $return = 0 if (!$node->parent( $self->parent() ));
263 if ($obj->is_leaf()) { ... }
265 Returns 1 if the object has no children, and 0 otherwise.
271 return $self->result_source->resultset->search(
272 { $self->_parent_column => $self->id() },
281 if ($obj->is_root()) { ... }
283 Returns 1 if the object has no parent, and 0 otherwise.
289 return ( $self->get_column( $self->_parent_column ) ? 1 : 0 );
296 if ($obj->is_branch()) { ... }
298 Returns 1 if the object has a parent and has children.
305 return !($self->is_leaf() or $self->is_root());
312 Returns a flat list of *all* the node's descendents.
313 Dangerously recursive. Use with extreme caution. May contain
321 for my $child ($self->children) {
322 push @descendents, $child, $child->descendents;
329 =head2 pharaoh_delete
331 Deletes a node and all it's children (even if cascade_delete is off)
337 for my $child ($self->children) {
338 $child->pharaoh_delete;
345 =head2 grandmother_delete
347 Deletes a node and sends all its children to live with their grandmother
351 sub grandmother_delete {
353 $self->parent->add_children($self->children);
359 =head2 promote_eldest_child_delete
361 Deletes a node and promotes the first of it children to take its place.
362 If that node already had children, they will now be siblings of the new
363 parent node's former siblings (which are now its children).
367 sub promote_eldest_child_delete {
369 my @children = $self->children;
370 my $eldest = shift @children;
371 $eldest->set_parent($self->parent);
372 $eldest->add_children(@children);
380 Replaces the current node with the given replacement, and then deletes the
381 current node. The replacement node with have the old node's parent, and its
382 children will be the union of its original children and the old node's
387 sub replace_with_and_delete {
388 my ($self, $replacement) = @_;
389 $replacement->add_children($self->children);
390 $replacement->set_parent($self->parent);
396 =head2 set_primary_key
398 This method is an override of DBIx::Class' method for setting the
399 class' primary key column(s). This method passes control right on
400 to the normal method after first validating that only one column is
401 being selected as a primary key. If more than one column is then
402 an error will be thrown.
406 sub set_primary_key {
409 croak('You may only specify a single column as the primary key for adjacency tree classes');
411 return $self->next::method( @_ );
417 =head1 INHERITED METHODS
425 L<mk_classdata|DBIx::Class/mk_classdata>
429 L<component_base_class|DBIx::Class/component_base_class>
433 =head2 DBIx::Class::Componentised
439 L<inject_base|DBIx::Class::Componentised/inject_base>
443 L<load_components|DBIx::Class::Componentised/load_components>
447 L<load_own_components|DBIx::Class::Componentised/load_own_components>
451 =head2 Class::Data::Accessor
457 L<mk_classaccessor|Class::Data::Accessor/mk_classaccessor>
463 Aran Clary Deltac <bluefeet@cpan.org>
467 You may distribute this code under the same terms as Perl itself.