Renamed Positional to Ordered and added tests for Ordered.

[dbsrgits/DBIx-Class-Tree.git] / lib / DBIx / Class / Tree / AdjacencyList.pm

# vim: ts=8:sw=4:sts=4:et
package DBIx::Class::Tree::AdjacencyList;
use strict;
use warnings;
use base qw( DBIx::Class );
use Carp qw( croak );

=head1 NAME

DBIx::Class::Tree::AdjacencyList - Manage a tree of data using the common adjacency list model. (EXPERIMENTAL)

=head1 SYNOPSIS

Create a table for your tree data.

  CREATE TABLE employees (
    employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
    parent_id INTEGER NOT NULL DEFAULT 0,
    name TEXT NOT NULL
  );

In your Schema or DB class add Tree::AdjacencyList to the top 
of the component list.

  __PACKAGE__->load_components(qw( Tree::AdjacencyList ... ));

Specify the column that contains the parent ID of each row.

  package My::Employee;
  __PACKAGE__->parent_column('parent_id');

Thats it, now you can modify and analyze the tree.

  #!/usr/bin/perl
  use My::Employee;
  
  my $employee = My::Employee->create({ name=>'Matt S. Trout' });
  
  my $rs = $employee->children();
  my @siblings = $employee->children();
  
  my $parent = $employee->parent();
  $employee->parent( 7 );

=head1 DESCRIPTION

This module provides methods for working with adjacency lists.  The 
adjacency list model is a very common way of representing a tree structure.  
In this model each row in a table has a prent ID column that references the 
primary key of another row in the same table.  Because of this the primary 
key must only be one column and is usually some sort of integer.  The row 
with a parent ID of 0 is the root row and is usually the parent of all 
other rows.

=head1 METHODS

=head2 parent_column

  __PACKAGE__->parent_column('parent_id');

Declares the name of the column that contains the self-referential 
ID which defines the parent row.  Defaults to "parent_id".  This 
will create a has_many (children) and belongs_to (parent) 
relationship.

=cut

__PACKAGE__->mk_classdata( '_parent_column' => 'parent_id' );

sub parent_column {
    my $class = shift;
    if (@_) {
        my $parent_col = shift;
        my $primary_col = ($class->primary_columns())[0];
        $class->belongs_to( '_parent' => $class => { "foreign.$primary_col" => "self.$parent_col" } );
        $class->has_many( 'children' => $class => { "foreign.$parent_col" => "self.$primary_col" } );
        $class->_parent_column( $parent_col );
        return 1;
    }
    return $class->_parent_column();
}

=head2 parent

  my $parent = $employee->parent();
  $employee->parent( $parent_obj );
  $employee->parent( $parent_id );

Retrieves the object's parent object, or changes the object's 
parent to the specified parent or parent ID.

=cut

sub parent {
    my $self = shift;
    if (@_) {
        my $new_parent = shift;
        my $parent_col = $self->_parent_column();
        if (ref($new_parent)) {
            $new_parent = $new_parent->id() || croak('Parent object does not have an ID');;
        }
        return 0 if ($new_parent == ($self->get_column($parent_col)||0));
        $self->set_column( $parent_col => $new_parent );
        $self->update();
        return 1;
    }
    return $self->_parent();
}

=head2 children

  my $children_rs = $employee->children();
  my @children = $employee->children();

Returns a list or record set, depending on context, of all 
the objects one level below the current one.  This method 
is created when parent_column() is called, which sets up a 
has_many relationship called children.

=head2 attach_child

  $parent->attach_child( $child );

Sets the child to the new parent.

=cut

sub attach_child {
    my( $self, $child ) = @_;
    return $child->parent( $self );
}

=head2 siblings

  my $rs = $node->siblings();
  my @siblings = $node->siblings();

Returns either a result set or an array of all other objects 
with the same parent as the calling object.

=cut

sub siblings {
    my( $self ) = @_;
    my $parent_col = $self->_parent_column;
    my $primary_col = ($self->primary_columns())[0];
    my $rs = $self->result_source->resultset->search(
        {
            $parent_col => $self->get_column($parent_col),
            $primary_col => { '!=' => $self->get_column($primary_col) },
        },
    );
    return $rs->all() if (wantarray());
    return $rs;
}

=cut

=head2 attach_sibling

  $this->attach_sibling( $that );

Sets the passed in object to have the same parent 
as the calling object.

=cut

sub attach_sibling {
    my( $self, $node ) = @_;
    return $node->parent( $self->parent() );
}

1;
__END__

=head1 AUTHOR

Aran Clary Deltac <bluefeet@cpan.org>

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.