From: Neil de Carteret <n3dst4@gmail.com>
Date: Sun, 10 Dec 2006 12:39:24 +0000 (+0000)
Subject: Improvements to AdjacentList.pm:
X-Git-Tag: 0.03001~10
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c0d76c37162678a26ce56f769aa98e3cf1ae11c1;p=dbsrgits%2FDBIx-Class-Tree.git

Improvements to AdjacentList.pm:
	Fixed a typo (ley for key)
	Changed "attach" to "add". May be controversial.
	Made the "parents" relationship *not* cascade deletes :-)
	Added a "descendents" method which just does a horrendous recursion to do
		what you think it does.
	Added four deletion strategies. Would like to improve this in future by
		e.g. overriding delete()

And tests for delete/descendents bits.
---

diff --git a/lib/DBIx/Class/Tree/AdjacencyList.pm b/lib/DBIx/Class/Tree/AdjacencyList.pm
index 58c0961..42fddf3 100644
--- a/lib/DBIx/Class/Tree/AdjacencyList.pm
+++ b/lib/DBIx/Class/Tree/AdjacencyList.pm
@@ -55,8 +55,12 @@ 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');
@@ -81,13 +85,15 @@ sub parent_column {
         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" } );
+        $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();
@@ -120,6 +126,34 @@ sub parent {
     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();
@@ -141,10 +175,10 @@ 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
+=head2 add_child
 
-  $parent->attach_child( $child );
-  $parent->attach_child( $child, $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 
@@ -152,7 +186,7 @@ the child.
 
 =cut
 
-sub attach_child {
+sub add_child {
     my $self = shift;
     my $return = 1;
     foreach my $child (@_) {
@@ -161,6 +195,21 @@ sub attach_child {
     return $return;
 }
 
+
+
+=head2 add_children
+
+An alias for add_child.
+
+=cut
+
+sub add_children {
+    my $self = shift;
+    return $self->add_child(@_);
+}
+
+
+
 =head2 siblings
 
   my $rs = $node->siblings();
@@ -185,12 +234,12 @@ sub siblings {
     return $rs;
 }
 
-=cut
 
-=head2 attach_sibling
 
-  $obj->attach_sibling( $sibling );
-  $obj->attach_sibling( $sibling, $sibling, ... );
+=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 
@@ -198,7 +247,7 @@ as the calling object.  Returns 1 on success and
 
 =cut
 
-sub attach_sibling {
+sub add_sibling {
     my $self = shift;
     my $return = 1;
     foreach my $node (@_) {
@@ -207,6 +256,8 @@ sub attach_sibling {
     return $return;
 }
 
+
+
 =head2 is_leaf
 
   if ($obj->is_leaf()) { ... }
@@ -223,6 +274,8 @@ sub is_leaf {
     )->count();
 }
 
+
+
 =head2 is_root
 
   if ($obj->is_root()) { ... }
@@ -236,6 +289,8 @@ sub is_root {
     return ( $self->get_column( $self->_parent_column ) ? 1 : 0 );
 }
 
+
+
 =head2 is_branch
 
   if ($obj->is_branch()) { ... }
@@ -247,9 +302,97 @@ Returns 0 otherwise.
 
 sub is_branch {
     my( $self ) = @_;
-    return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 );
+    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 
@@ -260,7 +403,7 @@ an error will be thrown.
 
 =cut
 
-sub set_primary_ley {
+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');
diff --git a/t/lib/TreeTest.pm b/t/lib/TreeTest.pm
index e77eea1..a3054cb 100644
--- a/t/lib/TreeTest.pm
+++ b/t/lib/TreeTest.pm
@@ -8,7 +8,7 @@ use TreeTest::Schema;
 our $NODE_COUNT = 80;
 
 sub count_tests {
-    my $count = 13;
+    my $count = 22;
     if( TreeTest::Schema::Node->can('position_column') ){
         $count ++;
     }
@@ -38,11 +38,11 @@ sub run_tests {
     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) );
+    $nodes->find(22)->add_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) );
+    $nodes->find(22)->add_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' );
 
@@ -52,6 +52,38 @@ sub run_tests {
     if( TreeTest::Schema::Node->can('position_column') ){
         ok( check_positions(scalar $root->children()), 'positions are correct' );
     }
+
+    #$nodes->delete;
+    $schema = TreeTest::Schema->connect();
+    $nodes = $schema->resultset('Node');
+    $root = $nodes->create({ name=>'root' });
+    @parents = (
+        1,1,3,2,3,3,6,6,2,5,3,5,12,1
+    );
+    foreach my $parent_id (@parents) {
+        my $node = $nodes->create({ name=>'child' });
+        $node->parent( $parent_id );
+    }
+
+    ok ($nodes->find(1)->descendents == 14, 'root node has 14 descendents');
+    ok ($nodes->find(2)->descendents == 4, 'node 2 has 4 descendents');
+    ok ($nodes->find(6)->descendents == 2, 'node 6 has 2 descendents');
+    ok ($nodes->find(10)->descendents == 0, 'node 10 has no descendents');
+    
+    $nodes->find(2)->pharaoh_delete;
+    ok ($nodes->find(1)->descendents == 9, 'root node has 9 descendents after pharaohing node 2');
+
+    ok ($nodes->find(3)->children == 4, 'node 3 has 4 children');
+    $nodes->find(6)->grandmother_delete;
+    ok ($nodes->find(3)->children == 5, 'node 3 has 5 children after node 6 dies');
+
+    $nodes->find(3)->replace_with_and_delete($nodes->find(12));
+    ok ($nodes->find(12)->children == 5, 'node 12 has 5 children after taking over from node 3');
+    ok ($nodes->find(7)->parent->id == 12, 'node 7\'s parent is node 12');
+    
+    
+    
+
 }
 
 sub check_positions {