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