File Coverage

blib/lib/DBIx/Tree.pm

Criterion	Covered	Total	%
statement	116	176	65.9
branch	36	64	56.2
condition	24	47	51.0
subroutine	9	12	75.0
pod	1	4	25.0
total	186	303	61.3

package DBIx::Tree;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
use Carp;
use DBI;

@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw();
@EXPORT_OK = qw();

( $VERSION ) = '$Revision: 1.96 $' =~ /(?:\$Revision:\s+)?(\S+)/;

# Preloaded methods go here.

# Constructor.
#
sub new {

    my $proto =  shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);

    my %args = @_;

    $self->{dbh}    = $args{connection};

#    $self->{dbh}->trace(1);
    $self->{dbh}->{RaiseError} = 1;

    $self->{table}  = $args{table};
    $self->{method} = $args{method};
    $self->{post_method} = $args{post_method};
    $self->{sth}    = $args{sth} || $args{sql};

    my $columns = $args{columns};
    $self->{columns}          = $columns;
    $self->{id_column}        = $columns->[0];
    $self->{data_column}      = $columns->[1];
    $self->{parent_id_column} = $columns->[2];
    $self->{order_column}     = $columns->[3] if $#$columns > 2;
    $self->{order_column}   ||= $self->{data_column};
    $self->{order_direction}  = $columns->[4] if $#$columns > 3;
    $self->{order_direction}||= ''; # hush undefined warnings

    $self->{start_id} = $args{start_id} || 1;
    $self->{threshold} = $args{threshold} || 1;
    $self->{match_data} = $args{match_data};
    $self->{limit} = $args{limit};

    $self->{recursive} = $args{recursive} || 1;

    return $self;
}

sub do_query {

    my $self = shift;

    carp "do_query() is now a private function - you need not call it yourself"
	if $^W;

    $self->_do_query(@_);
}

sub _do_query {

    my ($self, $parentid, $id, $level) = @_;

    my $sth;

    unless ($sth = $self->{sth}) {
	my $columns = join(', ', @{ $self->{columns} } );

	my $sql = "SELECT $columns FROM " . ($self->{table});
	if ( $self->{match_data} ) {
	    $sql .= " WHERE $self->{data_column} like '$self->{match_data}%'";
	}
	$sql .= ' order by ' . $self->{order_column} . ' ' .
	    $self->{order_direction} ;
	if ( $self->{limit} ) {
	    $sql .= " LIMIT $self->{limit_left}";
	}
	$sth = $self->{dbh}->prepare($sql);
    } elsif (!ref $self->{sth}) {
	$sth = $self->{dbh}->prepare($self->{sth});
    } else {
	$sth = $self->{sth};
    }

    if (defined($parentid) || defined($id)) {
	# need to modify the statement
	my $sql = $sth->{Statement};
	my $conj = 'WHERE';

	my ($where, $extra);
	if ($sql =~ m/\s+WHERE\s+(.*)/i) {
	    $where = $1;
	    ($extra) = $where =~ m/((?:GROUP\s+BY|ORDER\s+BY|LIMIT).*)/si;
	    $where =~ s/((?:GROUP\s+BY|ORDER\s+BY|LIMIT).*)//si;
	    $sql =~ s/\s+WHERE\s+.*//; # strip where/extra off sql
	} else {
	    $where = '';
	    ($extra) = $sql =~ m/((?:GROUP\s+BY|ORDER\s+BY|LIMIT).*)/si;
	    $sql =~ s/((?:GROUP\s+BY|ORDER\s+BY|LIMIT).*)//si;
	}

	if ($where) {
	    $where = "$conj ( $where )";
	    $conj = 'AND';
	}

	if (defined $parentid) {
	    $where .= "$conj $self->{parent_id_column} = ?";
	    $conj = ' AND';
	}

	if (defined $id) {
	    $where .= "$conj $self->{id_column} = ?";
	    $conj = ' AND';
	}

	$sql .= " $where $extra";
	$sth = $self->{dbh}->prepare_cached($sql);
    }

    my $rc = $sth->execute(defined $parentid ? $parentid : (),
			   defined       $id ?       $id : ()
			  );
    if (!$rc) {
	carp("Could not issue query: $DBI::errstr");
	return 0;
    }

    $self->{data} = $sth->fetchall_arrayref({});
    $sth->finish if $sth->{Active};

    if (!defined($level) || ($level >= $self->{threshold}) ) {
	$self->{limit_left} -= @{$self->{data}};
    }
    $self->{limit_left} = 0 if $self->{limit_left} < 0;

    1; # return success

}

sub tree {

    carp("tree() use is deprecated; use traverse() instead.\n")
	if $^W;

    my $self = shift;
    return $self->traverse(@_);
}

sub traverse {

    my $self = shift;

    # allow local arguments to override defaults set in constructor:
    my %args = @_;
    while (my ($key, $val) = each %args) {
	($self->{$key}, $args{$key}) = ($args{$key}, $self->{$key})
    }

    # reset limit counter:
    $self->{limit_left} = $self->{limit};

    my $rc;
    unless ($self->{recursive} || ($self->{threshold} gt 1 && $self->{limit}) ) {
	$rc = $self->_traverse_linear;
    } else {
	$rc = $self->_traverse_recursive;
    }

    # restore object defaults:
    while (my ($key, $val) = each %args) {
	($self->{$key}, $args{$key}) = ($args{$key}, $self->{$key})
    }

    return $rc;
}

