X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FTree%2FAdjacencyList.pm;h=e14875fe3e53a3cca2e11ac000ca6a75184ccae1;hb=ab184e4a4303cde87f3f585ec422f99898a915b4;hp=d1ef803fa2903bed962091859652c98ebef05744;hpb=e338251bec21568f78a72f89ddb009a4edba8edb;p=dbsrgits%2FDBIx-Class-Tree.git

diff --git a/lib/DBIx/Class/Tree/AdjacencyList.pm b/lib/DBIx/Class/Tree/AdjacencyList.pm
index d1ef803..e14875f 100644
--- a/lib/DBIx/Class/Tree/AdjacencyList.pm
+++ b/lib/DBIx/Class/Tree/AdjacencyList.pm
@@ -1,13 +1,15 @@
-# 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 );
 
 =head1 NAME
 
-DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model. (EXPERIMENTAL)
+DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model.
 
 =head1 SYNOPSIS
 
@@ -15,11 +17,11 @@ Create a table for your tree data.
 
   CREATE TABLE employees (
     employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
-    parent_id INTEGER NOT NULL,
+    parent_id INTEGER NOT NULL DEFAULT 0,
     name TEXT NOT NULL
   );
 
-In your Schema or DB class add Tree::AdjacencyList to the top 
+In your Schema or DB class add Tree::AdjacencyList to the top
 of the component list.
 
   __PACKAGE__->load_components(qw( Tree::AdjacencyList ... ));
@@ -29,28 +31,33 @@ 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.
 
-  #!/use/bin/perl
+  #!/usr/bin/perl
   use My::Employee;
-  
+
   my $employee = My::Employee->create({ name=>'Matt S. Trout' });
-  
+
   my $rs = $employee->children();
   my @siblings = $employee->children();
-  
+
   my $parent = $employee->parent();
   $employee->parent( 7 );
 
 =head1 DESCRIPTION
 
-This module provides methods for working with adjacency lists.  The 
-adjacency list model is a very common way of representing a tree structure.  
-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.
+This module provides methods for working with adjacency lists.  The
+adjacency list model is a very common way of representing a tree structure.
+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 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
 
@@ -58,12 +65,67 @@ other rows.
 
   __PACKAGE__->parent_column('parent_id');
 
-Declares the name of the column that contains the self-referential 
-ID which defines the parent row.  Defaults to "parent_id".
+Declares the name of the column that contains the self-referential
+ID which defines the parent row.  This will create a has_many (children) 
+and belongs_to (parent) relationship.
+
+This method also sets up 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' );
+__PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );
+
+sub parent_column {
+    my $class = shift;
+    if (@_) {
+        my $parent_col = shift;
+        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, cascade_copy => 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 D'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
 
@@ -71,79 +133,279 @@ __PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' );
   $employee->parent( $parent_obj );
   $employee->parent( $parent_id );
 
-Retrieves the object's parent ID, or sets the object's 
-parent ID.  If setting the parent ID then 0 will be returned 
-if the object already has the specified parent, and 1 on 
+Retrieves the object's parent object, or changes the object's
+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
 
 sub parent {
-    my( $self, $new_parent ) = @_;
-    my $parent_column = $self->parent_column();
-    if ($new_parent) {
+    my $self = shift;
+    if (@_) {
+        my $new_parent = shift;
+        my $parent_col = $self->_parent_column();
         if (ref($new_parent)) {
-            $new_parent = $new_parent->id() || 0;
+            $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
         }
-        return 0 if ($new_parent == ($self->get_column($parent_column)||0));
-        $self->set_column( $parent_column => $new_parent );
+        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;
     }
-    else {
-        return $self->find( $self->get_column( $parent_column ) );
+    return $self->_parent();
+}
+=head2 ancestors
+
+  @list = $employee->ancestors();
+
+Returns a list of ancestors starting with a record's
+parent and moving toward the tree root.
+
+=cut
+
+sub ancestors {
+    my $self = shift;
+    my @ancestors = ();
+    my $rec = $self;
+    while ($rec = $rec->parent) {
+      push(@ancestors, $rec);
+    }
+    return @ancestors;
+}
+
+
+=head2 has_descendant
+
+  if ($employee->has_descendant( $id )) { ... }
+
+Returns true if the object has a descendant with the
+specified ID.
+
+=cut
+
+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 1 if ($child->has_descendant( $find_id ));
     }
+
+    return 0;
 }
 
+=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();
   my @children = $employee->children();
 
-Returns a list or record set, depending on context, of all 
-the objects one level below the current one.
+Returns a list or record set, depending on context, of all
+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
+
+  $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
+the child.
 
 =cut
 
-sub children {
+sub attach_child {
+    my $self = shift;
+    my $return = 1;
+    foreach my $child (@_) {
+        $child->parent( $self );
+    }
+    return $return;
+}
+
+=head2 siblings
+
+  my $rs = $node->siblings();
+  my @siblings = $node->siblings();
+
+Returns either a result set or an array of all other objects
+with the same parent as the calling object.
+
+=cut
+
+sub siblings {
     my( $self ) = @_;
+    my $parent_col = $self->_parent_column;
+    my $primary_col = ($self->primary_columns())[0];
     my $rs = $self->result_source->resultset->search(
-        { $self->parent_column()=>$self->id() }
+        {
+            $parent_col => $self->get_column($parent_col),
+            $primary_col => { '!=' => $self->get_column($primary_col) },
+        },
     );
     return $rs->all() if (wantarray());
     return $rs;
 }
 
-=head2 attach_child
+=head2 attach_sibling
 
-  $parent->attach_child( $child );
+  $obj->attach_sibling( $sibling );
+  $obj->attach_sibling( $sibling, $sibling, ... );
 
-Sets (or moves) the child to the new parent.
+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 attach_child {
-    my( $self, $child ) = @_;
-    $child->parent( $self );
+sub attach_sibling {
+    my $self = shift;
+    my $return = 1;
+    foreach my $node (@_) {
+        $return = 0 if (!$node->parent( $self->parent() ));
+    }
+    return $return;
 }
 
-=head2 attach_sibling
+=head2 is_leaf
 
-  $this->attach_sibling( $that );
+  if ($obj->is_leaf()) { ... }
 
-Sets the passed in object to have the same parent 
-as the calling object.
+Returns 1 if the object has no children, and 0 otherwise.
 
 =cut
 
-sub attach_sibling {
-    my( $self, $child ) = @_;
-    $child->parent( $self->parent() );
+sub is_leaf {
+    my( $self ) = @_;
+
+    my $has_child = $self->children_rs->count();
+
+    return $has_child ? 0 : 1;
+}
+
+=head2 is_root
+
+  if ($obj->is_root()) { ... }
+
+Returns 1 if the object has no parent, and 0 otherwise.
+
+=cut
+
+sub is_root {
+    my( $self ) = @_;
+    return ( $self->get_column( $self->_parent_column ) ? 0 : 1 );
+}
+
+=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()) ? 0 : 1 );
+}
+
+=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>