# 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