#!/usr/bin/perl -w

#
# LivingXML IVI Database
#
# (c) in 2002 by Philipp Ghring
#
# Available under the GNU GPL License.
#

use strict;

#use MIME::Parser;
use File::CounterFile;
use CGI qw(:standard :cgi-lib);
use XML::Sablotron qw( :all );
use XML::Sablotron::DOM qw( :constants :functions );
use File::Path;

#
# Stage 1: Prerequisite stuff ...
#

my $db="./db";

if (! -w "$db")
{
  mkdir "$db",0777;
}

my $res="";
my $result="";
my %in;
CGI::ReadParse(\%in);

my $path=""; $path=$1 if ($in{_path} && $in{_path} =~ m/([\w\/\. ]+)/); $path =~s{\.\.}{}g; $in{_path}=$path;

my $parent=$path; $parent=~ s/\/[^\/]*\/?$//;


print STDERR "Path: $path\n";

# my @parameter;
# @parameter=%in;

# my $max=1;
undef $/;




#
# Internal Functions
#

sub analyze
{
  return "" if(! defined $_[1]);
  # print "$_[1]\n";

  my $typ=$_[1]->getNodeType($_[0]);
  # print "Typ: $typ\n";

  return $_[1]->getNodeValue($_[0]) if($typ eq TEXT_NODE);

  my $type=$_[1]->getNodeName($_[0]);
  # print "Analysiere: $type:\n";

  my $erg="";

  my $array = $_[1]->getChildNodes($_[0]);
  foreach my $node (@$array)
  {
    $erg.=analyze($_[0],$node,$_[2],$_[3]);
  }
  if ($type eq "lowercase")
  {
    $erg=lc $erg;
  }
  elsif ($type eq "soundex")
  {
    $erg=soundex($erg);
  }
  elsif ($type =~ m/^(source|destination|parameter|root|normal|number)$/)
  {
    # do nothing
  }
  elsif ($type eq "index")
  {
    my $source=$_[3]."/".analyze($_[0],$_[1]->getFirstChild($_[0]),"","");
    my $destination=analyze($_[0],$_[1]->getLastChild($_[0]),"","");

    print STDERR "$_[2] $source -> $destination\n";
    symlink $destination,$source if($_[2] eq "symlink");
#    unlink $source if($_[2] eq "unlink");
  }
  elsif ($type eq "#text")
  {
    $erg=$_[1]->getNodeValue($_[0]);
  }
  else
  {
    print STDERR "Typ nicht erkannt: $type\n";
  }
  $erg;
}

sub analyzesearch
{
  return "" if(! defined $_[1]);
   print "$_[1]\n";

  my $typ=$_[1]->getNodeType($_[0]);
  # print "Typ: $typ\n";

  return $_[1]->getNodeValue($_[0]) if($typ eq TEXT_NODE);

  my $type=$_[1]->getNodeName($_[0]);
  # print "Analysiere: $type:\n";

  my $erg="";

  my $array = $_[1]->getChildNodes($_[0]);
  foreach my $node (@$array)
  {
    $erg.=analyzesearch($_[0],$node);
  }

  if ($type eq "lowercase")
  {
    $erg=lc $erg;
  }
  elsif ($type eq "soundex")
  {
    $erg=soundex($erg);
  }
  elsif ($type =~ m/^(source|parameter|root|normal|number)$/)
  {
    # do nothing
  }
  elsif ($type eq "index")
  {
    $erg=analyzesearch($_[0],$_[1]->getFirstChild($_[0]),"","");
  }
  elsif ($type eq "#text")
  {
    $erg=$_[1]->getNodeValue($_[0]);
  }
  elsif ($type eq "xsl:value-of")
  {
    my $select=$_[1]->getAttribute("select",$_[0]);
    if($select eq '$id')
    { 
      $erg="*";
    }
    else
    {
      $erg=$in{$select};
      print STDERR "select: $select => $erg\n";
    }
  }
  elsif ($type eq "destination")
  {
    $erg="";
  }
  else
  {
    print STDERR "Typ nicht erkannt: -$type-\n";
  }
  $erg;
}

