Tree::Numbered::DB - a tree that is stored in / tied to a DB table.

 Tree::Numbered::DB - a tree that is stored in / tied to a DB table.

  use NumberedTree::DBTree;
  my $dbh = DBI->connect(...);

  # The easy way:
  my $tree = NumberedTree::DBTree->read($table, $dbh);

  # The hard way:
  my $tree = NumberedTree::DBTree->new(source_name => 'a_table', 
                                       source => $dbh);
  while (I aint sick of it) {
  	$tree->append(Value => $newValue);
  }

  etc.

 Example SQL statement to build the table (tested on MySQL):  
 create table places (serial int auto_increment primary key, 
 				  parent int not null, 
				  name varchar(20));

  Existing mapping (e.g. from a deleted field, or default) -->
  Mapping for the same field found in the parent of the node -->
  Mapping suplied as an argument.

 Please report through CPAN: 
 < http://rt.cpan.org/NoAuth/Bugs.html?Dist=Tree-Numbered-DB >
 or send mail to <bug-Tree-Numbered-DB#rt.cpan.org> 

 For sugestions, questions and such, email me directly.

package Tree::Numbered::DB;

use strict;

use Tree::Numbered;

use DBI;

our $VERSION = '1.02.2';
our @ISA = qw(Tree::Numbered);

my %collumn_names = (_Serial => 'serial', 
		     _Parent => 'parent',
		     Value => 'name');

sub _addMapping; # predeclared method.

# Internal group of subs to determine whether we should write each change
# or do batch operations. 1 = every change.
{
    my $write_mode = 1;
    sub _turnOnWrite {
	$write_mode = 1;
    }
    sub _turnOffWrite {
	$write_mode = 0;
    }
    sub _WriteMode {return $write_mode};
}

# <getFieldsStr> returns a string of fields in the order they are returned
#  from getFieldNames
# Arguments: $cols - a hash of column mappings.
# Returns: See above,,,

sub _getFieldsStr {
    my $self = shift;
    return join ', ', map {$self->getMapping($_) . "=?"} 
    @{$self->getFieldNames} if $self->getFieldNames;
}

# <getStatements> a service method that prepares SQL statements used in the 
# module.
# Arguments: $colnames - names of the columns that make up the table (see
#            %collumn_names above).
# Returns: a hash with the statements.

sub getStatements {
    my $self = shift;
    my $serial = $self->getMapping('_Serial');
    my $parent = $self->getMapping('_Parent');

    my $extra = $self->_getFieldsStr || '';
    my $dbh = $self->{Source};
    my $table = $self->{SourceName};

    my %statements;
    $statements{add} = "insert into $table set " .
	"$parent=$self->{_Parent}, " . $extra;
    $statements{who} = "select max($serial) from $table";
    $statements{delete} = "delete from $table where $serial=?";
    $statements{update} = "update $table set " . $extra .
	" where $serial=?"; # We don't have a number yet...
    $statements{truncate} = "truncate $table";

    $self->{Statements} = {map {$_ => $dbh->prepare($statements{$_}) } 
			   keys %statements};
}

# <new> constructs a new tree or node.
# Arguments: By name: 
#       parent - the node's parent (for internal use).
#       source_name - table name.
#       source - DB handle.
#       *_col - column mapping.
#       * - column value.
#       serial_col - collumn name for serial numbers
#       parent_col - column name for parent numbers.
#       NoWrite - create the node without writing it to the DB (internal use). 
# Returns: The tree object.

