lib/DBIx/Class/Tree/AdjacencyList.pm

   1 package DBIx::Class::Tree::AdjacencyList;
   2 # vim: ts=8:sw=4:sts=4:et
   3
   4 use strict;
   5 use warnings;
   6
   7 use base qw( DBIx::Class );
   8 use Carp qw( croak );
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model. (EXPERIMENTAL)
  13
  14 =head1 SYNOPSIS
  15
  16 Create a table for your tree data.
  17
  18   CREATE TABLE employees (
  19     employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
  20     parent_id INTEGER NOT NULL DEFAULT 0,
  21     name TEXT NOT NULL
  22   );
  23
  24 In your Schema or DB class add Tree::AdjacencyList to the top
  25 of the component list.
  26
  27   __PACKAGE__->load_components(qw( Tree::AdjacencyList ... ));
  28
  29 Specify the column that contains the parent ID of each row.
  30
  31   package My::Employee;
  32   __PACKAGE__->parent_column('parent_id');
  33
  34 Thats it, now you can modify and analyze the tree.
  35
  36   #!/usr/bin/perl
  37   use My::Employee;
  38
  39   my $employee = My::Employee->create({ name=>'Matt S. Trout' });
  40
  41   my $rs = $employee->children();
  42   my @siblings = $employee->children();
  43
  44   my $parent = $employee->parent();
  45   $employee->parent( 7 );
  46
  47 =head1 DESCRIPTION
  48
  49 This module provides methods for working with adjacency lists.  The
  50 adjacency list model is a very common way of representing a tree structure.
  51 In this model each row in a table has a prent ID column that references the
  52 primary key of another row in the same table.  Because of this the primary
  53 key must only be one column and is usually some sort of integer.  The row
  54 with a parent ID of 0 is the root node and is usually the parent of all
  55 other rows.  Although, there is no limitation in this module that would
  56 stop you from having multiple root nodes.
  57
  58 =head1 METHODS
  59
  60 =head2 parent_column
  61
  62   __PACKAGE__->parent_column('parent_id');
  63
  64 Declares the name of the column that contains the self-referential
  65 ID which defines the parent row.  Defaults to "parent_id".  This
  66 will create a has_many (children) and belongs_to (parent)
  67 relationship.
  68
  69 This method also setups an additional has_many relationship called
  70 parents which is useful when you want to treat an adjacency list
  71 as a DAG.
  72
  73 =cut
  74
  75 __PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );
  76
  77 sub parent_column {
  78     my $class = shift;
  79     if (@_) {
  80         my $parent_col = shift;
  81         my $primary_col = ($class->primary_columns())[0];
  82         $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
  83         $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } );
  84         $class->has_many( 'parents' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
  85         $class->_parent_column( $parent_col );
  86         return 1;
  87     }
  88     return $class->_parent_column();
  89 }
  90
  91 =head2 parent
  92
  93   my $parent = $employee->parent();
  94   $employee->parent( $parent_obj );
  95   $employee->parent( $parent_id );
  96
  97 Retrieves the object's parent object, or changes the object's
  98 parent to the specified parent or parent ID.  If you would like
  99 to make the object the root node, just set the parent to 0.
 100
 101 If you are setting the parent then 0 will be returned if the
 102 specified parent is already the object's parent and 1 on
 103 success.
 104
 105 =cut
 106
 107 sub parent {
 108     my $self = shift;
 109     if (@_) {
 110         my $new_parent = shift;
 111         my $parent_col = $self->_parent_column();
 112         if (ref($new_parent)) {
 113             $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
 114         }
 115         return 0 if ($new_parent == ($self->get_column($parent_col)||0));
 116         $self->set_column( $parent_col => $new_parent );
 117         $self->update();
 118         return 1;
 119     }
 120     return $self->_parent();
 121 }
 122
 123 =head2 parents
 124
 125   my $parents = $node->parents();
 126   my @parents = $node->parents();
 127
 128 This has_many relationship is not that useful as it will
 129 never return more than one parent due to the one-to-many
 130 structure of adjacency lists.  The reason this relationship
 131 is defined is so that this tree type may be treated as if
 132 it was a DAG.
 133
 134 =head2 children
 135
 136   my $children_rs = $employee->children();
 137   my @children = $employee->children();
 138
 139 Returns a list or record set, depending on context, of all
 140 the objects one level below the current one.  This method
 141 is created when parent_column() is called, which sets up a
 142 has_many relationship called children.
 143
 144 =head2 attach_child
 145
 146   $parent->attach_child( $child );
 147   $parent->attach_child( $child, $child, ... );
 148
 149 Sets the child, or children, to the new parent.  Returns 1
 150 on success and returns 0 if the parent object already has
 151 the child.
 152
 153 =cut
 154
 155 sub attach_child {
 156     my $self = shift;
 157     my $return = 1;
 158     foreach my $child (@_) {
 159         $child->parent( $self );
 160     }
 161     return $return;
 162 }
 163
 164 =head2 siblings
 165
 166   my $rs = $node->siblings();
 167   my @siblings = $node->siblings();
 168
 169 Returns either a result set or an array of all other objects
 170 with the same parent as the calling object.
 171
 172 =cut
 173
 174 sub siblings {
 175     my( $self ) = @_;
 176     my $parent_col = $self->_parent_column;
 177     my $primary_col = ($self->primary_columns())[0];
 178     my $rs = $self->result_source->resultset->search(
 179         {
 180             $parent_col => $self->get_column($parent_col),
 181             $primary_col => { '!=' => $self->get_column($primary_col) },
 182         },
 183     );
 184     return $rs->all() if (wantarray());
 185     return $rs;
 186 }
 187
 188 =cut
 189
 190 =head2 attach_sibling
 191
 192   $obj->attach_sibling( $sibling );
 193   $obj->attach_sibling( $sibling, $sibling, ... );
 194
 195 Sets the passed in object(s) to have the same parent
 196 as the calling object.  Returns 1 on success and
 197 0 if the sibling already has the same parent.
 198
 199 =cut
 200
 201 sub attach_sibling {
 202     my $self = shift;
 203     my $return = 1;
 204     foreach my $node (@_) {
 205         $return = 0 if (!$node->parent( $self->parent() ));
 206     }
 207     return $return;
 208 }
 209
 210 =head2 is_leaf
 211
 212   if ($obj->is_leaf()) { ... }
 213
 214 Returns 1 if the object has no children, and 0 otherwise.
 215
 216 =cut
 217
 218 sub is_leaf {
 219     my( $self ) = @_;
 220     return $self->result_source->resultset->search(
 221         { $self->_parent_column => $self->id() },
 222         { limit => 1 }
 223     )->count();
 224 }
 225
 226 =head2 is_root
 227
 228   if ($obj->is_root()) { ... }
 229
 230 Returns 1 if the object has no parent, and 0 otherwise.
 231
 232 =cut
 233
 234 sub is_root {
 235     my( $self ) = @_;
 236     return ( $self->get_column( $self->_parent_column ) ? 1 : 0 );
 237 }
 238
 239 =head2 is_branch
 240
 241   if ($obj->is_branch()) { ... }
 242
 243 Returns 1 if the object has a parent and has children.
 244 Returns 0 otherwise.
 245
 246 =cut
 247
 248 sub is_branch {
 249     my( $self ) = @_;
 250     return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 );
 251 }
 252
 253 =head2 set_primary_key
 254
 255 This method is an override of DBIx::Class' method for setting the
 256 class' primary key column(s).  This method passes control right on
 257 to the normal method after first validating that only one column is
 258 being selected as a primary key.  If more than one column is then
 259 an error will be thrown.
 260
 261 =cut
 262
 263 sub set_primary_ley {
 264     my $self = shift;
 265     if (@_>1) {
 266         croak('You may only specify a single column as the primary key for adjacency tree classes');
 267     }
 268     return $self->next::method( @_ );
 269 }
 270
 271 1;
 272 __END__
 273
 274 =head1 INHERITED METHODS
 275
 276 =head2 DBIx::Class
 277
 278 =over 4
 279
 280 =item *
 281
 282 L<mk_classdata|DBIx::Class/mk_classdata>
 283
 284 =item *
 285
 286 L<component_base_class|DBIx::Class/component_base_class>
 287
 288 =back
 289
 290 =head2 DBIx::Class::Componentised
 291
 292 =over 4
 293
 294 =item *
 295
 296 L<inject_base|DBIx::Class::Componentised/inject_base>
 297
 298 =item *
 299
 300 L<load_components|DBIx::Class::Componentised/load_components>
 301
 302 =item *
 303
 304 L<load_own_components|DBIx::Class::Componentised/load_own_components>
 305
 306 =back
 307
 308 =head2 Class::Data::Accessor
 309
 310 =over 4
 311
 312 =item *
 313
 314 L<mk_classaccessor|Class::Data::Accessor/mk_classaccessor>
 315
 316 =back
 317
 318 =head1 AUTHOR
 319
 320 Aran Clary Deltac <bluefeet@cpan.org>
 321
 322 =head1 LICENSE
 323
 324 You may distribute this code under the same terms as Perl itself.
 325