sub _traverse_recursive {

    my $self = shift;

    $self->_handle_node($self->{start_id}, undef, [], [], 1);
}

sub _handle_node {

    my ($self,
	$id,
	$item,
	$parentids,
	$parentnames,
	$level) = @_;

    unless (defined $item) {
	$self->_do_query(undef, $id, $level); # special root finding invocation
	$item = $self->{data}->[0]->{$self->{data_column}};
    }

	# $item is not defined when the constructor is called with:
	# o match_data = 'Some value', and
	# o start_id   = Some value, and (presumably)
	# o The id of the match data is not start_id.
	# In this case, the above special call for finding the root does
	# not return a valid value for item.

    if (defined($item) && $self->{method} && ($level >= $self->{threshold}) )
	{
    $self->{method}->
	( item        => $item,
	  level       => $level,
	  id          => $id,
	  parent_id   => $parentids,
	  parent_name => $parentnames );
	}

    $self->_do_query($id, undef, $level);
    push @{$parentids}, $id;
    push @{$parentnames}, $item;

    for my $child (@{$self->{data}}) {
	$self->_handle_node($child->{$self->{id_column}},
			    $child->{$self->{data_column}},
			    $parentids,
			    $parentnames,
			    $level+1);
    }

    pop @{$parentids};
    pop @{$parentnames};

    if (defined($item) && $self->{post_method} && ($level >= $self->{threshold}) )
	{
    $self->{post_method}->
	( item        => $item,
	  level       => $level,
	  id          => $id,
	  parent_id   => $parentids,
	  parent_name => $parentnames );
	}
}

sub _traverse_linear {

  my $self = shift;

  $self->_do_query();

  my ($current, @order, @stack);

  my (%id_cols, %id_pnts);

  my $i = -1;
  foreach my $aitem (@{ $self->{data} }) {
    $i++;
    if ( defined $aitem->{$self->{parent_id_column}} ) {
      push @{ $id_pnts{ $aitem->{$self->{parent_id_column}} } }, $aitem->{$self->{id_column}};
    }
    if ( defined $aitem->{$self->{id_column}} ) {
      $id_cols{ $aitem->{$self->{id_column}} } = $i;
    }
  }

  my $level = 1;

  # this non-recursive algorithm requires the use of a stack in order
  # to process each element. After each element is processed, it is
  # removed from the stack and its children on the next level are
  # added to the stack. Then it starts all over again until we run out
  # of elements.

  push @order, $self->{start_id};
  push @stack, 1;

  # $level starts out at 1. Every time we run out of items to process
  # at the current level (if $levelFound == 0) $level is
  # decremented. If we get to 0, we have run out of items to process,
  # and can call it quits.

  my (@parent_id, @parent_name);

  while ($level) {

    # search the stack for an item whose level matches $level.

    my $levelFound = 0;
    my $i = -1;
    foreach my $index (@stack) {
      $i++;
      if ($index == $level) {

	# if we have found something whose level is equal to $level,
	# set the variable $current so we can refer to it later. Also,
	# set the flag $levelFound

	$current = $order[$i];
	$levelFound = 1;

	# since we've found record we don't need it on stack

	splice(@order,$i,1);
	splice(@stack,$i,1);

	last;
      }
    }

    # if we found something at the current level, its id will be in
    # $current, so let's process it. Otherwise, we drop through this,
    # decrement $level, and if $level is not 0, start the process over
    # again.

    if ($levelFound) {

      ######################################
      #
      # loop through the array of rows until we find the record with
      # the id that matches $current. This is the id of the item we
      # pulled off of $stack
      #
      ######################################
      my $item;

      my $aryitem = $id_cols{ $current };
      if (defined $aryitem) {

	  ###############################
	  #
	  # the data column is used to get $item, which is the label
	  # in the tree diagram.
	  #
	  # The cartid property is the id of the shopping cart that
	  # was created in the new method
	  #
	  ###############################
	  $item = $self->{data}->[$aryitem]->{$self->{data_column}};

	  ###############################
	  #
	  # if the calling program defined a target script, define
	  # this item on the tree as a hyperlink.  include variables
	  # for id and cartid.
	  #
	  # Otherwise, just add the item as it is.
	  #
	  ###############################
	  $self->{method}->
	      ( item        => $item,
		level       => $level,
		id          => $current,
		parent_id   => \@parent_id,
		parent_name => \@parent_name )
		  if ($self->{method} && $level >= $self->{threshold});


      }

      #################################
      #
      # add all the children (if any) of the current item to the stack
      #
      ###############################

      my $aitem = $id_pnts{ $current };
      if (defined $aitem) {
          foreach my $id ( @{ $aitem } ) {
	    push @stack, $level + 1;
	    push @order, $id;
	  }
      }

      if ($item && $current) {
          push @parent_id, $current;
          push @parent_name, $item;
      }
      $level++ ;

    } else {

      my $current = pop @parent_id;
      my $item = pop @parent_name;

      if ($self->{post_method} && ($level >= $self->{threshold}) )
	  {
      $self->{post_method}->
	  ( item        => $item,
	    level       => $level,
	    id          => $current,
	    parent_id   => \@parent_id,
	    parent_name => \@parent_name );
	  }

      $level--;
    }

  }

  return 1;

}

# Autoload methods go after =cut, and are processed by the autosplit
# program.

1;
__END__