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

package DBIx::Class::Tree::AdjacencyList;
# vim: ts=8:sw=4:sts=4:et

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.

=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 node and is usually the parent of all 
other rows.  Although, there is no limitation in this module that would 
stop you from having multiple root nodes.



=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.

This method also setups an additional has_many relationship called 
parents which is useful when you want to treat an adjacency list 
as a DAG.

=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->has_many( 'parents' => $class => { "foreign.$primary_col" => "self.$parent_col" }, {cascade_delete=>0} );
        $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.  If you would like 
to make the object the root node, just set the parent to 0.

If you are setting the parent then 0 will be returned if the 
specified parent is already the object's parent and 1 on 
success.

=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 set_parent

    $employee->set_parent($boss_obj);
    $employee->set_parent($boss_id);

A syntactic alternative to ->parent() for setting only.

=cut

sub set_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;
    }
}



=head2 parents

  my $parents = $node->parents();
  my @parents = $node->parents();

This has_many relationship is not that useful as it will 
never return more than one parent due to the one-to-many 
structure of adjacency lists.  The reason this relationship 
is defined is so that this tree type may be treated as if 
it was a DAG.

=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 add_child

  $parent->add_child( $child );
  $parent->add_child( $child, $child, ... );

Sets the child, or children, to the new parent.  Returns 1 
on success and returns 0 if the parent object already has 
the child.

=cut

sub add_child {
    my $self = shift;
    my $return = 1;
    foreach my $child (@_) {
        $child->parent( $self );
    }
    return $return;
}



=head2 add_children

An alias for add_child.

=cut

sub add_children {
    my $self = shift;
    return $self->add_child(@_);
}



=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;
}



=head2 add_sibling

  $obj->add_sibling( $sibling );
  $obj->add_sibling( $sibling, $sibling, ... );

Sets the passed in object(s) to have the same parent 
as the calling object.  Returns 1 on success and 
0 if the sibling already has the same parent.

=cut

sub add_sibling {
    my $self = shift;
    my $return = 1;
    foreach my $node (@_) {
        $return = 0 if (!$node->parent( $self->parent() ));
    }
    return $return;
}



=head2 is_leaf

  if ($obj->is_leaf()) { ... }

Returns 1 if the object has no children, and 0 otherwise.

=cut

sub is_leaf {
    my( $self ) = @_;
    return $self->result_source->resultset->search(
        { $self->_parent_column => $self->id() },
        { limit => 1 }
    )->count();
}



=head2 is_root

  if ($obj->is_root()) { ... }

Returns 1 if the object has no parent, and 0 otherwise.

=cut

sub is_root {
    my( $self ) = @_;
    return ( $self->get_column( $self->_parent_column ) ? 1 : 0 );
}



=head2 is_branch

  if ($obj->is_branch()) { ... }

Returns 1 if the object has a parent and has children.  
Returns 0 otherwise.

=cut

sub is_branch {
    my( $self ) = @_;
    return !($self->is_leaf() or $self->is_root());
}



=head2 descendents

Returns a flat list of *all* the node's descendents.
Dangerously recursive. Use with extreme caution. May contain
nuts.

=cut

sub descendents {
    my $self  = shift;
    my @descendents;
    for my $child ($self->children) {
        push @descendents, $child, $child->descendents;
    }
    return @descendents;
}



=head2 pharaoh_delete

Deletes a node and all it's children (even if cascade_delete is off)

=cut

sub pharaoh_delete {
    my $self = shift;
    for my $child ($self->children) {
        $child->pharaoh_delete;
    }
    $self->delete;
}



=head2 grandmother_delete

Deletes a node and sends all its children to live with their grandmother

=cut

sub grandmother_delete {
    my $self = shift;
    $self->parent->add_children($self->children);
    $self->delete;
}



=head2 promote_eldest_child_delete

Deletes a node and promotes the first of it children to take its place.
If that node already had children, they will now be siblings of the new
parent node's former siblings (which are now its children).

=cut

sub promote_eldest_child_delete {
    my $self = shift;
    my @children = $self->children;
    my $eldest = shift @children;
    $eldest->set_parent($self->parent);
    $eldest->add_children(@children);
    $self->delete;
}
    


=head2 

Replaces the current node with the given replacement, and then deletes the
current node.  The replacement node with have the old node's parent, and its
children will be the union of its original children and the old node's 
children.

=cut

sub replace_with_and_delete {
    my ($self, $replacement) = @_;
    $replacement->add_children($self->children);
    $replacement->set_parent($self->parent);
    $self->delete;
}



=head2 set_primary_key

This method is an override of DBIx::Class' method for setting the 
class' primary key column(s).  This method passes control right on 
to the normal method after first validating that only one column is 
being selected as a primary key.  If more than one column is then 
an error will be thrown.

=cut

sub set_primary_key {
    my $self = shift;
    if (@_>1) {
        croak('You may only specify a single column as the primary key for adjacency tree classes');
    }
    return $self->next::method( @_ );
}

1;
__END__

=head1 INHERITED METHODS

=head2 DBIx::Class

=over 4

=item *

L<mk_classdata|DBIx::Class/mk_classdata>

=item *

L<component_base_class|DBIx::Class/component_base_class>

=back

=head2 DBIx::Class::Componentised

=over 4

=item *

L<inject_base|DBIx::Class::Componentised/inject_base>

=item *

L<load_components|DBIx::Class::Componentised/load_components>

=item *

L<load_own_components|DBIx::Class::Componentised/load_own_components>

=back

=head2 Class::Data::Accessor

=over 4

=item *

L<mk_classaccessor|Class::Data::Accessor/mk_classaccessor>

=back

=head1 AUTHOR

Aran Clary Deltac <bluefeet@cpan.org>

=head1 LICENSE

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