sub new {
    my %reserved = map {$_ => 1} ('parent_col', 'serial_col', 
				  'parent', 'serial', 'NoWrite', 
				  'source', 'source_name');

    my $parent = shift;
    my %args = @_;

    my ($parent_serial, $class);
    _turnOffWrite; # turn off writing for a while.

    # Create the bloody thing. addField will search the parent for mappings.
    my $properties = $parent->SUPER::new;

    # Find out which mappings and fields
    my @colnames = grep(/_col$/, keys %args);
    my %colmaps = map {$_ => $args{$_}} @colnames;
    my %fields = %args;
    delete @fields{@colnames, keys %reserved};

    # Auto create fields with undefind value if a mapping exists for them.
    foreach (@colnames) {
	next if (exists $reserved{$_});
	s/_col$//;
	$fields{$_} = undef unless (exists $fields{$_}); # Auto vivification.
    }

    # Create the Value field if no other field was requested:
    unless (scalar keys %fields) {
	#default field and map.
	$properties->_addMapping('Value', $collumn_names{Value});
	$fields{Value} = undef;
    }

    if ($class = ref($parent)) {
	# We're adding to an existing tree.
	$properties->{Source} = $parent->{Source};   
	$properties->{SourceName} = $parent->{SourceName};
	$properties->{_Parent} = $parent->{_Serial};

	# Inherit mappings:
	foreach my $field ($parent->getFieldNames) {
	    # Won't do anything if mapping is already there:
	    $properties->_addMapping($field, $parent->getMapping($field));
	}
	$properties->_addMapping('_Serial', $parent->getMapping('_Serial'));
	$properties->_addMapping('_Parent', $parent->getMapping('_Parent'));
    } else {
	# New tree. Check that args are correct:
	unless ($args{source_name} && $args{source}){
	    warn "No source or name, failed to create a tree.";
	    return undef; 
	}

	$class = $parent;
	$properties->{_Parent} = $args{parent} ||= 0;
	$properties->{Source} = $args{source} ||= '';   
	$properties->{SourceName} = $args{source_name} ||= '';

	# Use default mapping for mandatory fields::
	$properties->_addMapping('_Serial', $collumn_names{_Serial});
	$properties->_addMapping('_Parent', $collumn_names{_Parent});

    }

    # Use arguments for mappings for mandatory serial and parent.
    $properties->setMapping('_Serial', $colmaps{"serial_col"}) 
	if ($colmaps{"serial_col"});
    $properties->setMapping('_Parent', $colmaps{"parent_col"})
	if  ($colmaps{"parent_col"});
    
    # add mappings and fields.
    foreach (keys %fields) {
        # Fail if there's a field with no mapping.
	unless($colmaps{"${_}_col"} or $properties->getMapping($_)) {
	    warn "No mapping for field $_, unable to create a tree.";
	    return undef;
	}
	$properties->_addMapping($_, $colmaps{"${_}_col"});
	$properties->addField($_, $fields{$_}) or 
	    $properties->setField($_, $fields{$_});
    }
	     
    _turnOnWrite; # Ok, let's make it real:
    # Create SQL statements:
    $properties->getStatements;
    $properties->{_Serial} = addNodeDB($properties) unless $args{NoWrite};

    return $properties;
}

# <addNodeDB> adds a record to a table containing a tree.
# Arguments: $self - the node's hash. This is not a class method because the 
#            object we're operating on is not yet blessed.
# Returns: The new Serial number of the Item added.

sub addNodeDB {
    my $self = shift;
    my $parent = $self->{_Parent};
    # Preserve order of fields:
    my @values = map { $self->getField($_) } @{ $self->getFieldNames };

    $self->{Statements}->{add}->execute(@values) or return undef;
    $self->{Statements}->{who}->execute;
    return ($self->{Statements}->{who}->fetchrow_array)[0];
}

# <readDB> constructs a new tree from a pre-existing table.
# Arguments: $table - table name.
#            $dbh - database handle to operate on.
#            $cols - a hash giving alternative collumn names.
# Returns: The tree object.

sub read {
    my ($self, $table, $dbh, $cols) = @_;
    return undef if (ref $self); # Class method only, dude.

    # Some defaults:
    $cols ||= {Value_col => $collumn_names{Value}}; 
    $cols->{serial_col} ||= $collumn_names{_Serial};
    $cols->{parent_col} ||= $collumn_names{_Parent};

    my %fcols = %$cols; # field columns.
    delete @fcols{'serial_col', 'parent_col'};

    # Start construction of root element:
    my $tree = Tree::Numbered::DB->new(source => $dbh,
				       source_name => $table,
				       parent => 0,
				       NoWrite => 1, 
				       %$cols);

    my $extra = join '', map {', '.$tree->getMapping($_)} $tree->getFieldNames;
    $extra ||= '';

    my @parents = @{
	$dbh->selectall_arrayref("select $cols->{parent_col} from $table " . 
				 "group by $cols->{parent_col}")
	};
    # The prntnums hash is used to save calls to the DB. 
    # if a row is not a parent,
    # there's no need to query the database about its children.
    my %prntnums = map {$_->[0] => 1} @parents;
    delete $prntnums{0}; # or endless recursion...

    # TO DO: make order-by a user choice instead of hard-coded.
    my $sth = $dbh->prepare("select $cols->{serial_col}" . $extra . 
			    " from $table where $cols->{parent_col}=?" .
			    " order by $cols->{serial_col}");
    $sth->execute(0);
    my $root = $sth->fetchrow_hashref;

    $tree->{_Serial} = $root->{$tree->getMapping('_Serial')};
    foreach my $field ($tree->getFieldNames) {
	$tree->setField($field, $root->{$tree->getMapping($field)});
    }
    $tree->recursiveTreeBuild($sth, $cols, %prntnums);

    return $tree;
}

