lib/DBIx/Class/Tree/AdjacencyList.pm

   1 # vim: ts=8:sw=4:sts=4:et
   2 package DBIx::Class::Tree::AdjacencyList;
   3 use strict;
   4 use warnings;
   5 use base qw( DBIx::Class );
   6 use Carp qw( croak );
   7
   8 =head1 NAME
   9
  10 DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model. (EXPERIMENTAL)
  11
  12 =head1 SYNOPSIS
  13
  14 Create a table for your tree data.
  15
  16   CREATE TABLE employees (
  17     employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
  18     parent_id INTEGER NOT NULL DEFAULT 0,
  19     name TEXT NOT NULL
  20   );
  21
  22 In your Schema or DB class add Tree::AdjacencyList to the top
  23 of the component list.
  24
  25   __PACKAGE__->load_components(qw( Tree::AdjacencyList ... ));
  26
  27 Specify the column that contains the parent ID of each row.
  28
  29   package My::Employee;
  30   __PACKAGE__->parent_column('parent_id');
  31
  32 Thats it, now you can modify and analyze the tree.
  33
  34   #!/usr/bin/perl
  35   use My::Employee;
  36
  37   my $employee = My::Employee->create({ name=>'Matt S. Trout' });
  38
  39   my $rs = $employee->children();
  40   my @siblings = $employee->children();
  41
  42   my $parent = $employee->parent();
  43   $employee->parent( 7 );
  44
  45 =head1 DESCRIPTION
  46
  47 This module provides methods for working with adjacency lists.  The
  48 adjacency list model is a very common way of representing a tree structure.
  49 In this model each row in a table has a prent ID column that references the
  50 primary key of another row in the same table.  Because of this the primary
  51 key must only be one column and is usually some sort of integer.  The row
  52 with a parent ID of 0 is the root node and is usually the parent of all
  53 other rows.  Although, there is no limitation in this module that would
  54 stop you from having multiple root nodes.
  55
  56 =head1 METHODS
  57
  58 =head2 parent_column
  59
  60   __PACKAGE__->parent_column('parent_id');
  61
  62 Declares the name of the column that contains the self-referential
  63 ID which defines the parent row.  Defaults to "parent_id".  This
  64 will create a has_many (children) and belongs_to (parent)
  65 relationship.
  66
  67 =cut
  68
  69 __PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );
  70
  71 sub parent_column {
  72     my $class = shift;
  73     if (@_) {
  74         my $parent_col = shift;
  75         my $primary_col = ($class->primary_columns())[0];
  76         $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
  77         $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } );
  78         $class->_parent_column( $parent_col );
  79         return 1;
  80     }
  81     return $class->_parent_column();
  82 }
  83
  84 =head2 parent
  85
  86   my $parent = $employee->parent();
  87   $employee->parent( $parent_obj );
  88   $employee->parent( $parent_id );
  89
  90 Retrieves the object's parent object, or changes the object's
  91 parent to the specified parent or parent ID.  If you would like
  92 to make the object the root node, just set the parent to 0.
  93
  94 If you are setting the parent then 0 will be returned if the
  95 specified parent is already the object's parent and 1 on
  96 success.
  97
  98 =cut
  99
 100 sub parent {
 101     my $self = shift;
 102     if (@_) {
 103         my $new_parent = shift;
 104         my $parent_col = $self->_parent_column();
 105         if (ref($new_parent)) {
 106             $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
 107         }
 108         return 0 if ($new_parent == ($self->get_column($parent_col)||0));
 109         $self->set_column( $parent_col => $new_parent );
 110         $self->update();
 111         return 1;
 112     }
 113     return $self->_parent();
 114 }
 115
 116 =head2 children
 117
 118   my $children_rs = $employee->children();
 119   my @children = $employee->children();
 120
 121 Returns a list or record set, depending on context, of all
 122 the objects one level below the current one.  This method
 123 is created when parent_column() is called, which sets up a
 124 has_many relationship called children.
 125
 126 =head2 attach_child
 127
 128   $parent->attach_child( $child );
 129   $parent->attach_child( $child, $child, ... );
 130
 131 Sets the child, or children, to the new parent.  Returns 1
 132 on success and returns 0 if the parent object already has
 133 the child.
 134
 135 =cut
 136
 137 sub attach_child {
 138     my $self = shift;
 139     my $return = 1;
 140     foreach my $child (@_) {
 141         $child->parent( $self );
 142     }
 143     return $return;
 144 }
 145
 146 =head2 siblings
 147
 148   my $rs = $node->siblings();
 149   my @siblings = $node->siblings();
 150
 151 Returns either a result set or an array of all other objects
 152 with the same parent as the calling object.
 153
 154 =cut
 155
 156 sub siblings {
 157     my( $self ) = @_;
 158     my $parent_col = $self->_parent_column;
 159     my $primary_col = ($self->primary_columns())[0];
 160     my $rs = $self->result_source->resultset->search(
 161         {
 162             $parent_col => $self->get_column($parent_col),
 163             $primary_col => { '!=' => $self->get_column($primary_col) },
 164         },
 165     );
 166     return $rs->all() if (wantarray());
 167     return $rs;
 168 }
 169
 170 =cut
 171
 172 =head2 attach_sibling
 173
 174   $obj->attach_sibling( $sibling );
 175   $obj->attach_sibling( $sibling, $sibling, ... );
 176
 177 Sets the passed in object(s) to have the same parent
 178 as the calling object.  Returns 1 on success and
 179 0 if the sibling already has the same parent.
 180
 181 =cut
 182
 183 sub attach_sibling {
 184     my $self = shift;
 185     my $return = 1;
 186     foreach my $node (@_) {
 187         $return = 0 if (!$node->parent( $self->parent() ));
 188     }
 189     return $return;
 190 }
 191
 192 1;
 193 __END__
 194
 195 =head1 AUTHOR
 196
 197 Aran Clary Deltac <bluefeet@cpan.org>
 198
 199 =head1 LICENSE
 200
 201 You may distribute this code under the same terms as Perl itself.
 202