From: Peter Rabbitson Date: Sun, 25 Apr 2010 10:21:00 +0000 (+0000) Subject: Update to current cpan version X-Git-Tag: 0.03001~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Tree.git;a=commitdiff_plain;h=98277fa537fe2441d8f3439d48861387d4acfc12 Update to current cpan version --- diff --git a/Changes b/Changes index c5539c1..6f5944a 100644 --- 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. diff --git a/Makefile.PL b/Makefile.PL index 192903a..263bfc1 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -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 --- 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 diff --git a/lib/DBIx/Class/Tree.pm b/lib/DBIx/Class/Tree.pm index 3e8f690..a887a10 100644 --- a/lib/DBIx/Class/Tree.pm +++ b/lib/DBIx/Class/Tree.pm @@ -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__ diff --git a/lib/DBIx/Class/Tree/AdjacencyList.pm b/lib/DBIx/Class/Tree/AdjacencyList.pm index d2aedb8..05ed86d 100644 --- a/lib/DBIx/Class/Tree/AdjacencyList.pm +++ b/lib/DBIx/Class/Tree/AdjacencyList.pm @@ -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