[Bast-commits] r9210 - in DBIx-Class-Tree/trunk: . lib/DBIx/Class
lib/DBIx/Class/Tree
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Sun Apr 25 10:21:00 GMT 2010
Author: ribasushi
Date: 2010-04-25 11:21:00 +0100 (Sun, 25 Apr 2010)
New Revision: 9210
Modified:
DBIx-Class-Tree/trunk/Changes
DBIx-Class-Tree/trunk/Makefile.PL
DBIx-Class-Tree/trunk/TODO
DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree.pm
DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree/AdjacencyList.pm
Log:
Update to current cpan version
Modified: DBIx-Class-Tree/trunk/Changes
===================================================================
--- DBIx-Class-Tree/trunk/Changes 2010-04-25 10:12:57 UTC (rev 9209)
+++ DBIx-Class-Tree/trunk/Changes 2010-04-25 10:21:00 UTC (rev 9210)
@@ -1,12 +1,25 @@
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.
- Added a validation override for set_primary_key().
Modified: DBIx-Class-Tree/trunk/Makefile.PL
===================================================================
--- DBIx-Class-Tree/trunk/Makefile.PL 2010-04-25 10:12:57 UTC (rev 9209)
+++ DBIx-Class-Tree/trunk/Makefile.PL 2010-04-25 10:21:00 UTC (rev 9210)
@@ -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;
+
Modified: DBIx-Class-Tree/trunk/TODO
===================================================================
--- DBIx-Class-Tree/trunk/TODO 2010-04-25 10:12:57 UTC (rev 9209)
+++ DBIx-Class-Tree/trunk/TODO 2010-04-25 10:21:00 UTC (rev 9210)
@@ -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
Modified: DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree/AdjacencyList.pm
===================================================================
--- DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree/AdjacencyList.pm 2010-04-25 10:12:57 UTC (rev 9209)
+++ DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree/AdjacencyList.pm 2010-04-25 10:21:00 UTC (rev 9210)
@@ -31,6 +31,10 @@
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 @@
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,15 +85,49 @@
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
my $parent = $employee->parent();
@@ -119,6 +153,18 @@
$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,34 +172,29 @@
return $self->_parent();
}
+=head2 has_descendant
+ if ($employee->has_descendant( $id )) { ... }
-=head2 set_parent
+Returns true if the object has a descendant with the
+specified ID.
- $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');;
+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
my $parents = $node->parents();
@@ -175,10 +216,10 @@
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 @@
=cut
-sub add_child {
+sub attach_child {
my $self = shift;
my $return = 1;
foreach my $child (@_) {
@@ -195,21 +236,6 @@
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,20 +260,20 @@
return $rs;
}
+=cut
+=head2 attach_sibling
-=head2 add_sibling
+ $obj->attach_sibling( $sibling );
+ $obj->attach_sibling( $sibling, $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 {
+sub attach_sibling {
my $self = shift;
my $return = 1;
foreach my $node (@_) {
@@ -256,8 +282,6 @@
return $return;
}
-
-
=head2 is_leaf
if ($obj->is_leaf()) { ... }
@@ -268,14 +292,15 @@
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
if ($obj->is_root()) { ... }
@@ -286,11 +311,9 @@
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 @@
sub is_branch {
my( $self ) = @_;
- return !($self->is_leaf() or $self->is_root());
+ return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 );
}
-
-
-=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
Modified: DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree.pm
===================================================================
--- DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree.pm 2010-04-25 10:12:57 UTC (rev 9209)
+++ DBIx-Class-Tree/trunk/lib/DBIx/Class/Tree.pm 2010-04-25 10:21:00 UTC (rev 9210)
@@ -4,10 +4,9 @@
use strict;
use warnings;
-use vars qw( $VERSION );
use base qw( DBIx::Class );
-$VERSION = '0.01000';
+our $VERSION = '0.03000';
1;
__END__
More information about the Bast-commits
mailing list