From: Aran Deltac Date: Fri, 24 Mar 2006 23:59:10 +0000 (+0000) Subject: First submit, with AdjacencyList and a pod test. X-Git-Tag: 0.03001~24 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Tree.git;a=commitdiff_plain;h=87427fdbbc45da39f7a19c58ff1aaf442dce68a2 First submit, with AdjacencyList and a pod test. --- diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..de8c300 --- /dev/null +++ b/Build.PL @@ -0,0 +1,19 @@ +use strict; +use Module::Build; + +my %arguments = ( + create_makefile_pl => 'passthrough', + license => 'perl', + module_name => 'DBIx::Class::Tree', + requires => { + 'DBIx::Class' => 0.07, + }, + build_requires => { + 'DBD::SQLite' => 1.11, + }, + create_readme => 1, + test_files => [ glob('t/*.t'), glob('t/*/*.t') ] +); + +Module::Build->new(%arguments)->create_build_script; + diff --git a/Changes b/Changes new file mode 100644 index 0000000..8909281 --- /dev/null +++ b/Changes @@ -0,0 +1,7 @@ + +Revision history for DBIx::Class::Tree + +0.01000 + - AdjacencyList module created. + - First version. + diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..51d31fd --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,31 @@ +# 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(); + my $makefile = File::Spec->rel2abs($0); + + CPAN::Shell->install('Module::Build::Compat') + or die " *** Cannot install without Module::Build. Exiting ...\n"; + + chdir $cwd or die "Cannot chdir() back to $cwd: $!"; + } + eval "use Module::Build::Compat 0.02; 1" or die $@; + use lib '_build/lib'; + Module::Build::Compat->run_build_pl(args => \@ARGV); + require Module::Build; + Module::Build::Compat->write_makefile(build_class => 'Module::Build'); diff --git a/lib/DBIx/Class/Tree/AdjacencyList.pm b/lib/DBIx/Class/Tree/AdjacencyList.pm new file mode 100644 index 0000000..93ccb16 --- /dev/null +++ b/lib/DBIx/Class/Tree/AdjacencyList.pm @@ -0,0 +1,282 @@ +# vim: ts=8:sw=4:sts=4:et +package DBIx::Class::Tree::AdjacencyList; +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) + +=head1 SYNOPSIS + +Create a table for your tree data. + + CREATE TABLE employees ( + employee_id INTEGER PRIMARY KEY AUTOINCREMENT, + parent_id INTEGER NOT NULL, + name TEXT NOT NULL + ); + +In your Schema or DB class add Tree::AdjacencyList to the top +of the component list. + + __PACKAGE__->load_components(qw( Tree::AdjacencyList ... )); + # If you want positionable data make sure this + # module comes first, as in: + __PACKAGE__->load_components(qw( Tree::AdjacencyList Positional ... )); + +Specify the column that contains the parent ID each row. + + package My::Employee; + __PACKAGE__->parent_column('parent_id'); + +Thats it, now you can modify and analyze the tree. + + #!/use/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. + +=head1 METHODS + +=head2 parent_column + + __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". + +If you are useing the L component then this +parent_column will automatically be used as the collection_column. + +=cut + +__PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' ); + +=head2 parent + + my $parent = $employee->parent(); + $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 +success. + +If you are using the L component this +module will first move the object to the last position of +the list, change the parent ID, then move the object to the +last position of the new list. This ensures the intergrity +of the positions. + +=cut + +sub parent { + my( $self, $new_parent ) = @_; + my $parent_column = $self->parent_column(); + if ($new_parent) { + if (ref($new_parent)) { + $new_parent = $new_parent->id() || 0; + } + return 0 if ($new_parent == ($self->get_column($parent_column)||0)); + $self->move_last() if ($self->positional()); + $self->set_column( $parent_column => $new_parent ); + if ($self->positional()) { + $self->set_column( + $self->position_column() => $self->search( {$self->_collection_clause()} )->count() + 1 + ); + } + $self->update(); + return 1; + } + else { + return $self->find( $self->get_column( $parent_column ) ); + } +} + +=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. + +If you are using the L component then this method +will return the children sorted by the position column. + +=cut + +sub children { + my( $self ) = @_; + my $rs = $self->search( + { $self->parent_column()=>$self->id() }, + ( $self->isa('DBIx::Class::Position') ? {order_by=>$self->position_column()} : () ) + ); + return $rs->all() if (wantarray()); + return $rs; +} + +=head2 attach_child + + $parent->attach_child( $child ); + +Sets (or moves) the child to the new parent. + +=cut + +sub attach_child { + my( $self, $child ) = @_; + $child->parent( $self ); +} + +=head2 attach_sibling + + $this->attach_sibling( $that ); + +Sets the passed in object to have the same parent +as the calling object. + +=cut + +sub attach_sibling { + my( $self, $child ) = @_; + $child->parent( $self->parent() ); +} + +=head1 POSITIONAL METHODS + +If you are useing the L component +in conjunction with this module then you will also have +these methods available to you. + +=head2 append_child + + $parent->append_child( $child ); + +Sets the child to have the specified parent and moves the +child to the last position. + +=cut + +sub append_child { + my( $self, $child ) = @_; + croak('This method may only be used with the Positional component') if (!$self->positional()); + $child->parent( $self ); +} + +=head2 prepend_child + + $parent->prepend_child( $child ); + +Sets the child to have the specified parent and moves the +child to the first position. + +=cut + +sub prepend_child { + my( $self, $child ) = @_; + croak('This method may only be used with the Positional component') if (!$self->positional()); + $child->parent( $self ); + $child->move_first(); +} + +=head2 attach_before + + $this->attach_before( $that ); + +Attaches the object at the position just before the +calling object's position. + +=cut + +sub attach_before { + my( $self, $sibling ) = @_; + croak('This method may only be used with the Positional component') if (!$self->positional()); + $sibling->parent( $self->parent() ); + $sibling->move_to( $self->get_column($self->position_column()) ); +} + +=head2 attach_after + + $this->attach_after( $that ); + +Attaches the object at the position just after the +calling object's position. + +=cut + +sub attach_after { + my( $self, $sibling ) = @_; + croak('This method may only be used with the Positional component') if (!$self->positional()); + $sibling->parent( $self->parent() ); + $sibling->move_to( $self->get_column($self->position_column()) + 1 ); +} + +=head2 positional + + if ($object->positional()) { ... } + +Returns true if the object is a DBIx::Class::Positional +object. + +=cut + +sub positional { + my( $self ) = @_; + return $self->isa('DBIx::Class::Positional'); +} + +=head1 PRIVATE METHODS + +These methods are used internally. You should never have the +need to use them. + +=head2 _collection_clause + +This method is provided as an override of the method in +L. This way Positional and Tree::AdjacencyList +may be used together without conflict. Make sure that in +your component list that you load Tree::AdjacencyList before you +load Positional. + +=cut + +sub _collection_clause { + my( $self ) = @_; + return ( + $self->parent_column() => + $self->get_column($self->parent_column()) + ); +} + +1; +__END__ + +=head1 AUTHOR + +Aran Clary Deltac + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + diff --git a/t/01pod.t b/t/01pod.t new file mode 100644 index 0000000..1647794 --- /dev/null +++ b/t/01pod.t @@ -0,0 +1,7 @@ +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => 'Test::Pod 1.14 required' if $@; +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; + +all_pod_files_ok();