sub processindex
{
  print STDERR "Processing Index $_[0] ...\n";
  my $name=$_[0]; $name=~s{/*$}{}; $name=~s{^.*/}{};
  my $base=$_[0]; $base=~s{/*$}{}; $base=~s{\.[^/]*?$}{};
 
  print STDERR "base=$base name=$name\n";
 
  my $style= <<EOF
<?xml version='1.0' encoding='iso-8859-1'?>
<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
  <xsl:output method="xml" encoding="utf-8" omit-xml-declaration="yes"/>
  <xsl:param name="id"/>
<xsl:template match="/root">
EOF
;

  open IN,"<$_[0]/.index.xml";
  $style.=<IN>;
  close IN;
  $style.="</xsl:template></xsl:stylesheet>";

#  print "Style:\n$style\n\n\n";


  if($_[2])
  {
    my @parameter;
    push @parameter,"id",$_[1];

    my $content="<root>".$_[2]."</root>";
    my $res=""; my $result="";
    $res = XML::Sablotron::Process("arg:/style", "arg:/data", "arg:/result", \@parameter, [data=>$content,style=>$style],$result);

    if ($result)
    {
      print STDERR "Got result.\n";
      my $sit = new XML::Sablotron::Situation();
      my $doc = XML::Sablotron::DOM::parseBuffer($sit, $result);
      analyze ($sit,$doc->getFirstChild($sit),$_[3],$_[0]);
    }
  }
  else
  {
    foreach my $file (<$base/*>)
    {
      my $id=$file; $id=~s{$base/}{};
      my @parameter;
      # @parameter=%in;
      push @parameter,"id",$id;

      my $res=""; my $result="";

      my $content="<root>";
      open IN,"<$file";
      $content.=<IN>;
      close IN;
      $content.="</root>";

      print STDERR "Processing file $file\n";
 
      #print "Vorher:\n$content\n\n\n";
  
      $res = XML::Sablotron::Process("arg:/style", "arg:/data", "arg:/result", \@parameter, [data=>$content,style=>$style],$result);
  
      #print "Nachher:\n-$result-\n\n\n";
  
      if ($result)
      {
        my $sit = new XML::Sablotron::Situation();
        my $doc = XML::Sablotron::DOM::parseBuffer($sit, $result);
        analyze ($sit,$doc->getFirstChild($sit),"symlink",$_[0]);
      }
    }
  }


}


sub searchforindexdir
{
  if (-d $_[0])
  {
    my $name=$_[0]; $name=~s{/*$}{}; $name=~s{^.*/}{};
    if ($name =~ m/\./)
    {
      if(-r "$_[0]/.index.xml")
      {
        print STDERR "Processing rule for $_[0]\n";
        processindex($_[0],$_[1],$_[2],$_[3]);
      }
      else
      {
        print STDERR "No rule found for $_[0]!\n";
      }
    }
    else
    {
      foreach my $sub (<$_[0]/*>)
      {
        searchforindexdir($sub);
      }
    }
  }
  else
  {
    print STDERR "Table not found\n";
  }
}







#
# Stage 2: Parsing Request, generating XML result
#

my $content= <<EOF
<?xml version="1.0" encoding="utf-8"?>
<ivi:response xmlns:ivi="http://livingxml.net/2002/ivi" xmlns:xlink="http://www.w3.org/1999/xlink">
EOF
;

# xmlns:xql="http://metalab.unc.edu/xql/"

if ($in{_define}) # Define before anything else, so that the created table can be already used with the other commands
{
  if ($in{_table} && -d "$db/$path/$in{_table}")
  {
    mkdir "db/$path/$in{_table}.$in{_define}",0777;
    $path="$path/$in{_table}.$in{_define}"; # So that _form can do its job
    $content .= "<ivi:message>Index successfully created</ivi:message>";
  }
  elsif (! -w "$db/$path/$in{_define}")
  {
    if (mkdir "$db/$path/$in{_define}",0777)
    {
      $content .= "<ivi:message>Table successfully created</ivi:message>";
    }
    else
    {
      $content .= "<ivi:error>Table could not be created: $!</ivi:error>";
    }
  }
}

if($in{_xql} || $in{_index})
{
  my $xql=$in{_xql};

  if($in{_index})
  {
    print STDERR "Searching for Index:\n";
    undef $/;
    my $style="<root xmlns:xsl=\"http://www.w3.org/1999/XSL/Transform\">";
    open IN,"<$db/$path/.index.xml";
    $style.=<IN>;
    close IN;
    $style.="</root>";
    print STDERR "$style\n";

    my $sit = new XML::Sablotron::Situation();
    my $doc = XML::Sablotron::DOM::parseBuffer($sit, $style);
    $xql= analyzesearch ($sit,$doc->getFirstChild($sit));
    print STDERR "xql: $xql\n";
  }

  $content .= "<ivi:result xql=\"$xql\" parent=\"$parent\">";

  my $count=0;
  foreach my $file (<$db/$path/$xql>)
  {
    last if($in{_max} && ++$count >$in{_max});

    print STDERR "$file\n";
    open IN,"<$file";
    undef $/;
    my $id=$file; $id =~ s{^$db/?}{}; $id =~ s{^$path/?}{}; $file =~ s{^$db/?}{};
    $content.="<ivi:data id=\"$id\" path=\"$file\">";
    $content.=<IN>;
    $content.="</ivi:data>";
    close IN;
  } 




#opendir(DIR,$db) or die "Konnte Verzeichnis $db nicht ffnen: $!";
#while (defined($f=readdir(DIR)))
#{
#  next if $f =~ /^\.\.?$/;
#
#  print LOG "$f\n";
#  my $b=$f; my $a="$db/$f";
#
#  open IN,"<$a" or die "$!";
#  undef $/;
#  $content=<IN>;
#  close IN;
#  if ($content =~ m/<ie([^>]*)>(.*?)<\/ie>/s)
#  {
#    my ($arg,$akt)=($1,$2);
#
#    symlink "../ie/$b", "db/$user/ind_type/$1\_$b" if ($arg =~ m/type=\"(\w+)\"/);
#    symlink "../ie/$b", "db/$user/ind_creator/$1\_$b" if ($akt =~ m/<creator[^>]+id=\"(\d+)"/);
#  }
#}
#
#closedir DIR;



  $content .= "</ivi:result>";
}
elsif ($in{_process} || $in{_form}) # INSERT INTO TABLE ...
{
  my $process; 
  $process=$in{_process};

  # Handling FORM parameters

  if($in{_form})
  {
    my @parameter;
    @parameter=%in;
    my $mycontent="<root>\n";
    foreach my $key (keys %in)
    {
      if (not $key =~ m{^_}) 
      {
        my $value=$in{$key}; $value=~s/\x00//g;
        $mycontent.="<param name=\"$key\">".$value."</param>";
      }
    }
    $mycontent.="</root>\n";
    open ERRLOG,">errlog";
    print ERRLOG $mycontent;
    close ERRLOG;
    $res = Process($in{_form}, "arg:/data", "arg:/result", \@parameter, [data=>$mycontent],$result);
    print STDERR "Crash\n";
    print STDERR "$result\n";
    $process=$result;
  }

  # Generating ID

  my $id=$in{_id};

  if(-f "$db/$path")
  {
    $path =~ m{^(.*/)(.*?)$}; $path=$1; $id=$2;
  }
  elsif (-d "$db/$path")
  {
    if($in{_id}) # Wir haben eine ID zugewiesen bekommen
    {
      $id=$in{_id};
    }
    else # Wir mssen eine neue ID generieren
    {
      $id = (new File::CounterFile "$db/$path/.counter", "1")->inc;
    }
  }
  else
  {
    print STDERR "Could not generate a ID for ($path):\n";
    print STDERR $in{_process};
    $content.="<ivi:error>Could not generate ID</ivi:error>";
  }

  # Writing Data

  if(open OUT,">$db/$path/$id")
  {
    print OUT $process;
    close OUT;
    $content.="<ivi:object path=\"$path/$id\" id=\"$id\"/>\n";
  }
  elsif(! -w "$db/$path" || ! -w "$db/$path/$id")
  {
    $content.="<ivi:error>No write permission on database!</ivi:error>";
  }
  else
  {
    $content.="<ivi:error>Could not write file: $path!</ivi:error>";
  }


  # Creating Index
  my $name="$db/$path"; $name=~s{/*$}{}; 
  foreach(<$name.*>)
  {
    print STDERR "processindex($_,$id,$process,\"symlink\");";
    processindex($_,$id,$process,"symlink"); 
  }


  print STDERR "Looking for newly generated index:\n";
  if($id eq ".index.xml")
  {
    print STDERR "New Index found.\n";
    print STDERR "processindex($db/$path,,,symlink);\n";
    processindex("$db/$path","","","symlink");
    $content .= "<ivi:message>Index successfully filled</ivi:message>";  
  }

}
elsif ($in{_drop}) 
{
  if (-d "$db/$path/$in{_drop}")
  {
    if (-w "$db/$path/$in{_drop}")
    {
      if(<$db/$path/$in{_drop}/*>)
      {
        $content .= "<ivi:error>Table not empty! Please remove contents first.</ivi:error>";
      }
      else
      {
       if(rmtree "$db/$path/$in{_drop}")
        {$content .= "<ivi:message>Table successfully dropped</ivi:message>";}
        else
        {$content .= "<ivi:error>$!</ivi:error>";}
      }
    }
    else
    {
      $content.="<ivi:error>No permission to drop table!</ivi:error>";
    }
  }
  elsif (-f "$db/$path/$in{_drop}")
  {
    if (-w "$db/$path/$in{_drop}")
    {
      unlink "$db/$path/$in{_drop}";
      $content .= "<ivi:message>XML successfully dropped</ivi:message>";
    }
    else
    {
      $content.="<ivi:error>No permission to drop XML!</ivi:error>";
    }
  }
  else
  {
    $content.="<ivi:error>What should I drop? Object does not exist (anymore?).</ivi:error>";
  }
}
elsif ($in{_diagnose})
{
  my $diag=$in{_diagnose};
  if ($diag eq 'version' or $diag eq 'all')
  {
    $content.= "<version>LivingXML IVI DB 0.5</version>\n";
  }

  if($diag eq 'ping' or $diag eq 'all')
  { 
    $content.= "<pong/>";
  }
  if ($diag eq 'echo' or $diag eq 'all')
  {
    $content.="<environment>";
    foreach my $key (keys %ENV)
    {
      $content.= "<$key>$ENV{$key}</$key>\n";
    }
    $content.="</environment>";
  }
}
else
{
 
  # Default: Give Directory Listings and Help

  if(-d "$db/$path")
  {
    my $parent=$path; $parent=~ s/\/[^\/]*\/?$//;

    if(open IN,"<$db/$path/.index.xml")
    {
      $content.="<ivi:index xmlns:xsl=\"http://www.w3.org/1999/XSL/Transform\">";
      $content.=<IN>;
      $content.="</ivi:index>";
      close IN;
    }

    $content.="<ivi:listing path=\"$path\" parent=\"$parent\">";

    foreach my $f (<$db/$path/*>)
    {
      my $fn=$f; $fn =~ s/^$db\///; 
      my $fn2=$f; $fn2 =~ s{.*/}{};
      if(-f $f)
      {
        if(-l $f)
        {
          $content.="<link xlink:type=\"simple\" xlink:href=\"$fn\">$fn2</link>\n";
        }
        else
        {
          $content.="<xml xlink:type=\"simple\" xlink:href=\"$fn\">$fn2</xml>\n";
        }
      }
      elsif(-d $f)
      {
        if(-l $f)
        {
          $content.="<link xlink:type=\"simple\" xlink:href=\"$fn\">$fn2</link>\n";
        }
        else
        {
          if (-f "$f/.index.xml")
          {
            $content.="<index xlink:type=\"simple\" xlink:href=\"$fn\">$fn2</index>\n";
          }
          elsif (-f "$f/.style.xsl")
          {
            $content.="<styledir xlink:type=\"simple\" xlink:href=\"$fn\">$fn2</styledir>\n";
          }
          else
          {
            $content.="<table xlink:type=\"simple\" xlink:href=\"$fn\">$fn2</table>\n";
          }
        }
      }
      elsif(-l $f)
      {
        $content.="<broken>$fn2</broken>\n";
      }
    }
    $content.="</ivi:listing>";
  }
  if(-f "$db/$path")
  {
    $content .= "<ivi:result>";

    my $file="$db/$path";
    {
      print STDERR "$file\n";
      open IN,"<$file";
      undef $/;

      my $id=$file; $id =~ s{^.*/}{}; $file=~ s{^$db/?}{};
      $content.="<ivi:data id=\"$id\" path=\"$file\">";
      $content.=<IN>;
      $content.="</ivi:data>";

      close IN;
    } 
 
    $content .= "</ivi:result>";
  }
  $content.= <<EOF
