Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

300 lines (265 sloc) 7.639 kb
# 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
Jump to Line
Something went wrong with that request. Please try again.