# 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