[gen.cgi]
--
#!/usr/local/bin/perl
use strict;
require "./webtool.pl";
require "./tree.pl";
;# constants
my $CONF = "./gen.conf";         # configuration file
my $CGI = "gen.cgi";
my ($_LITERAL, $_LIST, $_SET) = (0, 1, 2);

;# parse request
my ($raw, %decoded_data, $top, $cat);
$raw = webtool::parse_form_data(\%decoded_data);
($top) = ($decoded_data{'top'} =~ /(\d+)/);
$top = 0 if $top < 0;
$cat = $decoded_data{'cat'};
(defined $decoded_data{'name'} && $decoded_data{'name'} ne "")
 || _error("Request Error: No Request");

;# get configuration
my $count = 0;
open(CFILE, "<" . $CONF)
 || _error("File Error: Open Failed: configuration");

my ($conf_name, $conf_type, @conf_param);
tree::parse_treeroot(\*CFILE, \$conf_name, \$conf_type, \@conf_param, \$count) 
 || _error("Data Error: Violation Found: at $CONF line $count");

_error("Data Error: Not Configuration File: $CONF")
  if($conf_type != $_SET || $conf_name ne "conf");

my $conf_ref = {'*NAME*' => "conf"};
tree::parse_tree(\*CFILE, $conf_ref, \$count, @conf_param)
 || _error("Data Error: Violation Found: at $CONF line $count");

;# the following structure required:
;# conf/-+-(entry id):-+-(name of directory containing datafiles)
;#       |             +-(name of indexfile)
;#       +-...
close CFILE;

exists $conf_ref->{$decoded_data{'name'}}
 || _error("Request Error: No Entry: $decoded_data{'name'}");

my ($path, $indexfile)
    = (
       tree::element_at($conf_ref, "$decoded_data{'name'}/1"),
       tree::element_at($conf_ref, "$decoded_data{'name'}/2")
      );

;# parse index tree
$count = 0;

open(IFILE, "<" . $path . $indexfile)
 || _error("File Error: Open Failed: $path$indexfile");

my ($root_name, $root_type, @root_param);
tree::parse_treeroot(\*IFILE, \$root_name, \$root_type, \@root_param, \$count)
 || _error("Data Error: Violation Found: at $path$indexfile line $count");

_error("Data Error: Not Index File: $path$indexfile")
  if($root_type != $_SET || $root_name ne "root");

my $root_ref = {'*NAME*' => "root"};
tree::parse_tree(\*IFILE, $root_ref, \$count, @root_param)
 || _error("Data Error: Violation Found: at $path$indexfile line $count");

close IFILE;

;# the following structure required:
;# root/-+-files/   -+-(file id): ---(realname)
;#       |           +-...
;#       +-(iname)? -+-(file id)
;#       |           +-...
;#       |           +-(categoty)?-+-(file id)
;#       |           |             +-...
;#       |           |             +-(subcategory)?-+-(file id)
;#       |           |             |                +-...
;#       |           |             |                +- ... ...
;#       |           |             +-...
;#       |           +-...
;#       +-mould:   -+-(literal)
;#       |           +-...
;#       |           +-unit:      -+-(literal)
;#       |                         +-...
;#       |                         +-(id)/         -+-class:     ---reference
;#       |                         |                +-reference: ---(reference label)
;#       |                         +-...
;#       +-frame:   -+-(literal)
;#       |           +-...
;#       |           +-(id)/     ---class:        ---displayarea
;#       |           +-(id)/     ---class:        ---console
;#       |           +-...
;#       +-control/ -+-charset:  ---(charset)
;#                   +-display:  ---(number)
;#                   +-indexname:---(iname)
;#                   +-allow:    -+-(allowed element)
;#                                +-...

my $allowlist = tree::element_at($root_ref, "control/allow");
my %allowed = {};
for(my $i = 1; $i <= $#{$allowlist}; $i ++){
  $allowed{uc($allowlist->[$i])} = 1;
}
;# selects output data
my $frame_ref = tree::element_at($root_ref, "frame");
my $files_ref = tree::element_at($root_ref, "files");
my $iname = tree::element_at($root_ref, "control/indexname/");
my $indexname = $iname;
tree::escape(\$indexname);
my $selected = ($cat eq "") ?
                tree::element_at($root_ref, $indexname)
               : tree::element_at($root_ref, "$indexname/$cat");
