-# 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 );
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
+
+
=head2 parent_column
__PACKAGE__->parent_column('parent_id');
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' );
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 parent
my $parent = $employee->parent();
$employee->parent( $parent_id );
Retrieves the object's parent object, or changes the object's
-parent to the specified parent or parent ID.
+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 setting the parent then 0 will be returned if the
+specified parent is already the object's parent and 1 on
+success.
=cut
return $self->_parent();
}
+
+
+=head2 set_parent
+
+ $employee->set_parent($boss_obj);
+ $employee->set_parent($boss_id);
+
+A syntactic alternative to ->parent() for setting only.
+
+=cut
+
+sub set_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');;
+ }
+ return 0 if ($new_parent == ($self->get_column($parent_col)||0));
+ $self->set_column( $parent_col => $new_parent );
+ $self->update();
+ return 1;
+ }
+}
+
+
+
+=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();
is created when parent_column() is called, which sets up a
has_many relationship called children.
-=head2 attach_child
+=head2 add_child
+
+ $parent->add_child( $child );
+ $parent->add_child( $child, $child, ... );
+
+Sets the child, or children, to the new parent. Returns 1
+on success and returns 0 if the parent object already has
+the child.
- $parent->attach_child( $child );
+=cut
+
+sub add_child {
+ my $self = shift;
+ my $return = 1;
+ foreach my $child (@_) {
+ $child->parent( $self );
+ }
+ return $return;
+}
-Sets the child to the new parent.
+
+
+=head2 add_children
+
+An alias for add_child.
=cut
-sub attach_child {
- my( $self, $child ) = @_;
- return $child->parent( $self );
+sub add_children {
+ my $self = shift;
+ return $self->add_child(@_);
}
+
+
=head2 siblings
my $rs = $node->siblings();
return $rs;
}
+
+
+=head2 add_sibling
+
+ $obj->add_sibling( $sibling );
+ $obj->add_sibling( $sibling, $sibling, ... );
+
+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 add_sibling {
+ my $self = shift;
+ my $return = 1;
+ foreach my $node (@_) {
+ $return = 0 if (!$node->parent( $self->parent() ));
+ }
+ return $return;
+}
+
+
+
+=head2 is_leaf
+
+ if ($obj->is_leaf()) { ... }
+
+Returns 1 if the object has no children, and 0 otherwise.
+
=cut
-=head2 attach_sibling
+sub is_leaf {
+ my( $self ) = @_;
+ return $self->result_source->resultset->search(
+ { $self->_parent_column => $self->id() },
+ { limit => 1 }
+ )->count();
+}
+
- $this->attach_sibling( $that );
-Sets the passed in object to have the same parent
-as the calling object.
+=head2 is_root
+
+ if ($obj->is_root()) { ... }
+
+Returns 1 if the object has no parent, and 0 otherwise.
=cut
-sub attach_sibling {
- my( $self, $node ) = @_;
- return $node->parent( $self->parent() );
+sub is_root {
+ my( $self ) = @_;
+ return ( $self->get_column( $self->_parent_column ) ? 1 : 0 );
+}
+
+
+
+=head2 is_branch
+
+ if ($obj->is_branch()) { ... }
+
+Returns 1 if the object has a parent and has children.
+Returns 0 otherwise.
+
+=cut
+
+sub is_branch {
+ my( $self ) = @_;
+ return !($self->is_leaf() or $self->is_root());
+}
+
+
+
+=head2 descendents
+
+Returns a flat list of *all* the node's descendents.
+Dangerously recursive. Use with extreme caution. May contain
+nuts.
+
+=cut
+
+sub descendents {
+ my $self = shift;
+ my @descendents;
+ for my $child ($self->children) {
+ push @descendents, $child, $child->descendents;
+ }
+ return @descendents;
+}
+
+
+
+=head2 pharaoh_delete
+
+Deletes a node and all it's children (even if cascade_delete is off)
+
+=cut
+
+sub pharaoh_delete {
+ my $self = shift;
+ for my $child ($self->children) {
+ $child->pharaoh_delete;
+ }
+ $self->delete;
+}
+
+
+
+=head2 grandmother_delete
+
+Deletes a node and sends all its children to live with their grandmother
+
+=cut
+
+sub grandmother_delete {
+ my $self = shift;
+ $self->parent->add_children($self->children);
+ $self->delete;
+}
+
+
+
+=head2 promote_eldest_child_delete
+
+Deletes a node and promotes the first of it children to take its place.
+If that node already had children, they will now be siblings of the new
+parent node's former siblings (which are now its children).
+
+=cut
+
+sub promote_eldest_child_delete {
+ my $self = shift;
+ my @children = $self->children;
+ my $eldest = shift @children;
+ $eldest->set_parent($self->parent);
+ $eldest->add_children(@children);
+ $self->delete;
+}
+
+
+
+=head2
+
+Replaces the current node with the given replacement, and then deletes the
+current node. The replacement node with have the old node's parent, and its
+children will be the union of its original children and the old node's
+children.
+
+=cut
+
+sub replace_with_and_delete {
+ my ($self, $replacement) = @_;
+ $replacement->add_children($self->children);
+ $replacement->set_parent($self->parent);
+ $self->delete;
+}
+
+
+
+=head2 set_primary_key
+
+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 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( @_ );
}
1;
__END__
+=head1 INHERITED METHODS
+
+=head2 DBIx::Class
+
+=over 4
+
+=item *
+
+L<mk_classdata|DBIx::Class/mk_classdata>
+
+=item *
+
+L<component_base_class|DBIx::Class/component_base_class>
+
+=back
+
+=head2 DBIx::Class::Componentised
+
+=over 4
+
+=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
Aran Clary Deltac <bluefeet@cpan.org>
projects / dbsrgits/DBIx-Class-Tree.git / blobdiff