<ivi:available>
<command><name>_xql</name><description>Query the database</description></command>
<command><name>_process</name><description>Process new XML into the database</description></command>
<parameter><name>_id</name><description>Tells _process which primary key ID to use. If empty, new key will be generated.</description></parameter>
<command><name>_form</name><description>Process new HTML Form data into the database</description></command>
<command><name>_define</name><description>Creates a new table or index</description></command>
<command><name>_diagnose</name><description>Diagnose functions</description></command>
<parameter><name>_style</name><description>Defines, which stylesheet should be used. Suggested value: <a href=\"ivi?_style=file://ivi.xsl\">file://ivi.xsl</a></description></parameter>
<parameter><name>_path</name><description>Parameter, which Table to work on. Subtables are appended with '/'</description></parameter>

</ivi:available>
EOF
;

}

$content.="</ivi:response>";


#
# Stage 3: Running a Stylesheet over the XML Result if needed
#

if ($in{_style}) # Lets run a stylesheet over it!
{
  my @parameter;
  @parameter=%in;
  #print STDERR "$content\n";
  $content =~s/\x00//g;
  $res = Process($in{_style}, "arg:/data", "arg:/result", \@parameter, [data=>$content],$result);
  print "Content-type: text/html; charset=utf-8\n\n";
  print $result;
  print $content if(! $result);

}
else # Lets return the results directly!
{
  print "Content-type: text/xml; charset=utf-8\n\n";

  print $content;
}

#
# We are done!
#

