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,
  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   # If you want positionable data make sure this
  27   # module comes first, as in:
  28   __PACKAGE__->load_components(qw( Tree::AdjacencyList Positional ... ));
  29
  30 Specify the column that contains the parent ID each row.
  31
  32   package My::Employee;
  33   __PACKAGE__->parent_column('parent_id');
  34
  35 Thats it, now you can modify and analyze the tree.
  36
  37   #!/use/bin/perl
  38   use My::Employee;
  39
  40   my $employee = My::Employee->create({ name=>'Matt S. Trout' });
  41
  42   my $rs = $employee->children();
  43   my @siblings = $employee->children();
  44
  45   my $parent = $employee->parent();
  46   $employee->parent( 7 );
  47
  48 =head1 DESCRIPTION
  49
  50 This module provides methods for working with adjacency lists.  The
  51 adjacency list model is a very common way of representing a tree structure.
  52 In this model each row in a table has a prent ID column that references the
  53 primary key of another row in the same table.  Because of this the primary
  54 key must only be one column and is usually some sort of integer.  The row
  55 with a parent ID of 0 is the root row and is usually the parent of all
  56 other rows.
  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".
  66
  67 If you are useing the L<DBIx::Class::Positional> component then this
  68 parent_column will automatically be used as the collection_column.
  69
  70 =cut
  71
  72 __PACKAGE__->mk_classdata( 'parent_column' => 'parent_id' );
  73
  74 =head2 parent
  75
  76   my $parent = $employee->parent();
  77   $employee->parent( $parent_obj );
  78   $employee->parent( $parent_id );
  79
  80 Retrieves the object's parent ID, or sets the object's
  81 parent ID.  If setting the parent ID then 0 will be returned
  82 if the object already has the specified parent, and 1 on
  83 success.
  84
  85 If you are using the L<DBIx::Class::Positional> component this
  86 module will first move the object to the last position of
  87 the list, change the parent ID, then move the object to the
  88 last position of the new list.  This ensures the intergrity
  89 of the positions.
  90
  91 =cut
  92
  93 sub parent {
  94     my( $self, $new_parent ) = @_;
  95     my $parent_column = $self->parent_column();
  96     if ($new_parent) {
  97         if (ref($new_parent)) {
  98             $new_parent = $new_parent->id() || 0;
  99         }
 100         return 0 if ($new_parent == ($self->get_column($parent_column)||0));
 101         $self->move_last() if ($self->positional());
 102         $self->set_column( $parent_column => $new_parent );
 103         if ($self->positional()) {
 104             $self->set_column(
 105                 $self->position_column() => $self->search( {$self->_collection_clause()} )->count() + 1
 106             );
 107         }
 108         $self->update();
 109         return 1;
 110     }
 111     else {
 112         return $self->find( $self->get_column( $parent_column ) );
 113     }
 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.
 123
 124 If you are using the L<DBIx::Class::Positional> component then this method
 125 will return the children sorted by the position column.
 126
 127 =cut
 128
 129 sub children {
 130     my( $self ) = @_;
 131     my $rs = $self->search(
 132         { $self->parent_column()=>$self->id() },
 133         ( $self->isa('DBIx::Class::Position') ? {order_by=>$self->position_column()} : () )
 134     );
 135     return $rs->all() if (wantarray());
 136     return $rs;
 137 }
 138
 139 =head2 attach_child
 140
 141   $parent->attach_child( $child );
 142
 143 Sets (or moves) the child to the new parent.
 144
 145 =cut
 146
 147 sub attach_child {
 148     my( $self, $child ) = @_;
 149     $child->parent( $self );
 150 }
 151
 152 =head2 attach_sibling
 153
 154   $this->attach_sibling( $that );
 155
 156 Sets the passed in object to have the same parent
 157 as the calling object.
 158
 159 =cut
 160
 161 sub attach_sibling {
 162     my( $self, $child ) = @_;
 163     $child->parent( $self->parent() );
 164 }
 165
 166 =head1 POSITIONAL METHODS
 167
 168 If you are useing the L<DBIx::Class::Postional> component
 169 in conjunction with this module then you will also have
 170 these methods available to you.
 171
 172 =head2 append_child
 173
 174   $parent->append_child( $child );
 175
 176 Sets the child to have the specified parent and moves the
 177 child to the last position.
 178
 179 =cut
 180
 181 sub append_child {
 182     my( $self, $child ) = @_;
 183     croak('This method may only be used with the Positional component') if (!$self->positional());
 184     $child->parent( $self );
 185 }
 186
 187 =head2 prepend_child
 188
 189   $parent->prepend_child( $child );
 190
 191 Sets the child to have the specified parent and moves the
 192 child to the first position.
 193
 194 =cut
 195
 196 sub prepend_child {
 197     my( $self, $child ) = @_;
 198     croak('This method may only be used with the Positional component') if (!$self->positional());
 199     $child->parent( $self );
 200     $child->move_first();
 201 }
 202
 203 =head2 attach_before
 204
 205   $this->attach_before( $that );
 206
 207 Attaches the object at the position just before the
 208 calling object's position.
 209
 210 =cut
 211
 212 sub attach_before {
 213     my( $self, $sibling ) = @_;
 214     croak('This method may only be used with the Positional component') if (!$self->positional());
 215     $sibling->parent( $self->parent() );
 216     $sibling->move_to( $self->get_column($self->position_column()) );
 217 }
 218
 219 =head2 attach_after
 220
 221   $this->attach_after( $that );
 222
 223 Attaches the object at the position just after the
 224 calling object's position.
 225
 226 =cut
 227
 228 sub attach_after {
 229     my( $self, $sibling ) = @_;
 230     croak('This method may only be used with the Positional component') if (!$self->positional());
 231     $sibling->parent( $self->parent() );
 232     $sibling->move_to( $self->get_column($self->position_column()) + 1 );
 233 }
 234
 235 =head2 positional
 236
 237   if ($object->positional()) { ... }
 238
 239 Returns true if the object is a DBIx::Class::Positional
 240 object.
 241
 242 =cut
 243
 244 sub positional {
 245     my( $self ) = @_;
 246     return $self->isa('DBIx::Class::Positional');
 247 }
 248
 249 =head1 PRIVATE METHODS
 250
 251 These methods are used internally.  You should never have the
 252 need to use them.
 253
 254 =head2 _collection_clause
 255
 256 This method is provided as an override of the method in
 257 L<DBIx::Class::Positional>.  This way Positional and Tree::AdjacencyList
 258 may be used together without conflict.  Make sure that in
 259 your component list that you load Tree::AdjacencyList before you
 260 load Positional.
 261
 262 =cut
 263
 264 sub _collection_clause {
 265     my( $self ) = @_;
 266     return (
 267         $self->parent_column() =>
 268         $self->get_column($self->parent_column())
 269     );
 270 }
 271
 272 1;
 273 __END__
 274
 275 =head1 AUTHOR
 276
 277 Aran Clary Deltac <bluefeet@cpan.org>
 278
 279 =head1 LICENSE
 280
 281 You may distribute this code under the same terms as Perl itself.
 282