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

UserTag tree                Order        table master subordinate start
UserTag tree                addAttr
UserTag tree                attrAlias    sub subordinate
UserTag tree                hasEndTag
UserTag tree                Version      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