# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: tree.coretag,v 1.12 2007-07-18 00:16:26 jon Exp $

UserTag tree                Order        table master subordinate start
UserTag tree                addAttr
UserTag tree                attrAlias    sub subordinate
UserTag tree                hasEndTag
UserTag tree                Version      $Revision: 1.12 $
UserTag tree                Routine      <<EOR
sub {
	my($table, $parent, $sub, $start_item, $opt, $text) = @_;

#::logDebug("tree-list: received parent=$parent sub=$sub start=$start_item");

	my $nodb;
	my @passed;
	my @start;
	if($opt->{file}) {
		my $delim = $opt->{delimiter} || "\t";
		my $s = $opt->{subordinate} || 'code';
		my $l = $opt->{level_field} || 'msort';
		$delim = qr/$delim/;
		my @lines = split /\n/, readfile($opt->{file});
		my $hdr = shift @lines;
		my @fields = split $delim, $hdr;
		my $i = 1;
		for(@lines) {
			my $ref = {};
			@{$ref}{@fields} = split $delim, $_;
			$ref->{$s} = $i++;
			push @passed, $ref;
			push @start, $ref if $ref->{$l} == 0;
		}
		$nodb = 1;
	}
	my $db;
	
	unless($nodb) {
		$db = ::database_exists_ref($table)
			or return error_opt($opt, "Database %s doesn't exist", $table);
		$db->column_exists($parent)
			or return error_opt($opt, "Parent column %s doesn't exist", $parent);
		$db->column_exists($sub)
			or return error_opt($opt, "Subordinate column %s doesn't exist", $sub);
	}

	my $basewhere;

	WHEREBASE: {
		my @keys;
		my @things;
		if($opt->{multiple_start}) {
			@keys = split /[\0,\s]+/, $start_item;
		}
		else {
			@keys = $start_item;
		}

		unless($nodb) {
			for(@keys) {
				push @things, "$parent = " . $db->quote($_, $parent);
			}
		}
		$basewhere = join " OR ", @things;
	}

	my @outline = (1);
	if(defined $opt->{outline}) {
		$opt->{outline} =~ s/[^a-zA-Z0-9]+//g;
		@outline = split //, $opt->{outline};
		@outline = (qw/1 A 1 a 1 a/) if scalar @outline < 2;
	}

	my $mult = ( int($opt->{spacing}) || 10 );
	my $keyfield;
	$keyfield = $db->config('KEY') unless $nodb;
	$opt->{code_field} = $keyfield if ! $opt->{code_field};

	my $sort = '';
	if($opt->{sort}) {
		$sort .= ' ';
		$sort .= 'ORDER BY '
			unless $opt->{sort} =~ /^\s*order\s+by\s+/i;
		my @sort;
		@sort = ref $opt->{sort}
				?  @{$opt->{sort}}	
				: ( $opt->{sort} );
		for(@sort) {
			s/\s*[=:]\s*([rnxf]).*//;
			$_ .= " DESC" if $1 eq 'r';
		}
		$sort .= join ", ", @sort;
		undef $opt->{sort};
	}

	my $where = '';
	unless($nodb) {
		if( my $f = $db->config('HIDE_FIELD')) {
			$where .= " AND $f <> 1";
		}
	}

	if($opt->{where}) {
		$where .= " AND ($opt->{where})";
	}

	my $qb = "SELECT * FROM $table WHERE $basewhere$where$sort";
#::logDebug("tree tag initial query=$qb");

	my $ary;
	if($nodb) {
		$ary = \@start;
	}
	else {
		$ary = $db->query( {
							hashref => 1,
							sql => $qb,
							});
	}
	
	my $memo;
	if( $opt->{memo} ) {
		$memo = ($::Scratch->{$opt->{memo}} ||= {});
		my $toggle;
		if($opt->{toggle} and $toggle = $CGI::values{$opt->{toggle}}) {
			$memo->{$toggle} = ! $memo->{$toggle};
		}
	}

	if($opt->{collapse} and $CGI::values{$opt->{collapse}}) {
		$memo = {};
		delete $::Scratch->{$opt->{memo}} if $opt->{memo};
	}

	my $explode;
	if($opt->{full} or $opt->{explode} and $CGI::values{$opt->{explode}}) {
		$explode = 1;
	}

	my $enable;

	my $qsub;

	my $donemsg;
	my $dbh;
	$dbh = $db->dbh() unless $nodb;

	my $qs_query = "SELECT * FROM $table WHERE $parent = ?$where$sort";
	if($nodb) {
		my $l = $opt->{level_field} || 'msort';
#::logDebug("setting up nodb qsub level=$l");
		$qsub = sub {
			my $key = shift;
#::logDebug("Looking for key=$key");
			return if $key < 1;
			my $base = $passed[$key - 1]->{$l} + 1;
#::logDebug("Base level=$base, firstone = $passed[$key]{$l}");
			my @out;
			for(my $i = $key; $passed[$i]{$l} >= $base ; $i++ ) {
				push @out, $passed[$i] if $passed[$i]{$l} == $base;
			}
			return unless @out;
			return \@out;
		};
	}
	elsif($dbh and $db->config('Class') eq 'DBI') {
		my $sth = $dbh->prepare($qs_query)
				or die errmsg(
						"tree failed to prepare query: %s\nError was: %s",
						$qs_query,
						$DBI::errstr,
						);
		$qsub = sub {
#::logDebug("executing query sub DBI style"); # while ! $donemsg++;
			my $parm = shift;
			my @ary;
			$sth->execute($parm)
				or die errmsg(
						"tree failed to prepare query for '%s': %s\nError was: %s",
						$parm,
						$qs_query,
						$DBI::errstr,
						);
			while(my $ref = $sth->fetchrow_hashref()) {
				push @ary, { %$ref };
			}
			return unless @ary;
			return \@ary;
		};
	}
	else {
		$qsub = sub {
			my $parm = shift;
#::logDebug("executing query sub regular style"); # while ! $donemsg++;
			$parm = $db->quote($parm, $parent);
			my $q = $qs_query;
			$q =~ s/\s\?\s/ $parm /;
			$db->query( { hashref => 1, sql => $q });
		};
	}


	$memo = {} if ! $memo;

	my $count = 0;

	my $stop_sub;

#::logDebug("tree-list: valid parent=$parent sub=$sub start=$start_item mult=$mult");

	my @ary_stack   = ( $ary );				# Stacks the rows
	my @above_stack = { $start_item => 1 }; # Holds the previous levels
	my @inc_stack   = ($outline[0]);		# Holds the increment characters
	my @rows;
	my $row;

	ARY: for (;;) {
#::logDebug("next ary");
		my $ary = pop(@ary_stack)
			or last ARY;
		my $above = pop(@above_stack);
		my $level = scalar(@ary_stack);
		my $increment = pop(@inc_stack);
		ROW: for(;;) {
#::logDebug("next row level=$level increment=$increment");
			my $prev = $row;
			$row = shift @$ary
				or ($prev and $prev->{mv_last} = 1), last ROW;
			$row->{mv_level} = $level;
			$row->{mv_spacing} = $level * $mult;
			$row->{mv_spacer} = $opt->{spacer} x $row->{mv_spacing}
				if $opt->{spacer};
			$row->{mv_increment} = $increment++;
			$row->{mv_ip} = $count++;
			push(@rows, $row);
			my $code = $row->{$keyfield};
			$row->{mv_toggled} = 1 if $memo->{$code};
#::logDebug("next row sub=$sub=$row->{$sub}");
			my $next = $row->{$sub}
				or next ROW;

			my $stop;
			$row->{mv_children} = 1
				if ($opt->{stop}		and ! $row->{ $opt->{stop} }	)
				or ($opt->{continue}	and   $row->{ $opt->{continue} })
				or ($opt->{autodetect});

			$stop = 1  if ! $explode and ! $memo->{$code};
#::logDebug("next row sub=$sub=$next stop=$stop explode=$explode memo=$memo->{$code}");

			if($above->{$next} and ($opt->{autodetect} or ! $stop) ) {
				my $fmt = <<EOF;
Endless tree detected at key %s in table %s.
Parent %s, would traverse to %s.
EOF
				my $msg = ::errmsg($fmt, $code, $table, $row->{$parent}, $next);
				if(! $opt->{pedantic}) {
					error_opt($opt, $msg);
					next ROW;
				}
				else {
					$opt->{log_error} = 1 unless $opt->{show_error};
					return error_opt($opt, $msg);
				}
			}

			my $a;
			if ($opt->{autodetect} or ! $stop) {
#::logDebug("next=$next row query=$q");
				$a = $qsub->($next);
				$above->{$next} = 1 if $a and scalar @{$a};
			}

			if($opt->{autodetect}) {
				$row->{mv_children} = $a ? scalar(@$a) : 0; 
			}

			if (! $stop) {
				push(@ary_stack, $ary);
				push(@above_stack, $above);
				push(@inc_stack, $increment);
				$level++;
				$increment = defined $outline[$level] ? $outline[$level] : 1;
				$ary = $a;
			}
		}  # END ROW
#::logDebug("last row");
	} # END ARY
	$opt->{object} = { mv_results => \@rows };
#::logDebug("last ary, results =" . ::uneval(\@rows));
	return labeled_list($opt, $text, $opt->{object});
}
EOR
