code/SystemTag/tree.coretag

   1 # Copyright 2002-2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: tree.coretag,v 1.12 2007-07-18 00:16:26 jon Exp $
   9
  10 UserTag tree                Order        table master subordinate start
  11 UserTag tree                addAttr
  12 UserTag tree                attrAlias    sub subordinate
  13 UserTag tree                hasEndTag
  14 UserTag tree                Version      $Revision: 1.12 $
  15 UserTag tree                Routine      <<EOR
  16 sub {
  17         my($table, $parent, $sub, $start_item, $opt, $text) = @_;
  18
  19 #::logDebug("tree-list: received parent=$parent sub=$sub start=$start_item");
  20
  21         my $nodb;
  22         my @passed;
  23         my @start;
  24         if($opt->{file}) {
  25                 my $delim = $opt->{delimiter} || "\t";
  26                 my $s = $opt->{subordinate} || 'code';
  27                 my $l = $opt->{level_field} || 'msort';
  28                 $delim = qr/$delim/;
  29                 my @lines = split /\n/, readfile($opt->{file});
  30                 my $hdr = shift @lines;
  31                 my @fields = split $delim, $hdr;
  32                 my $i = 1;
  33                 for(@lines) {
  34                         my $ref = {};
  35                         @{$ref}{@fields} = split $delim, $_;
  36                         $ref->{$s} = $i++;
  37                         push @passed, $ref;
  38                         push @start, $ref if $ref->{$l} == 0;
  39                 }
  40                 $nodb = 1;
  41         }
  42         my $db;
  43
  44         unless($nodb) {
  45                 $db = ::database_exists_ref($table)
  46                         or return error_opt($opt, "Database %s doesn't exist", $table);
  47                 $db->column_exists($parent)
  48                         or return error_opt($opt, "Parent column %s doesn't exist", $parent);
  49                 $db->column_exists($sub)
  50                         or return error_opt($opt, "Subordinate column %s doesn't exist", $sub);
  51         }
  52
  53         my $basewhere;
  54
  55         WHEREBASE: {
  56                 my @keys;
  57                 my @things;
  58                 if($opt->{multiple_start}) {
  59                         @keys = split /[\0,\s]+/, $start_item;
  60                 }
  61                 else {
  62                         @keys = $start_item;
  63                 }
  64
  65                 unless($nodb) {
  66                         for(@keys) {
  67                                 push @things, "$parent = " . $db->quote($_, $parent);
  68                         }
  69                 }
  70                 $basewhere = join " OR ", @things;
  71         }
  72
  73         my @outline = (1);
  74         if(defined $opt->{outline}) {
  75                 $opt->{outline} =~ s/[^a-zA-Z0-9]+//g;
  76                 @outline = split //, $opt->{outline};
  77                 @outline = (qw/1 A 1 a 1 a/) if scalar @outline < 2;
  78         }
  79
  80         my $mult = ( int($opt->{spacing}) || 10 );
  81         my $keyfield;
  82         $keyfield = $db->config('KEY') unless $nodb;
  83         $opt->{code_field} = $keyfield if ! $opt->{code_field};
  84
  85         my $sort = '';
  86         if($opt->{sort}) {
  87                 $sort .= ' ';
  88                 $sort .= 'ORDER BY '
  89                         unless $opt->{sort} =~ /^\s*order\s+by\s+/i;
  90                 my @sort;
  91                 @sort = ref $opt->{sort}
  92                                 ?  @{$opt->{sort}}
  93                                 : ( $opt->{sort} );
  94                 for(@sort) {
  95                         s/\s*[=:]\s*([rnxf]).*//;
  96                         $_ .= " DESC" if $1 eq 'r';
  97                 }
  98                 $sort .= join ", ", @sort;
  99                 undef $opt->{sort};
 100         }
 101
 102         my $where = '';
 103         unless($nodb) {
 104                 if( my $f = $db->config('HIDE_FIELD')) {
 105                         $where .= " AND $f <> 1";
 106                 }
 107         }
 108
 109         if($opt->{where}) {
 110                 $where .= " AND ($opt->{where})";
 111         }
 112
 113         my $qb = "SELECT * FROM $table WHERE $basewhere$where$sort";
 114 #::logDebug("tree tag initial query=$qb");
 115
 116         my $ary;
 117         if($nodb) {
 118                 $ary = \@start;
 119         }
 120         else {
 121                 $ary = $db->query( {
 122                                                         hashref => 1,
 123                                                         sql => $qb,
 124                                                         });
 125         }
 126
 127         my $memo;
 128         if( $opt->{memo} ) {
 129                 $memo = ($::Scratch->{$opt->{memo}} ||= {});
 130                 my $toggle;
 131                 if($opt->{toggle} and $toggle = $CGI::values{$opt->{toggle}}) {
 132                         $memo->{$toggle} = ! $memo->{$toggle};
 133                 }
 134         }
 135
 136         if($opt->{collapse} and $CGI::values{$opt->{collapse}}) {
 137                 $memo = {};
 138                 delete $::Scratch->{$opt->{memo}} if $opt->{memo};
 139         }
 140
 141         my $explode;
 142         if($opt->{full} or $opt->{explode} and $CGI::values{$opt->{explode}}) {
 143                 $explode = 1;
 144         }
 145
 146         my $enable;
 147
 148         my $qsub;
 149
 150         my $donemsg;
 151         my $dbh;
 152         $dbh = $db->dbh() unless $nodb;
 153
 154         my $qs_query = "SELECT * FROM $table WHERE $parent = ?$where$sort";
 155         if($nodb) {
 156                 my $l = $opt->{level_field} || 'msort';
 157 #::logDebug("setting up nodb qsub level=$l");
 158                 $qsub = sub {
 159                         my $key = shift;
 160 #::logDebug("Looking for key=$key");
 161                         return if $key < 1;
 162                         my $base = $passed[$key - 1]->{$l} + 1;
 163 #::logDebug("Base level=$base, firstone = $passed[$key]{$l}");
 164                         my @out;
 165                         for(my $i = $key; $passed[$i]{$l} >= $base ; $i++ ) {
 166                                 push @out, $passed[$i] if $passed[$i]{$l} == $base;
 167                         }
 168                         return unless @out;
 169                         return \@out;
 170                 };
 171         }
 172         elsif($dbh and $db->config('Class') eq 'DBI') {
 173                 my $sth = $dbh->prepare($qs_query)
 174                                 or die errmsg(
 175                                                 "tree failed to prepare query: %s\nError was: %s",
 176                                                 $qs_query,
 177                                                 $DBI::errstr,
 178                                                 );
 179                 $qsub = sub {
 180 #::logDebug("executing query sub DBI style"); # while ! $donemsg++;
 181                         my $parm = shift;
 182                         my @ary;
 183                         $sth->execute($parm)
 184                                 or die errmsg(
 185                                                 "tree failed to prepare query for '%s': %s\nError was: %s",
 186                                                 $parm,
 187                                                 $qs_query,
 188                                                 $DBI::errstr,
 189                                                 );
 190                         while(my $ref = $sth->fetchrow_hashref()) {
 191                                 push @ary, { %$ref };
 192                         }
 193                         return unless @ary;
 194                         return \@ary;
 195                 };
 196         }
 197         else {
 198                 $qsub = sub {
 199                         my $parm = shift;
 200 #::logDebug("executing query sub regular style"); # while ! $donemsg++;
 201                         $parm = $db->quote($parm, $parent);
 202                         my $q = $qs_query;
 203                         $q =~ s/\s\?\s/ $parm /;
 204                         $db->query( { hashref => 1, sql => $q });
 205                 };
 206         }
 207
 208
 209         $memo = {} if ! $memo;
 210
 211         my $count = 0;
 212
 213         my $stop_sub;
 214
 215 #::logDebug("tree-list: valid parent=$parent sub=$sub start=$start_item mult=$mult");
 216
 217         my @ary_stack   = ( $ary );                             # Stacks the rows
 218         my @above_stack = { $start_item => 1 }; # Holds the previous levels
 219         my @inc_stack   = ($outline[0]);                # Holds the increment characters
 220         my @rows;
 221         my $row;
 222
 223         ARY: for (;;) {
 224 #::logDebug("next ary");
 225                 my $ary = pop(@ary_stack)
 226                         or last ARY;
 227                 my $above = pop(@above_stack);
 228                 my $level = scalar(@ary_stack);
 229                 my $increment = pop(@inc_stack);
 230                 ROW: for(;;) {
 231 #::logDebug("next row level=$level increment=$increment");
 232                         my $prev = $row;
 233                         $row = shift @$ary
 234                                 or ($prev and $prev->{mv_last} = 1), last ROW;
 235                         $row->{mv_level} = $level;
 236                         $row->{mv_spacing} = $level * $mult;
 237                         $row->{mv_spacer} = $opt->{spacer} x $row->{mv_spacing}
 238                                 if $opt->{spacer};
 239                         $row->{mv_increment} = $increment++;
 240                         $row->{mv_ip} = $count++;
 241                         push(@rows, $row);
 242                         my $code = $row->{$keyfield};
 243                         $row->{mv_toggled} = 1 if $memo->{$code};
 244 #::logDebug("next row sub=$sub=$row->{$sub}");
 245                         my $next = $row->{$sub}
 246                                 or next ROW;
 247
 248                         my $stop;
 249                         $row->{mv_children} = 1
 250                                 if ($opt->{stop}                and ! $row->{ $opt->{stop} }    )
 251                                 or ($opt->{continue}    and   $row->{ $opt->{continue} })
 252                                 or ($opt->{autodetect});
 253
 254                         $stop = 1  if ! $explode and ! $memo->{$code};
 255 #::logDebug("next row sub=$sub=$next stop=$stop explode=$explode memo=$memo->{$code}");
 256
 257                         if($above->{$next} and ($opt->{autodetect} or ! $stop) ) {
 258                                 my $fmt = <<EOF;
 259 Endless tree detected at key %s in table %s.
 260 Parent %s, would traverse to %s.
 261 EOF
 262                                 my $msg = ::errmsg($fmt, $code, $table, $row->{$parent}, $next);
 263                                 if(! $opt->{pedantic}) {
 264                                         error_opt($opt, $msg);
 265                                         next ROW;
 266                                 }
 267                                 else {
 268                                         $opt->{log_error} = 1 unless $opt->{show_error};
 269                                         return error_opt($opt, $msg);
 270                                 }
 271                         }
 272
 273                         my $a;
 274                         if ($opt->{autodetect} or ! $stop) {
 275 #::logDebug("next=$next row query=$q");
 276                                 $a = $qsub->($next);
 277                                 $above->{$next} = 1 if $a and scalar @{$a};
 278                         }
 279
 280                         if($opt->{autodetect}) {
 281                                 $row->{mv_children} = $a ? scalar(@$a) : 0;
 282                         }
 283
 284                         if (! $stop) {
 285                                 push(@ary_stack, $ary);
 286                                 push(@above_stack, $above);
 287                                 push(@inc_stack, $increment);
 288                                 $level++;
 289                                 $increment = defined $outline[$level] ? $outline[$level] : 1;
 290                                 $ary = $a;
 291                         }
 292                 }  # END ROW
 293 #::logDebug("last row");
 294         } # END ARY
 295         $opt->{object} = { mv_results => \@rows };
 296 #::logDebug("last ary, results =" . ::uneval(\@rows));
 297         return labeled_list($opt, $text, $opt->{object});
 298 }
 299 EOR