sub recursiveTreeBuild {
    my ($self, $sth, $cols, %prntnums) = @_;
    my $serial = $self->{_Serial};

    $sth->execute(($serial));
    my %rows = %{$sth->fetchall_hashref($self->getMapping('_Serial'))};
    
    foreach my $row (sort {$a <=> $b} keys %rows) {
	# Note that the mappings for #self are the same as those of $newNode.
	my %values = map { $_, $rows{$row}->{$self->getMapping($_)} } 
	$self->getFieldNames;
	$values{NoWrite} = 1;

	my $newNode = $self->append(%values);
	$newNode->{_Serial} = $row;

	next unless (delete $prntnums{$row});
	$newNode->recursiveTreeBuild($sth, $cols, %prntnums);
    }
}

# <delete> deletes the item pointed to by the cursor.
# The curser is not changed, which means it effectively moves to the next item.
# However it does change to be just after the end if it is already there,
# so you won't get an overflow.
# Arguments: None.
# Returns: The deleted item or undef if none was deleted.
#          Note that the returned item is invalid since it's deleted from its 
#          table.

sub delete {
    my $self = shift;
    my $deleted = $self->SUPER::delete;

    if ($deleted) { 
	$deleted->{Statements}->{delete}->execute($deleted->{_Serial}); 
    }
    return $deleted;
}

# <update> updates the database when something changes.
sub update {
    my $self = shift;
    my @values = (map { $self->getField($_) } 
		  @{ $self->getFieldNames } );
    $self->{Statements}->{update}->execute(@values, $self->getNumber);
}

# <truncate> removes the entire table tied to the tree. Kills the 
#  data structure.
# Arguments: None.
# Returns: Nothing.

sub truncate {
    my $self = shift;
    $self->{Statements}->{truncate}->execute;
    delete $self->{keys %$self}; # Suicide.
}

# <revert> re-blesses the tree into the parent class, losing DB Tie.
# Arguments: None.
# Returns: Nothing.

sub revert {
    my $self = shift;
    my $keep_data = shift;

    # Remove data specific to this class:
    unless ($keep_data) {
	delete $self->{Source};
	delete $self->{SourceName};
	delete $self->{Statements};
	delete $self->{Map};
    }
    $_->revert foreach (@{ $self->{Items} });

    return bless $self, $ISA[0];
}

#*******************************************************************
# Field <-> DB mappings

# <_addMapping> adds a mapping to a field if there isn't one already.
#  You are allowed to add mappings to nonexistent fields.
# Arguments: $field - field name.
#            $map - collumn name to be mapped to the field.
# Returns: map name on success, undef otherwise.

sub _addMapping {
    my $self = shift;
    my ($field, $map) = @_;

    return $self->{Map}->{$field} = $map unless ($self->{Map}->{$field});
    return undef;
}

sub _removeMapping {
    my $self = shift;
    my $field = shift;
    delete $self->{Map}->{$field};
}

sub getMapping {
    my $self = shift;
    my $field = shift;
    return $self->{Map}->{$field} if (exists $self->{Map}->{$field});
    return undef;
}

# <setMapping> changes the collumn mapping for a field.
# Arguments: $field - field name.
#            $value - new column name.
# Returns: the new map value (undef if set failed).

sub setMapping {
    my $self = shift;
    my ($field, $value) = @_;

    return undef unless (exists $self->{Map}->{$field});
    $self->{Map}->{$field} = $value;
    $self->getStatements if _WriteMode;
    return $self->{Map}->{$field};
}

#*******************************************************************
# Overloaded setters:

sub setField {
    my $self = shift;
    $self->SUPER::setField(@_);
    $self->update if (_WriteMode);
}

sub setFields {
    my $self = shift;
    return undef unless ($self->{Fields});

    my (%fields) = @_;
    $self->SUPER::setField($_, $fields{$_}) foreach (keys %fields);
    $self->update if (_WriteMode);
}

# <addField> adds a field and a mapping if necessary. Fails if can't find 
#   mapping.
# Order of search for a mapping:
#   Argument -> Existing -> Parent -> Fail.
# Arguments: $field - field name to add.
#            $arg - field value.
#            $map - a mapping for the field.
# Returns: undef on failure, true on success.

sub addField {
    my $self = shift;
    my ($field, $arg, $map) = @_;

    $map ||= $self->getMapping($field) || 
	$self->getParentRef->getMapping($field);
    return undef unless ((defined $field) && $map);

    $self->_addMapping($field, $map) or $self->setMapping($field, $map);
    my $rv = $self->SUPER::addField($field, $arg);

    if (_WriteMode) {
	$self->getStatements; 
	$self->update;
    }
    return $rv;
}

# <removeField> removes a field and its mapping.
# Arguments: $field - name of field to be removed.
#            $keep_map - wil not delete mapping if true.
# Returns: undef on failure, true on success.

sub removeField {
    my $self = shift;
    my ($field, $keep_map) = @_;

    my $rv = $self->SUPER::removeField($field);
    $self->_removeMapping($field) unless ($keep_map);
    return $rv;
}

1;