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.
  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 Optionally, automatically maintane a consistent tree structure.
  35
  36   __PACKAGE__->repair_tree( 1 );
  37
  38 Thats it, now you can modify and analyze the tree.
  39
  40   #!/usr/bin/perl
  41   use My::Employee;
  42
  43   my $employee = My::Employee->create({ name=>'Matt S. Trout' });
  44
  45   my $rs = $employee->children();
  46   my @siblings = $employee->children();
  47
  48   my $parent = $employee->parent();
  49   $employee->parent( 7 );
  50
  51 =head1 DESCRIPTION
  52
  53 This module provides methods for working with adjacency lists.  The
  54 adjacency list model is a very common way of representing a tree structure.
  55 In this model each row in a table has a prent ID column that references the
  56 primary key of another row in the same table.  Because of this the primary
  57 key must only be one column and is usually some sort of integer.  The row
  58 with a parent ID of 0 is the root node and is usually the parent of all
  59 other rows.  Although, there is no limitation in this module that would
  60 stop you from having multiple root nodes.
  61
  62 =head1 METHODS
  63
  64 =head2 parent_column
  65
  66   __PACKAGE__->parent_column('parent_id');
  67
  68 Declares the name of the column that contains the self-referential
  69 ID which defines the parent row.  Defaults to "parent_id".  This
  70 will create a has_many (children) and belongs_to (parent)
  71 relationship.
  72
  73 This method also setups an additional has_many relationship called
  74 parents which is useful when you want to treat an adjacency list
  75 as a DAG.
  76
  77 =cut
  78
  79 __PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );
  80
  81 sub parent_column {
  82     my $class = shift;
  83     if (@_) {
  84         my $parent_col = shift;
  85         my $primary_col = ($class->primary_columns())[0];
  86         $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
  87         $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } );
  88         $class->has_many( 'parents' => $class => { "foreign.$primary_col" => "self.$parent_col" }, { cascade_delete => 0, cascade_copy => 0 } );
  89         $class->_parent_column( $parent_col );
  90         return 1;
  91     }
  92     return $class->_parent_column();
  93 }
  94
  95 =head2 repair_tree
  96
  97   __PACKAGE__->repair_tree( 1 );
  98
  99 When set a true value this flag causes all changes to a node's parent to
 100 trigger an integrity check on the tree.  If, when changing a node's parent
 101 to one of it's descendents then all its children will first be moved to have
 102 the same current parent, and then the node's parent is changed.
 103
 104 So, for example, if the tree is like this:
 105
 106   A
 107     B
 108       C
 109       D
 110         E
 111     F
 112
 113 And you execute:
 114
 115   $b->parent( $d );
 116
 117 Since D is a descendant of B then all of B's siblings get their parent
 118 changed to A.  Then B's parent is set to D.
 119
 120   A
 121     C
 122     D
 123       B
 124       E
 125     F
 126
 127 =cut
 128
 129 __PACKAGE__->mk_classdata( 'repair_tree' => 0 );
 130
 131 =head2 parent
 132
 133   my $parent = $employee->parent();
 134   $employee->parent( $parent_obj );
 135   $employee->parent( $parent_id );
 136
 137 Retrieves the object's parent object, or changes the object's
 138 parent to the specified parent or parent ID.  If you would like
 139 to make the object the root node, just set the parent to 0.
 140
 141 If you are setting the parent then 0 will be returned if the
 142 specified parent is already the object's parent and 1 on
 143 success.
 144
 145 =cut
 146
 147 sub parent {
 148     my $self = shift;
 149     if (@_) {
 150         my $new_parent = shift;
 151         my $parent_col = $self->_parent_column();
 152         if (ref($new_parent)) {
 153             $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
 154         }
 155         return 0 if ($new_parent == ($self->get_column($parent_col)||0));
 156
 157         if ($self->repair_tree()) {
 158             my $found    = $self->has_descendant( $new_parent );
 159             if ($found) {
 160                 my $children = $self->children();
 161
 162                 while (my $child = $children->next()) {
 163                     $child->parent( $self->$parent_col() );
 164                 }
 165             }
 166         }
 167
 168         $self->set_column( $parent_col => $new_parent );
 169         $self->update();
 170         return 1;
 171     }
 172     return $self->_parent();
 173 }
 174 =head2 ancestors
 175
 176   @list = $employee->ancestors();
 177
 178 Returns a list of ancestors starting with a record's
 179 parent and moving toward the tree root.
 180
 181 =cut
 182
 183 sub ancestors {
 184     my $self = shift;
 185     my @ancestors = ();
 186     my $rec = $self;
 187     while ($rec = $rec->parent) {
 188       push(@ancestors, $rec);
 189     }
 190     return @ancestors;
 191 }
 192
 193
 194 =head2 has_descendant
 195
 196   if ($employee->has_descendant( $id )) { ... }
 197
 198 Returns true if the object has a descendant with the
 199 specified ID.
 200
 201 =cut
 202
 203 sub has_descendant {
 204     my ($self, $find_id) = @_;
 205
 206     my $children = $self->children();
 207     while (my $child = $children->next()) {
 208         if ($child->id() eq $find_id) {
 209             return 1;
 210         }
 211         return 1 if ($child->has_descendant( $find_id ));
 212     }
 213
 214     return 0;
 215 }
 216
 217 =head2 parents
 218
 219   my $parents = $node->parents();
 220   my @parents = $node->parents();
 221
 222 This has_many relationship is not that useful as it will
 223 never return more than one parent due to the one-to-many
 224 structure of adjacency lists.  The reason this relationship
 225 is defined is so that this tree type may be treated as if
 226 it was a DAG.
 227
 228 =head2 children
 229
 230   my $children_rs = $employee->children();
 231   my @children = $employee->children();
 232
 233 Returns a list or record set, depending on context, of all
 234 the objects one level below the current one.  This method
 235 is created when parent_column() is called, which sets up a
 236 has_many relationship called children.
 237
 238 =head2 attach_child
 239
 240   $parent->attach_child( $child );
 241   $parent->attach_child( $child, $child, ... );
 242
 243 Sets the child, or children, to the new parent.  Returns 1
 244 on success and returns 0 if the parent object already has
 245 the child.
 246
 247 =cut
 248
 249 sub attach_child {
 250     my $self = shift;
 251     my $return = 1;
 252     foreach my $child (@_) {
 253         $child->parent( $self );
 254     }
 255     return $return;
 256 }
 257
 258 =head2 siblings
 259
 260   my $rs = $node->siblings();
 261   my @siblings = $node->siblings();
 262
 263 Returns either a result set or an array of all other objects
 264 with the same parent as the calling object.
 265
 266 =cut
 267
 268 sub siblings {
 269     my( $self ) = @_;
 270     my $parent_col = $self->_parent_column;
 271     my $primary_col = ($self->primary_columns())[0];
 272     my $rs = $self->result_source->resultset->search(
 273         {
 274             $parent_col => $self->get_column($parent_col),
 275             $primary_col => { '!=' => $self->get_column($primary_col) },
 276         },
 277     );
 278     return $rs->all() if (wantarray());
 279     return $rs;
 280 }
 281
 282 =head2 attach_sibling
 283
 284   $obj->attach_sibling( $sibling );
 285   $obj->attach_sibling( $sibling, $sibling, ... );
 286
 287 Sets the passed in object(s) to have the same parent
 288 as the calling object.  Returns 1 on success and
 289 0 if the sibling already has the same parent.
 290
 291 =cut
 292
 293 sub attach_sibling {
 294     my $self = shift;
 295     my $return = 1;
 296     foreach my $node (@_) {
 297         $return = 0 if (!$node->parent( $self->parent() ));
 298     }
 299     return $return;
 300 }
 301
 302 =head2 is_leaf
 303
 304   if ($obj->is_leaf()) { ... }
 305
 306 Returns 1 if the object has no children, and 0 otherwise.
 307
 308 =cut
 309
 310 sub is_leaf {
 311     my( $self ) = @_;
 312
 313     my $has_child = $self->result_source->resultset->search(
 314         { $self->_parent_column => $self->id() },
 315         { limit => 1 }
 316     )->count();
 317
 318     return $has_child ? 0 : 1;
 319 }
 320
 321 =head2 is_root
 322
 323   if ($obj->is_root()) { ... }
 324
 325 Returns 1 if the object has no parent, and 0 otherwise.
 326
 327 =cut
 328
 329 sub is_root {
 330     my( $self ) = @_;
 331     return ( $self->get_column( $self->_parent_column ) ? 0 : 1 );
 332 }
 333
 334 =head2 is_branch
 335
 336   if ($obj->is_branch()) { ... }
 337
 338 Returns 1 if the object has a parent and has children.
 339 Returns 0 otherwise.
 340
 341 =cut
 342
 343 sub is_branch {
 344     my( $self ) = @_;
 345     return ( ($self->is_leaf() or $self->is_root()) ? 0 : 1 );
 346 }
 347
 348 =head2 set_primary_key
 349
 350 This method is an override of DBIx::Class' method for setting the
 351 class' primary key column(s).  This method passes control right on
 352 to the normal method after first validating that only one column is
 353 being selected as a primary key.  If more than one column is then
 354 an error will be thrown.
 355
 356 =cut
 357
 358 sub set_primary_key {
 359     my $self = shift;
 360     if (@_>1) {
 361         croak('You may only specify a single column as the primary key for adjacency tree classes');
 362     }
 363     return $self->next::method( @_ );
 364 }
 365
 366 1;
 367 __END__
 368
 369 =head1 INHERITED METHODS
 370
 371 =head2 DBIx::Class
 372
 373 =over 4
 374
 375 =item *
 376
 377 L<mk_classdata|DBIx::Class/mk_classdata>
 378
 379 =item *
 380
 381 L<component_base_class|DBIx::Class/component_base_class>
 382
 383 =back
 384
 385 =head2 DBIx::Class::Componentised
 386
 387 =over 4
 388
 389 =item *
 390
 391 L<inject_base|DBIx::Class::Componentised/inject_base>
 392
 393 =item *
 394
 395 L<load_components|DBIx::Class::Componentised/load_components>
 396
 397 =item *
 398
 399 L<load_own_components|DBIx::Class::Componentised/load_own_components>
 400
 401 =back
 402
 403 =head2 Class::Data::Accessor
 404
 405 =over 4
 406
 407 =item *
 408
 409 L<mk_classaccessor|Class::Data::Accessor/mk_classaccessor>
 410
 411 =back
 412
 413 =head1 AUTHOR
 414
 415 Aran Clary Deltac <bluefeet@cpan.org>
 416
 417 =head1 LICENSE
 418
 419 You may distribute this code under the same terms as Perl itself.
 420