defined($selected) || _error("Request Error: No Such Category: $decoded_data{'cat'}");
my @files = ();
my %fi = {};
_listup(\@files, \%fi, $selected);

my($datanum)
   = (tree::element_at($root_ref, "control/display/") =~ /(\d+)/);
my $n = (($#files + 1 - $top) <= $datanum)
         ? ($#files + 1 - $top) : $datanum;
my ($next_top, $prev_top) = ($top + $datanum, $top - $datanum);
my $consolestr = "<p>";
my $querybase = qq{?name=$decoded_data{'name'}\&amp\;cat=$cat\&amp\;top=};
$prev_top = 0 if($prev_top < 0 && $prev_top > -$datanum);
$consolestr .= ($prev_top >= 0)
                ? qq{<a href="./$CGI$querybase$prev_top">\&lt\;PREV|</a>}
                : "\&lt\;PREV|";
$consolestr .= ($next_top <= $#files + 1)
                ? qq{<a href="./$CGI$querybase$next_top">|NEXT\&gt\;</a>}
                : "|NEXT\&gt\;";
$consolestr .= "</p>";

my $mould_ref = tree::element_at($root_ref, "mould");
my $unit_ref = tree::element_at($mould_ref, "unit");

;# output responce header
my $charset = tree::element_at($root_ref, "control/charset/");
$charset = "iso-8859-1" if $charset eq "";
print "Content-type: text/html; charset=$charset\n\n";

;# output responce body
for(my $i = 1; $i <= $#{$frame_ref}; $i ++){
  my $elem = tree::element_at($frame_ref, $i);
  if(tree::type_of($elem) == $_LITERAL){
    print $elem . "\n";
    next;
  }

  next unless tree::type_of($elem) == $_SET;

  my $elemclass = tree::element_at($elem, "class/");
  if($elemclass eq "console"){
    print $consolestr . "\n";
  }elsif($elemclass eq "reference"){
    my $exref = tree::element_at($elem, "reference/");
    print $decoded_data{$exref};    
  }elsif($elemclass eq "displayarea"){
    ;# outout generated documents
    for(my $j = 0; $j < $n; $j ++){
    ;# generate one section
      my $dfile = $path . tree::element_at($files_ref, "$files[$j + $top]/");
      if(! open(DFILE, "<" . $dfile)){
        print "File Error: Open Failed: $dfile\n";
        next;
      }

      my($leaf_name, $leaf_type, @leaf_param);
      $count = 0;
      my $parseflag = tree::parse_treeroot(\*DFILE, \$leaf_name,\$leaf_type, \@leaf_param, \$count);
      if(! $parseflag){
        print "Data Error: Violation Found: at $dfile line $count\n";
        next;
      }

      _error("Data Error: Not Leaf File: $dfile")
      if($leaf_type != $_SET || $leaf_name ne "leaf");

      my $leaf_ref = {'*NAME*' => "leaf"};
      tree::parse_tree(\*DFILE, $leaf_ref, \$count, @leaf_param)
        || _error("Data Error: Violation Found: at $dfile line $count");
      close DFILE;
      ;# the following structure required:
      ;# leaf/-+-(id)/-+-(reference label):---(literal)
      ;#       |       +-...
      ;#       +-...

      my @leaves = keys %{$leaf_ref};

      for(my $k = 1; $k <= $#{$mould_ref}; $k ++){
        my $mouldelem = tree::element_at($mould_ref, $k);

        if(tree::type_of($mouldelem) == $_LITERAL){
          print $mouldelem . "\n";
          next;
        }

        next unless tree::name_of($mouldelem) eq "unit";

        while(my($key, $value) = each %{$leaf_ref}){
          next if $key =~ /\*/;

          for(my $m = 1; $m <= $#{$unit_ref}; $m ++){
            my $unitelem = tree::element_at($unit_ref, $m);
            if(tree::type_of($unitelem) == $_LITERAL){
              print $unitelem;
              next;
            }

            my $reference = tree::element_at($unitelem, "reference/");
            ##print tree::element_at($value, "$reference/");
            my $refdata = tree::element_at($value, "$reference/");
            my @refdata_s=();
            my @elemstack = ();
            @refdata_s = split(/</, $refdata);
            webtool::sanitize(\$refdata_s[0]);
            print $refdata_s[0];
            for(my $nn = 1; $nn <= $#refdata_s; $nn ++){
              my($data_elem, $data_elem2) = ($refdata_s[$nn] =~ m{^\s*([^\s>]*)\s*(.*)$});
              my($ts, $ts2, $ts3, $ts4, $ts5);
              if($data_elem =~ m{^/}){
                if($data_elem eq "/"){
                  ($ts, $ts2) = ($data_elem2 =~ /^([^\s>]*)\s*(.*)$/);
                }else{
                  $ts = substr($data_elem, 1);
                  $ts2 = $data_elem2;
                }
                $ts3 = pop(@elemstack);
                if(uc($ts) eq $ts3){
                  ($ts4, $ts5) = ($ts2 =~ /^([^>]*)>(.*)$/);
                  webtool::sanitize(\$ts5);
                  print "</" . $ts . $ts4 .">". $ts5;
                }else{
                  webtool::sanitize(\$ts2);
                  webtool::sanitize(\$ts);
                  print "\&lt\;/" . $ts . $ts2;
                  push(@elemstack, $ts3);
                }
                next;
              }

              if($allowed{uc($data_elem)}){
                if(uc($data_elem) eq "A"){
                  if($data_elem2 =~ /^href=\"[^\"]+\"\s*>/){
                    ($ts, $ts2) = ($data_elem2 =~ /^href=\"([^\"]+)\"\s*>(.*)$/);
###
                    if($ts =~ /:/){
                      if($ts =~ /^([^:]+):(.*)/){
                        ($ts3, $ts4) = ($ts =~ /^([^:]+):(.*)$/);
                        if((($ts3 eq "http" || $ts3 eq "https" || $ts3 eq "ftp") &&  $ts4 =~ m{//[\d\w\-\./~\+\?\#\%\&\;]+$}) ||
                           ($ts3 eq "mailto" && $ts4 =~ m{^[\d\w\-]+\@[\w\-\.\d]+$}) ||
                           ($ts3 eq "mailto" && $ts4 =~ m{^[\d\w\-]+$})){

                          webtool::sanitize(\$ts2);
                          print "<" . $data_elem . q{ href="}.$ts3.":".$ts4 . q{">}. $ts2;
                          push(@elemstack, uc($data_elem));
                          next;
                        }
                      }
                    }
                  }
                }elsif(uc($data_elem) eq "BR"){
                  if($data_elem2 =~ m{^/>}){
                    $ts =  substr($data_elem2, 2);
                    webtool::sanitize(\$ts);
                    print "<" . $data_elem . " />" . $ts;
                    next;
                  }
                }else{
                  if($data_elem2 =~ />/){
                    ($ts, $ts2) = ($data_elem2 =~ /^([^>]*)>(.*)$/);
                    webtool::sanitize(\$ts2);
                    print "<" . $data_elem . " " . $ts . ">". $ts2;
                    push(@elemstack, uc($data_elem));
                    next;
                  }
                }
              }
              webtool::sanitize(\$refdata_s[$nn]);
              print "\&lt\;" . $refdata_s[$nn];
            }
          }
        }
      }
    }
  }
}

exit(0);

sub _error{
  my($errmes) = @_;
  print "Content-type: text/plain; charset=iso-8859-1\n\n";
  print $errmes;
  exit(0);
}

sub _listup{
  my($arrayref, $hashref, $treeref) = @_;
  if(tree::type_of($treeref) == $_LIST){
    for(my $i = 1; $i <= $#{$treeref}; $i ++){
      if(tree::type_of($treeref->[$i]) == $_LITERAL){
        if(! exists($hashref->{$treeref->[$i]})){
          push(@{$arrayref}, $treeref->[$i]);
          $hashref->{$treeref->[$i]} = 1;
        }
        next;
      }

      _listup($arrayref, $hashref, $treeref->[$i]);
    }
  }elsif(tree::type_of($treeref) == $_SET){
    while(my($key, $value) = each %{$treeref}){
      next if $key =~ /\*/;

      _listup($arrayref, $hashref, $value);
    }
  }
}
--
Copyright (C) Junro YOSHINO <yoshinok@muf.biglobe.ne.jp>