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 row and is usually the parent of all
  53 other rows.
  54
  55 =head1 METHODS
  56
  57 =head2 parent_column
  58
  59   __PACKAGE__->parent_column('parent_id');
  60
  61 Declares the name of the column that contains the self-referential
  62 ID which defines the parent row.  Defaults to "parent_id".  This
  63 will create a has_many (children) and belongs_to (parent)
  64 relationship.
  65
  66 =cut
  67
  68 __PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );
  69
  70 sub parent_column {
  71     my $class = shift;
  72     if (@_) {
  73         my $parent_col = shift;
  74         my $primary_col = ($class->primary_columns())[0];
  75         $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
  76         $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } );
  77         $class->_parent_column( $parent_col );
  78         return 1;
  79     }
  80     return $class->_parent_column();
  81 }
  82
  83 =head2 parent
  84
  85   my $parent = $employee->parent();
  86   $employee->parent( $parent_obj );
  87   $employee->parent( $parent_id );
  88
  89 Retrieves the object's parent object, or changes the object's
  90 parent to the specified parent or parent ID.
  91
  92 =cut
  93
  94 sub parent {
  95     my $self = shift;
  96     if (@_) {
  97         my $new_parent = shift;
  98         my $parent_col = $self->_parent_column();
  99         if (ref($new_parent)) {
 100             $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
 101         }
 102         return 0 if ($new_parent == ($self->get_column($parent_col)||0));
 103         $self->set_column( $parent_col => $new_parent );
 104         $self->update();
 105         return 1;
 106     }
 107     return $self->_parent();
 108 }
 109
 110 =head2 children
 111
 112   my $children_rs = $employee->children();
 113   my @children = $employee->children();
 114
 115 Returns a list or record set, depending on context, of all
 116 the objects one level below the current one.  This method
 117 is created when parent_column() is called, which sets up a
 118 has_many relationship called children.
 119
 120 =head2 attach_child
 121
 122   $parent->attach_child( $child );
 123
 124 Sets the child to the new parent.
 125
 126 =cut
 127
 128 sub attach_child {
 129     my( $self, $child ) = @_;
 130     return $child->parent( $self );
 131 }
 132
 133 =head2 siblings
 134
 135   my $rs = $node->siblings();
 136   my @siblings = $node->siblings();
 137
 138 Returns either a result set or an array of all other objects
 139 with the same parent as the calling object.
 140
 141 =cut
 142
 143 sub siblings {
 144     my( $self ) = @_;
 145     my $parent_col = $self->_parent_column;
 146     my $primary_col = ($self->primary_columns())[0];
 147     my $rs = $self->result_source->resultset->search(
 148         {
 149             $parent_col => $self->get_column($parent_col),
 150             $primary_col => { '!=' => $self->get_column($primary_col) },
 151         },
 152     );
 153     return $rs->all() if (wantarray());
 154     return $rs;
 155 }
 156
 157 =cut
 158
 159 =head2 attach_sibling
 160
 161   $this->attach_sibling( $that );
 162
 163 Sets the passed in object to have the same parent
 164 as the calling object.
 165
 166 =cut
 167
 168 sub attach_sibling {
 169     my( $self, $node ) = @_;
 170     return $node->parent( $self->parent() );
 171 }
 172
 173 1;
 174 __END__
 175
 176 =head1 AUTHOR
 177
 178 Aran Clary Deltac <bluefeet@cpan.org>
 179
 180 =head1 LICENSE
 181
 182 You may distribute this code under the same terms as Perl itself.
 183