Update to current cpan version
Peter Rabbitson [Sun, 25 Apr 2010 10:21:00 +0000 (10:21 +0000)]
Changes
Makefile.PL
TODO
lib/DBIx/Class/Tree.pm
lib/DBIx/Class/Tree/AdjacencyList.pm

diff --git a/Changes b/Changes
index c5539c1..6f5944a 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,11 +1,24 @@
 
 Revision history for DBIx::Class::Tree
 
-
+0.03000 2009-08-18
     - Removed EXPERIMENTAL flags, because after 2 years there'd be bugs
       if there were any serious problems. (Ian Wells)
     - Fix borked tests (DBIx-Class 0.081 got rid of the loophole they used)
       (ribasushi)
+    - Increase DBIC dependency to 0.08100. (bluefeet)
+
+0.02001 2007-12-16
+    - Remove invalid line.
+
+0.02000 2007-10-29
+    - Use Module::Install instead of Module::Build.
+    - Fixed is_leaf, is_branch, and is_root.
+    - Renamed set_primary_ley as set_primary_key.
+    - New has_descdendant() method.
+    - New repair_tree flag.
+    - parent() now repairs the tree if needed/allowed.
+    - Do not cascade delete via the parents() relationship.
 
 0.01000 2006-11-06
     - Added is_leaf, is_root, and is_branch to AdjacencyList.
index 192903a..263bfc1 100644 (file)
@@ -1,31 +1,13 @@
-# Note: this file was auto-generated by Module::Build::Compat version 0.03
-    
-    unless (eval "use Module::Build::Compat 0.02; 1" ) {
-      print "This module requires Module::Build to install itself.\n";
-      
-      require ExtUtils::MakeMaker;
-      my $yn = ExtUtils::MakeMaker::prompt
-       ('  Install Module::Build now from CPAN?', 'y');
-      
-      unless ($yn =~ /^y/i) {
-       die " *** Cannot install without Module::Build.  Exiting ...\n";
-      }
-      
-      require Cwd;
-      require File::Spec;
-      require CPAN;
-      
-      # Save this 'cause CPAN will chdir all over the place.
-      my $cwd = Cwd::cwd();
-      
-      CPAN::Shell->install('Module::Build::Compat');
-      CPAN::Shell->expand("Module", "Module::Build::Compat")->uptodate
-       or die "Couldn't install Module::Build, giving up.\n";
-      
-      chdir $cwd or die "Cannot chdir() back to $cwd: $!";
-    }
-    eval "use Module::Build::Compat 0.02; 1" or die $@;
-    
-    Module::Build::Compat->run_build_pl(args => \@ARGV);
-    require Module::Build;
-    Module::Build::Compat->write_makefile(build_class => 'Module::Build');
+use inc::Module::Install;
+
+name            'DBIx-Class-Tree';
+all_from        'lib/DBIx/Class/Tree.pm';
+readme_from        'lib/DBIx/Class/Tree.pm';
+githubmeta;
+
+requires        'Carp'        => 0;
+requires        'DBIx::Class' => '0.08100';
+build_requires  'DBD::SQLite' => '0.42';
+
+WriteAll;
+
diff --git a/TODO b/TODO
index 2213fe8..16d7a0d 100644 (file)
--- a/TODO
+++ b/TODO
@@ -9,4 +9,6 @@
  - Add an ancestors() and descendants() method with
    support for resultset cacheing.
  - Not all methods are covered by the tests.
+ - has_ancestor() method.
+ - DBIx::Class::Tree::NestedSet
 
index 3e8f690..a887a10 100644 (file)
@@ -4,10 +4,9 @@ package DBIx::Class::Tree;
 use strict;
 use warnings;
 
-use vars qw( $VERSION );
 use base qw( DBIx::Class );
 
-$VERSION = '0.01000';
+our $VERSION = '0.03000';
 
 1;
 __END__
index d2aedb8..05ed86d 100644 (file)
@@ -31,6 +31,10 @@ 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.
 
   #!/usr/bin/perl
@@ -55,12 +59,8 @@ 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');
@@ -85,14 +85,48 @@ 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" }, {cascade_delete=>0} );
+        $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:
+
+  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( 'repair_tree' => 0 );
 
 =head2 parent
 
@@ -119,6 +153,18 @@ sub 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));
+
+        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;
@@ -126,33 +172,28 @@ sub parent {
     return $self->_parent();
 }
 
+=head2 has_descendant
 
+  if ($employee->has_descendant( $id )) { ... }
 
-=head2 set_parent
-
-    $employee->set_parent($boss_obj);
-    $employee->set_parent($boss_id);
-
-A syntactic alternative to ->parent() for setting only.
+Returns true if the object has a descendant with the
+specified ID.
 
 =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');;
+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 0 if ($new_parent == ($self->get_column($parent_col)||0));
-        $self->set_column( $parent_col => $new_parent );
-        $self->update();
-        return 1;
+        return 1 if ($child->has_descendant( $find_id ));
     }
-}
-
 
+    return 0;
+}
 
 =head2 parents
 
@@ -175,10 +216,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 add_child
+=head2 attach_child
 
-  $parent->add_child( $child );
-  $parent->add_child( $child, $child, ... );
+  $parent->attach_child( $child );
+  $parent->attach_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 
@@ -186,7 +227,7 @@ the child.
 
 =cut
 
-sub add_child {
+sub attach_child {
     my $self = shift;
     my $return = 1;
     foreach my $child (@_) {
@@ -195,21 +236,6 @@ sub add_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();
@@ -234,12 +260,12 @@ sub siblings {
     return $rs;
 }
 
+=cut
 
+=head2 attach_sibling
 
-=head2 add_sibling
-
-  $obj->add_sibling( $sibling );
-  $obj->add_sibling( $sibling, $sibling, ... );
+  $obj->attach_sibling( $sibling );
+  $obj->attach_sibling( $sibling, $sibling, ... );
 
 Sets the passed in object(s) to have the same parent 
 as the calling object.  Returns 1 on success and 
@@ -247,7 +273,7 @@ as the calling object.  Returns 1 on success and
 
 =cut
 
-sub add_sibling {
+sub attach_sibling {
     my $self = shift;
     my $return = 1;
     foreach my $node (@_) {
@@ -256,8 +282,6 @@ sub add_sibling {
     return $return;
 }
 
-
-
 =head2 is_leaf
 
   if ($obj->is_leaf()) { ... }
@@ -268,13 +292,14 @@ Returns 1 if the object has no children, and 0 otherwise.
 
 sub is_leaf {
     my( $self ) = @_;
-    return $self->result_source->resultset->search(
+
+    my $has_child = $self->result_source->resultset->search(
         { $self->_parent_column => $self->id() },
         { limit => 1 }
     )->count();
-}
-
 
+    return $has_child ? 0 : 1;
+}
 
 =head2 is_root
 
@@ -286,11 +311,9 @@ Returns 1 if the object has no parent, and 0 otherwise.
 
 sub is_root {
     my( $self ) = @_;
-    return ( $self->get_column( $self->_parent_column ) ? 1 : 0 );
+    return ( $self->get_column( $self->_parent_column ) ? 0 : 1 );
 }
 
-
-
 =head2 is_branch
 
   if ($obj->is_branch()) { ... }
@@ -302,97 +325,9 @@ Returns 0 otherwise.
 
 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;
+    return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 );
 }
 
-
-
-=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