Name

tree — display tree-like structure from database

ATTRIBUTES

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?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

tree is available in Interchange versions:

4.6.0-5.7.0 (git-head)

SOURCE

Interchange 5.7.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

AUTHORS

Interchange Development Group

SEE ALSO

menu(7ic), MV_TREE_TABLE(7ic)

DocBook! Interchange!