tree — display tree-like structure from database
Attribute | Pos. | Req. | Default | Description |
---|---|---|---|---|
table | Yes | Yes | None | Database table which contains the tree. |
master | Yes | Yes | None | Column which contains the parent item. |
subordinate | Yes | Yes | None | Column which serves as subordinate. |
start | Yes | None | Root item of the tree. | |
file | None | Use specified tab-seperated file instead of database table. | ||
delimiter | ||||
level_field | ||||
multiple_start | ||||
outline | ||||
spacing |
10
|
spacing per level | ||
code_field | ||||
sort | ||||
where | None | SQL where clause. | ||
memo | ||||
toggle | ||||
collapse | ||||
full | ||||
explode | ||||
spacer | ||||
stop | ||||
continue | ||||
autodetect | ||||
pedantic | ||||
log_error | ||||
show_error | ||||
object | ||||
interpolate | 0 | interpolate input? | ||
reparse | 1 | interpolate output? | ||
hide | 0 | Hide the tag return value? |
Interchange 5.9.0:
Source: code/SystemTag/tree.coretag
Lines: 299
# 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