#!/usr/bin/perl

#################################################################################################
#################################################################################################
#################################################################################################
#
#  H.X.S.P.    V 1.0
#  T S T R
#  T L Y O
#  P T E C
#      S E
#      H S
#      E S
#      E O
#      T R
#
#################################################################################################
#################################################################################################
#################################################################################################

use HTTP::Daemon;
use HTTP::Status;
use HTTP::Request;
use LWP::UserAgent;
use URI::Escape;
use CGI;
use FindBin;
use XML::LibXML;
use XML::LibXSLT;
use IO;

#################################################################################################
#################################################################################################
#################################################################################################
# Global Variables
#################################################################################################
#################################################################################################
#################################################################################################

# Version number
my $ver ="1.0";

# Working path of hxsp (loaded from config)
my $working_path;

# Interface language (loaded from config)
my $language;

# Port to use for hxsp (loaded from config)
my $port;

# Use complete command description on syntax error if ON (loaded from config)
my $all_usage_synerr;

# Include XIncludes on the fly if ON (loaded from config)
my $expand_xinc;

# Max Depth of the DOM tree while parsing
my $max_depth;

# Message sent when hxsp was called without commands (loaded from message.##)
my $home_message;

# Message sent when hxsp was called with the help command (loaded from message.##)
my $help_message;

# Message sent when a stylesheet is added (loaded from message.##)
my $s_add;

# Message sent when a stylesheet is reloaded (loaded from message.##)
my $s_reload;

# Message sent when a stylesheet is removed (loaded from message.##)
my $s_remove;

# Message to print the stylesheet status for list command (loaded from message.##)
my $list;

# Message sent when the list command was called
# and there is no stylesheet loaded (loaded from message.##)
my $empty;

# Message sent after "home_message" when hxsp was called without commands
# and sent after "help_message" when hxsp was called with the help command
# and after all syntax errors if "all_usage_synerr" is set ON (loaded from message.##)
my $all_usage;

# All the following syntax errors messages are used #only# if "all_usage_synerr" is set OFF

# Message sent on help syntax errors (loaded from message.##)
my $help_usage;

# Message sent on add syntax errors (loaded from message.##)
my $add_usage;

# Message sent on remove syntax errors (loaded from message.##)
my $remove_usage;

# Message sent on list syntax errors (loaded from message.##)
my $list_usage;

# Message sent on reload syntax errors (loaded from message.##)
my $reload_usage;

# Message sent on apply syntax errors (loaded from message.##)
my $apply_usage;

# The error hash contains the error messages to call in case of syntax
# or operative errors, the keys are defined by the left value of each line in error##
my %error;

# load ok template
my $ok_tpl;

# load operror template
my $operror_tpl;

# load synerror template
my $synerror_tpl;

# This is the data structure to store the loaded stylesheets (hash of array)
# [0] :Styleseet URI , [1] : Loaded styleseet
my %stylesheet_hash;

# This is a hash for fast duplicate uri detection
my %by_name;

#################################################################################################
#################################################################################################
#################################################################################################
# Starting Operations
#################################################################################################
#################################################################################################
#################################################################################################

# chdir to the directory of this perl script
chdir $FindBin::Bin;

# load CONFIG
load_conf();

# initialize the objects to use LibXML and LibXSLT
my $parser = XML::LibXML->new();
my $xslt = XML::LibXSLT->new();

# initialize the LibXML callbacks to load uri's
XML::LibXML->callbacks(\&match_uri,\&open_uri,\&read_uri,\&close_uri);

# include XIncludes on the fly if required
if ($expand_xinc eq "ON") { $parser->expand_xinclude( 1 ); }

# initialize the hxsp as HTTP::Daemon
my $d = new HTTP::Daemon LocalPort => $port;

# get the complete working url of hxsp
my $puwobo_url = $d->url().$working_path;

# set the working path to be comparable with url->path
$working_path = "/". $working_path;

# load messages
load_messages();

# load error
load_err();

# load templates
load_templates();

# print starting information on console
print qq{
hxsp v$ver active at: <URL:$puwobo_url>
   Language is $language
   On syntax error usage of every command is $all_usage_synerr
   Include XIncludes on the fly is $expand_xinc;
};

#################################################################################################
#################################################################################################
# HTTP::Daemon Operations
#################################################################################################
#################################################################################################

# do not accumulate defunct processes
$SIG{CHLD} = "IGNORE";
$SIG{USR1} = \&listen; # sent by the child to make the parent read the pipe

pipe LIST_CHILD, TELL_PARENT;
pipe LIST_PARENT, TELL_CHILD;
TELL_PARENT->autoflush(1);
TELL_CHILD->autoflush(1);


sub listen {
   my $res;
   my $query = <LIST_CHILD>;
   if ($query =~ /^add /) {
      $query =~ s/^add //;
      chomp($query);
      $res = add($query);
   }
   elsif ($query =~ /^reload /) {
      $query =~ s/^reload //;
      chomp($query);
      $res = reload($query);
   }
   elsif ($query =~ /^remove /) {
      $query =~ s/^remove //;
      chomp($query);
      $res = remove($query);
   }
   print TELL_CHILD "$res\n";
   print TELL_CHILD "____\n"; # end of response
}

while (my $c = $d->accept) #connect
{
   if (fork() == 0) #start new concurrent process
   {
      while (my $r = $c->get_request) #get http request
      {
         if ($r->method eq 'GET' &&
         ($r->url->path eq $working_path or $r->url->path eq $working_path."/"))#start dir
         {
             my $response = new HTTP::Response;
             $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
             $response->content(home($r->url->query));
             $c->send_response($response);
         }
         elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/help")#usage
         {
             my $response = new HTTP::Response;
             $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
             $response->content(help($r->url->query));
             $c->send_response($response);
         }
         elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/add")#add
         {
             my $response = new HTTP::Response;
             kill(USR1,getppid()); # ask the parent to read the pipe
             my $qs = $r->url->query;
             print TELL_PARENT "add $qs\n";
             my $in;
             while (($in = <LIST_PARENT>) ne "____\n") {
                $res .= $in;
             }
             chomp($res);
             $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
             $response->content($res);
             $c->send_response($response);
         }
         elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/remove")#remove
         {
             my $response = new HTTP::Response;
             kill(USR1,getppid()); # ask the parent to read the pipe
             my $qs = $r->url->query;
             print TELL_PARENT "remove $qs\n";
             my $in;
             my $res="";
             while (($in = <LIST_PARENT>) ne "____\n") {
                 $res .= $in;
             }
             chomp($res);
             $response->content($res);
             $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
             $c->send_response($response);
         }
         elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/reload")#reload
         {
             my $response = new HTTP::Response;
             kill(USR1,getppid()); # ask the parent to read the pipe
             my $qs = $r->url->query;
             print TELL_PARENT "reload $qs\n";
             my $in;
             my $res="";
             while (($in = <LIST_PARENT>) ne "____\n") {
                 $res .= $in;
             }
             chomp($res);
             $response->content($res);
             $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
             $c->send_response($response);
         }
         elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/list")#list
         {
             my $response = new HTTP::Response;
             $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
             $response->content(list($r->url->query));
             $c->send_response($response);
         }
         elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/apply")#apply
         {
             my %headers;
             my $response = new HTTP::Response;
             $response->content(apply($r->url->query,\%headers));
             $response->header(%headers);
             $c->send_response($response);
         }
         else #wrong command or not working_path
         {
             $c->send_error(RC_FORBIDDEN)
         }
      }
      $c->close;
      undef($c);
      exit;
   } # fork
}

#################################################################################################
#################################################################################################
#################################################################################################
# Stylesheet hash check subrutines
#################################################################################################
#################################################################################################
#################################################################################################

#################################################################################################
# sub addcheckvalues
# Usage: addcheckvalues($key,$uri);
# Returns: error message or  0 if no errors found
# Do: check if key and uri are already loaded
# Used by: addvalues
# Uses : err_replace
#################################################################################################
sub addcheckvalues
{
   my $ac_key = shift(@_);
   my $ac_uri = shift(@_);
   if (exists $stylesheet_hash{$ac_key})
   {
      return err_replace($error{"add_dup_key"},$ac_key,$ac_uri,"");
   }
   elsif (exists $by_name{$ac_uri})
   {
     return err_replace($error{"add_dup_value"},$ac_key,$ac_uri,$by_name{$ac_key});
   }
   else  {   return 0;  }
}
#################################################################################################

#################################################################################################
# sub recheckvalues
# Usage: recheckvalues($key);
# Returns: error message or  0 if no errors found
# Do: check if key are loaded
# Used by: remove, reloadvalues
# Uses : err_replace
#################################################################################################
sub recheckvalues
{
   my $re_key = shift(@_);
   if (not exists $stylesheet_hash{$re_key})
   {
     return err_replace($error{"re_inv_key"},$re_key,"","");
   }
   else { return 0; }
}
#################################################################################################

#################################################################################################
# sub applycheckvalues
# Usage: applycheckvalues(\@keys);
# Returns: error message or  0 if no errors found
# Do: check if keys in @keys are loaded
# Used by: remove, reloadvalues
# Uses : err_replace
#################################################################################################
sub applycheckvalues
{
   my $applykeys_ptr = shift(@_);
   foreach $applykey (@$applykeys_ptr)
   {
      if (not exists $stylesheet_hash{$applykey})
      {
         return err_replace($error{"apply_inv_key"},$applykey,"","");
      }
   }
   return 0;
}
#################################################################################################

#################################################################################################
#################################################################################################
#################################################################################################
# Stylesheet hash modify subrutines
#################################################################################################
#################################################################################################
#################################################################################################

#################################################################################################
# sub addvalues
# Usage: if add_halt_on_errors is ON addvalues($key,$uri,@added);
#        else addvalues($key,$uri)
# Returns: error message or 0 on success,
#             if add_halt_on_errors is ON return all the added keys on @added
# Do: add the values to the stylesheet hash
# Used by: add
# Uses : addcheckvalues, loadstyle
#################################################################################################
sub addvalues
{
   my $av_key = shift(@_);
   my $av_uri = shift(@_);
   my $av_stylesheet; #parsed stylesheet to be placed in hash
   if (my $err = addcheckvalues($av_key,$av_uri)) { return $err; }
   elsif (my $err = loadstyle($av_key, $av_uri, $av_stylesheet)) { return $err; }
   else
   {
      $stylesheet_hash{$av_key}[0]=$av_uri;
      $stylesheet_hash{$av_key}[1]=$av_stylesheet;
      $by_name{$av_uri}=$av_key;
      return 0;
   }
}
#################################################################################################

#################################################################################################
# sub removevalues
# Usage: removevalues($key);
# Returns: message
# Do: remove the key specified and relative values from the stylesheet hash
# Used by: remove, do_remove
# Uses : ok_replace
#################################################################################################
sub removevalues
{
   my $cr_key = shift(@_);
   my $cr_uri = $stylesheet_hash{$cr_key}[0];
   delete $stylesheet_hash{$cr_key};
   delete $by_name{$cr_uri};
   return ok_replace("$s_remove\n",$cr_key,$cr_uri);
}
#################################################################################################

#################################################################################################
# sub reloadvalues
# Usage: if add_halt_on_errors is ON reloadvalues($key.\%reloaded);
#        else reloadvalues($key);
# Returns: error message or 0 on success,
#             if add_halt_on_errors is ON return the old stylesheets in %reloaded
# Do: reload the stlylesheet with the key specified
# Used by: do_reload
# Uses : recheckvalues, loadstyle
#################################################################################################
sub reloadvalues
{
   my $rv_key = shift(@_);
   my $rv_uri = $stylesheet_hash{$rv_key}[0];
   my $rv_stylesheet; #parsed stylesheet to be placed in hash
   if (my $err = recheckvalues($rv_key)) { return $err; }
   elsif (my $err = loadstyle($rv_key, $rv_uri, $rv_stylesheet)) { return $err; }
   else
   {
      $stylesheet_hash{$rv_key}[1] = $rv_stylesheet;
      return 0;
   }
}
#################################################################################################

#################################################################################################
#################################################################################################
#################################################################################################
# LibXML LIBXSLT access subrutines
#################################################################################################
#################################################################################################
#################################################################################################

#################################################################################################
# sub loadstyle
# Usage: loadstyle($key,$uri,$stylesheet);
# Returns: error message or 0 on success,
#             parsed stylesheet in $stylesheet
# Do: parse the stylesheet at the given uri
# Used by: addvalues , reloadvalues
# Uses : err_replace, parser_error_replace
#################################################################################################
sub loadstyle
{
   my $ls_key= shift(@_);
   my $ls_uri= shift(@_);
   my $uncatched = "";
   my $line = "";
   my $style_doc;
   pipe P, STDERR;
   STDERR->autoflush(1);
   eval { $style_doc  = $parser->parse_file($ls_uri);  };
   print STDERR "____\n";
   while(($line = <P>) ne "____\n") { $uncatched .= $line; }
   close P;

   if ($@ or $uncatched ne "")
   {
      return err_replace($error{"add_xml_error"},$ls_key,$ls_uri,parser_error_replace($@.$uncatched));
   }
   else
   {
      pipe P, STDERR;
      STDERR->autoflush(1);
      $uncatched = "";
      $line = "";
      eval { $_[0] = $xslt->parse_stylesheet($style_doc); };
      print STDERR "____\n";
      while(($line = <P>) ne "____\n") { $uncatched .= $line; }
      close P;
      if ($@ or $uncatched ne "")
      {
         return err_replace($error{"add_xslt_error"},$ls_key,$ls_uri,parser_error_replace($@.$uncatched));
      }
      else  {return 0}
   }
}

sub load_xml_doc
{
   my $xmluri = shift(@_);
   my $uncatched = "";
   my $line = "";
   pipe P, STDERR;
   STDERR->autoflush(1);
   eval { $_[0] = $parser->parse_file($xmluri); };
   print STDERR "____\n";
   while(($line = <P>) ne "____\n") { $uncatched .= $line; }
   close P;
   if ($@ or $uncatched ne "")
   {
      return err_replace($error{"apply_xml_error"},"",$xmluri,parser_error_replace($@.$uncatched));
   }
   else  {return 0}
}

sub apply_style
{
   my $k = shift(@_);
   my $params_ptr = shift(@_);
   my %params = XML::LibXSLT::xpath_to_string(%$params_ptr);
   my $pippo;
   my $uncatched = "";
   my $line = "";
   pipe P, STDERR;
   STDERR->autoflush(1);
   XML::LibXSLT->max_depth($max_depth);
   eval { $_[0] = $stylesheet_hash{$k}[1]->transform($_[0],%params); };
   print STDERR "____\n";
   while(($line = <P>) ne "____\n") { $uncatched .= $line; }
   close P;
   if ($@ or $uncatched ne "")
   {
      my $e_r = parser_error_replace($@.$uncatched);
      return  err_replace($error{"apply_xslt_error"},$k,$stylesheet_hash{$k}[0],$e_r);
   }
   else  {return 0}
}
sub get_results
{
   my $k = shift(@_);
   my $results = shift(@_);
   my $retval;
   my $uncatched = "";
   my $line = "";
   pipe P, STDERR;
   STDERR->autoflush(1);
   eval { $retval = $stylesheet_hash{$k}[1]->output_string($results); };
   print STDERR "____\n";
   while(($line = <P>) ne "____\n") { $uncatched .= $line; }
   close P;
   if ($@ or $uncatched ne "")
   {
      my $e_r = parser_error_replace($@.$uncatched);
      return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
   }
   else { return $retval; }
}
sub get_results_prop
{
   my $result = shift(@_);
   my $retval;
   my $uncatched = "";
   my $line = "";
   pipe P, STDERR;
   STDERR->autoflush(1);
   eval { $retval = $result->toString; };
   print STDERR "____\n";
   while(($line = <P>) ne "____\n") { $uncatched .= $line; }
   close P;
   if ($@ or $uncatched ne "")
   {
      my $e_r = parser_error_replace($@.$uncatched);
      return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
   }
   else { return $retval; }
}

sub get_results_html
{
   my $result = shift(@_);
   my $retval;
   my $uncatched = "";
   my $line = "";
   pipe P, STDERR;
   STDERR->autoflush(1);
   eval { $retval = $result->toStringHTML();};
   print STDERR "____\n";
   while(($line = <P>) ne "____\n") { $uncatched .= $line; }
   close P;
   if ($@ or $uncatched ne "")
   {
      my $e_r = parser_error_replace($@.$uncatched);
      return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
   }
   else { return $retval; }
}

sub decode
{
   my $result = shift(@_);
   my $enc = shift(@_);
   my $retval;
   my $uncatched = "";
   my $line = "";
   pipe P, STDERR;
   STDERR->autoflush(1);
   eval { $retval = decodeFromUTF8($enc, $result);};
   print STDERR "____\n";
   while(($line = <P>) ne "____\n") { $uncatched .= $line; }
   close P;
   if ($@ or $uncatched ne "")
   {
      my $e_r = parser_error_replace($@.$uncatched);
      return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
   }
   else { return $retval; }
}
#################################################################################################

#################################################################################################
#################################################################################################
#################################################################################################
# Commands subrutines
#################################################################################################
#################################################################################################
#################################################################################################

#################################################################################################
# sub add
# Usage: add($http_query);
# Returns: values for HTTP::Response
# Do: add stylesheet(s) to hash
# Used by: daemon
# Uses : addparsequery, addvalues, ok_replace,
#        ok_print, synerror_print, operror_print
#################################################################################################
sub add
{
   my $http_query = shift(@_); # querystring
   my $cont =""; # return value
   my @binds; #values of binds passed via querystring
   my $err; # error string
   if ($err = addparsequery($http_query,\@binds)) { return synerror_print($err,$add_usage); }
   else
   {
      foreach my $bind (@binds)
      {
         my ($a_key , $e_uri) = split(/,/,$bind,2);
         my $une_uri = uri_unescape($e_uri);
         if ($err = addvalues($a_key,$une_uri)) { $cont .= "$err\n"; }
         else { $cont .= ok_replace("$s_add\n",$a_key,$une_uri); }
      }#foreach
      return ok_print($cont);
   }
}
#################################################################################################

#################################################################################################
# sub remove
# Usage: remove($http_query);
# Returns: values for HTTP::Response
# Do: remove stylesheet(s) from hash
# Used by: daemon
# Uses : reparsequery, getkeys, recheckvalues, removevalues,
#        ok_print, synerror_print, operror_print
#################################################################################################
sub remove
{
   my $http_query = shift(@_); # querystring
   my $rem_keys;
   my $cont="";
   my $err;
   if ($http_query eq "")
   {
      my $i=0;
      foreach my $rem_key (keys %stylesheet_hash)
      {
         $cont .= removevalues($rem_key);
         $i++;
      }
      if ($i==0) { return operror_print($error{"re_no_sl"}); }
   }
   elsif ($err = reparsequery($http_query,$rem_keys)){return synerror_print($err,$remove_usage);}
   else
   {
      foreach my $rem_key (split (/,/,$rem_keys))
      {
         if (my $err = recheckvalues($rem_key)) { $cont .= "$err\n"; }
         else { $cont .= removevalues($rem_key); }
      }
   }
   return ok_print($cont);
}
#################################################################################################

#################################################################################################
# sub reload
# Usage: remove($http_query);
# Returns: values for HTTP::Response
# Do: remove stylesheet(s) from hash
# Used by: daemon
# Uses : reparsequery, getkeys, recheckvalues, removevalues,
#        ok_print, synerror_print, operror_print
#################################################################################################
sub reload #reload stylesheet(s) from hash
{
   my $http_query = shift(@_);
   my $rel_keys;
   my @rel_k;
   my $dr_cont = "";
   if ($http_query eq "")
   {
      my $i=0;
      foreach my $key (keys %stylesheet_hash)
      {
         if (my $err = reloadvalues($key))  {  return $dr_cont .= $err; }
         else {$dr_cont .= ok_replace("$s_reload\n",$key,$stylesheet_hash{$key}[0]);}
         $i++;
      }
      if ($i==0) { return operror_print($error{"re_no_sl"}); }
   }
   elsif ($err = reparsequery($http_query,$rel_keys)){return synerror_print($err,$reload_usage);}
   else
   {
      foreach my $key (split (/,/,$rel_keys))
      {
         if (my $err = reloadvalues($key))  {  return $dr_cont .= $err; }
         else {$dr_cont .= ok_replace("$s_reload\n",$key,$stylesheet_hash{$key}[0]);}
      }
   }
   return ok_print($dr_cont);
}
#################################################################################################

sub apply #apply stylesheets
{
   my $http_query = shift(@_);
   my $headers_ptr = shift(@_);
   my $xmluri;
   my @applykeys;
   my %app_param;
   my %app_prop;
   my $results;
   my $lastkey;
   my $enc;

   if (my $err=applyparsequery($http_query,\@applykeys,\%app_param,\%app_prop,$xmluri))
   {
      return synerror_print($err,$apply_usage);
   }
   elsif (my $err=applycheckvalues(\@applykeys)) { return operror_print($err); }
   elsif (my $err=load_xml_doc($xmluri,$results)) { return operror_print($err); }
   #apply
   foreach my $applykey (@applykeys)
   {
      $lastkey=$applykey;
      if (my $err=apply_style($applykey,\%{$app_param{$applykey}},$results))
      {
         return operror_print($err);
      }
   }#foreach
   my $i=0;
   while (my ($n, $v) = each %app_prop)
   {
      if (($n eq "method") or ($n eq "METHOD"))
      {
        if ($v eq 'html') { $headers_ptr->{'Content-Type'}='text/html'; }
        elsif ($v eq 'text') { $headers_ptr->{'Content-Type'}='text/plain'; }
        else { $headers_ptr->{'Content-Type'}='text/xml'; }
      }
      if (($n eq "encoding") or ($n eq "ENCODING"))
      {
        $headers_ptr->{'Content-Encoding'}=$v;
        if ($v ne "UTF-8") { $enc = $v; }
      }
      if (($n eq "media-type") or ($n eq "MEDIA_TYPE") or ($n eq "MEDIA-TYPE"))
      {
        $headers_ptr->{'Content-Type'}=$v;
      }
      $i++;
   }
   if ($i == 0)
   {
      %$headers_ptr= ('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
      return get_results($lastkey,$results);
   }
   else
   {
      my $result;
      $headers_ptr->{'Cache-Control'} = 'no-cache';
      $headers_ptr->{'Pragma'} = "no-cache";
      $headers_ptr->{'Expires'} = '0';
      if ($headers_ptr->{'Content-Type'} eq 'text/html')
      {
         $result = get_results_html($results);
      }
      else
      {
         $result = get_results_prop($results);
         if ($enc)
         {
           $result = decode($result,$enc);
         }
      }
      return $result;
   }
}

sub list #list all the stylesheet loaded
{
   my $cont="";
   my $ind = 0;
   foreach $key (keys %stylesheet_hash)
   {
      $cont .= ok_replace("$list\n",$key,$stylesheet_hash{$key}[0]);
      $ind++;
   }
   if ($ind > 0) {   return ok_print($cont);  }
   else { return ok_print($empty);  }
}

sub home #return Dispay active
{
   if ($_[0] ne "") { return synerror_print($error{"home_qs"},$all_usage); }
   else {
      return ok_print($home_message.$all_usage);
   }
}

sub help #return html help
{
   if ($_[0] ne "") { return synerror_print($error{"help_qs"},$help_usage); }
   return ok_print($help_message.$all_usage);
}

#################################################################################################
#################################################################################################
# Subrutines to get parameters for commands from Query String (query string parsing)
#################################################################################################
#################################################################################################

sub add_comma_analysis
{
   my $bind = shift(@_);
   my ($l , $r) = split(/,/,$bind,2);
   if (index($bind ,",") == -1) { return $error{"add_no_sep"}; }
   elsif (index($r ,",") != -1) { return $error{"add_many_sep"}; }
   elsif (($l eq "") or ($r eq "")) { return $error{"add_null_bind"}; }
   else { return 0; }
}
##
#usage:
#addparsequery($querystring,\@binds)
#returns $errcode;
sub addparsequery
{
   my $query = shift(@_);
   my $value_ptr = shift(@_);
   if ($query eq "")  { return $error{"add_no_bind"}; }
   else
   {
      foreach my $params (split(/&/,$query))
      {
         my ($k , $v) = split(/=/,$params,2);
         $v=uri_unescape($v);
         if ($k ne "bind") { return $error{"add_oth"}; }
         elsif ($v eq "") { return $error{"add_null_bind"}; }
         elsif (my $err=add_comma_analysis($v)) { return $err; }
         else {  push @$value_ptr,$v;}
      }#foreach
      return 0;
   }
}

sub reparsequery
{
   my $query = shift(@_);
   my $k;
   my $v;
   my $err;
   if (index($query, "&") == -1)
   {
      ($k , $v) = split(/=/,$query,2);
      $v=uri_unescape($v);
      if ($k ne "keys") {  return $error{"re_oth"}; }
      elsif ($v eq "") { return $error{"re_null_keys"}; }
      elsif ((index($v,",")==0) or (index($v,",,")!=-1) or (substr($v,-1) eq ","))
      {
         return $error{"re_null_keys"};
      }
      else { $_[0] = $v; return 0; }
   }
   else { return $error{"re_many"}; }
}

sub get_req
{
   my $arr_ptr = shift(@_);
   my $xmluri_found = 0;
   my $keys_found = 0;
   foreach my $el (@$arr_ptr)
   {
       my ($k , $v) = split(/=/,$el,2);
       $v=uri_unescape($v);
       if ($k eq "param") { return $error{"apply_no_dots_param"}; }
       elsif ($k eq "prop") { return $error{"apply_no_dots_prop"}; }
       elsif ($k eq "xmluri")
       {
          if ($xmluri_found) { return $error{"apply_many_uri"}; }
          else
          {
             if ($v eq "") { return $error{"apply_null_uri"}; }
             else { $_[0] = $v;  $xmluri_found = 1; }
          }
       }
       elsif ($k eq "keys")
       {
           if ($keys_found) { return $error{"apply_many_keys"}; }
           else
           {
              if ($v eq "") { return $error{"apply_null_keys"}; }
              elsif ((index($v,",")==0) or (index($v,",,")!=-1) or (substr($v,-1) eq ","))
              {
                 return $error{"apply_null_keys"};
              }
              else { $_[1] = $v; $keys_found = 1; }
           }
       }
       else { return $error{"apply_oth"}; }
   }#foreach my $el (@$arr_ptr)
   if ((!$xmluri_found or !$keys_found)) { return $error{"apply_few_pars"}; }
   else  { return 0; }
}

sub applyparsequery
{
   my $query = shift(@_);
   my $apply_keys_ptr = shift(@_);
   my $keyparshoh = shift(@_);
   my $proph_ptr = shift(@_);
   my $applykeys;
   my %prop_h;
   my %genparam_h;
   my %keyparam_h;
   my @nodots;

   if ($query eq "") { return $error{"apply_few_pars"}; }
   if (index($query, "&") == -1) { return $error{"apply_few_pars"}; }
   foreach my $param (split(/&/,$query))
   {
       my ($k , $v) = split(/=/,$param,2);
       $v=uri_unescape($v);
       if (index($k, ".") == -1) { push @nodots,$param; }
       else
       {
            my ($l , $r) = split(/\./,$k,2);
            if ($l eq "prop")
            {
                if (($r eq "") or ($v eq "")) { return $error{"apply_null_prop"}; }
                elsif (index($r, ".") > -1)  { return $error{"apply_dots_prop"}; }
                else { $prop_h{$r} = $v; }
            }
            elsif ($l eq "param")
            {
                if (($r eq "") or ($v eq "")) { return $error{"apply_null_param"}; }
                elsif (index($r, ".") == -1)   { $genparam_h{$r} = $v; }
                else
                {
                    my ($kk , $va) = split(/\./,$r,2);
                    if (index($va, ".") > -1) {  return $error{"apply_dots_param"}; }
                    elsif (($kk eq "") or ($va eq "")) { return $error{"apply_null_param"}; }
                    else { $keyparam_h{$kk}{$va}=$v; }
                }
            }
            else  { return $error{"apply_oth"}; }
       }
   }

   if (my $err = get_req(\@nodots,$_[0],$applykeys)) { return $err; }
   while (my ($gn, $gv) = each %prop_h)
   {
      $proph_ptr->{$gn} = $gv;
   }
   foreach my $pkey ( keys %keyparam_h )
   {
       my $k_found=0;
       foreach my $verkey (split (/,/,$applykeys))
       {
          if ($pkey eq $verkey) { $k_found = 1; }
       }
       if (! $k_found) { return $error{"apply_inv_param"}; }
   }

   foreach my $applykey (split (/,/,$applykeys))
   {
         while (my ($gn, $gv) = each %genparam_h)
         {
            $keyparshoh->{$applykey}{$gn} = $gv;
         }
         while (my ($kn, $kv) = each %{ $keyparam_h{$applykey} } )
         {
           $keyparshoh->{$applykey}{$kn} = $kv;
         }
         push  @$apply_keys_ptr, $applykey;
   }#foreach
   return 0;
}

#################################################################################################
#################################################################################################
#################################################################################################
# Subrutines to replace values between {} on loaded templates
#################################################################################################
#################################################################################################
#################################################################################################

sub ok_print
{
   my $message = shift(@_);
   $message =~ s/(\n)/<br>\1/g;
   my $retval = $ok_tpl;
   $retval =~ s/\{MESSAGE\}/$message/g;
   return $retval;
}

sub operror_print
{
   my $message = shift(@_);
   $message =~ s/(\n)/<br>\1/g;
   my $retval = $operror_tpl;
   $retval =~ s/\{ERROR\}/$message/g;
   return $retval;
}

sub synerror_print
{
   my $message = shift(@_);
   my $us = shift(@_);
   $message =~ s/(\n)/<br>\1/g;
   my $retval = $synerror_tpl;
   $retval =~ s/\{ERROR\}/$message/g;
   $retval =~ s/\{USAGE\}/$us/g;
   return $retval;
}

#################################################################################################
#################################################################################################
#################################################################################################
# Subrutines to replace values between {} on loaded messages
#################################################################################################
#################################################################################################
#################################################################################################

sub ok_replace
{
   my $message = shift(@_);
   my $key = shift(@_);
   my $s_uri = shift(@_);
   $message =~ s/\{KEY\}/$key/g;
   $message =~ s/\{URI\}/$s_uri/g;
   return $message;
}

sub err_replace
{
   my $message = shift(@_);
   my $key = shift(@_);
   my $s_uri = shift(@_);
   my $errr = shift(@_);
   $message =~ s/\{KEY\}/$key/g;
   $message =~ s/\{URI\}/$s_uri/g;
   $message =~ s/\{ERROR\}/$errr/g;
   $message =~ s/\{OLDKEY\}/$errr/g;
   return $message;
}

sub parser_error_replace
{
    my $no_at = shift(@_);
    $no_at =~ s/(.*)\sat\s(.*)/\1/g;
    $no_at =~ s/</&lt;/g;
    $no_at =~ s/>/&gt;/g;
    return $no_at;
}

#################################################################################################
#################################################################################################
#################################################################################################
# Subrutines to load config files and templates
#################################################################################################
#################################################################################################
#################################################################################################

sub load_messages
{
   if ($language eq "IT")
   {
       open(MESSAGE, "./msg/message.it") || die "Can't open config file '/msg/message.it' : $!";
   }
   else
   {
       open(MESSAGE, "./msg/message.en") || die "Can't open config file '/msg/message.en' : $!";
   }
   while(my $line = <MESSAGE>) {
      # ignore comments and full line comments
      $line =~ s/#.*$//;
      next unless $line =~ /\S/;
      $line =~ s/\{URL\}/$puwobo_url/g;
      $line =~ s/\{VER\}/$ver/g;
      if ($line =~ /^(home_message)\s*=\s*(.*)$/) {$home_message = $2; }
      if ($line =~ /^(help_message)\s*=\s*(.*)$/) {$help_message = $2; }
      if ($line =~ /^(s_add)\s*=\s*(.*)$/) {$s_add = $2; }
      if ($line =~ /^(s_reload)\s*=\s*(.*)$/) {$s_reload = $2; }
      if ($line =~ /^(s_remove)\s*=\s*(.*)$/) {$s_remove = $2; }
      if ($line =~ /^(list)\s*=\s*(.*)$/) {$list = $2; }
      if ($line =~ /^(empty)\s*=\s*(.*)$/) {$empty = $2; }
      if ($line =~ /^(all_usage)\s*=\s*(.*)$/) {$all_usage = $2; }
      if ($all_usage_synerr eq "ON")
      {
         $help_usage=$add_usage=$remove_usage=$list_usage=$reload_usage=$apply_usage=$all_usage;
      }
      else
      {
         if ($line =~ /^(help_usage)\s*=\s*(.*)$/) {$help_usage = $2; }
         if ($line =~ /^(add_usage)\s*=\s*(.*)$/) {$add_usage = $2; }
         if ($line =~ /^(remove_usage)\s*=\s*(.*)$/) {$remove_usage = $2; }
         if ($line =~ /^(list_usage)\s*=\s*(.*)$/) {$list_usage = $2; }
         if ($line =~ /^(reload_usage)\s*=\s*(.*)$/) {$reload_usage = $2; }
         if ($line =~ /^(apply_usage)\s*=\s*(.*)$/) {$apply_usage = $2; }
      }
   }
   close MESSAGE;
}

sub load_conf
{
   open(CONFIG, "./config") || die "Can't open config file 'config' : $!";
   while(my $line = <CONFIG>) {
       # ignore comments and full line comments
       $line =~ s/#.*$//;
       next unless $line =~ /\S/;
       if ($line =~ /^(working_path)\s*=\s*(.*)$/) {$working_path = $2; }
       if ($line =~ /^(language)\s*=\s*(.*)$/) {$language = $2; }
       if ($line =~ /^(port)\s*=\s*(.*)$/) {$port = $2; }
       if ($line =~ /^(all_usage_synerr)\s*=\s*(.*)$/) {$all_usage_synerr = $2; }
       if ($line =~ /^(expand_xinc)\s*=\s*(.*)$/) {$expand_xinc = $2; }
       if ($line =~ /^(max_depth)\s*=\s*(.*)$/) {$max_depth = $2; }
   }
   close CONFIG;
}

sub load_err
{
   if ($language eq "IT")
   {
      open(ERRO, "./msg/error.it") || die "Can't open config file '/msg/error.it' : $!";
   }
   else
   {
      open(ERRO, "./msg/error.en") || die "Can't open config file '/msg/error.en' : $!";
   }
   while(my $line = <ERRO>)
   {
      # ignore comments and full line comments
      $line =~ s/#.*$//;
       next unless $line =~ /\S/;
       if ($line =~ /^(.*?)\s*=\s*(.*)$/) {$error{$1} = $2; }
   }
   close ERRO;
}

sub load_templates
{
        # load ok template
        open(OK_TPL, "./tpl/ok.tpl")
        || die "Can't open template file '/tpl/ok.tpl' : $!";
        while(my $line = <OK_TPL>) {$ok_tpl .= $line; }
        close OK_TPL;

        # load operror template
        open(OPERROR_TPL, "./tpl/operror.tpl")
        || die "Can't open template file '/tpl/operror.tpl' : $!";
        while(my $line = <OPERROR_TPL>) {$operror_tpl .= $line; }
        close OPERROR_TPL;

        # load synerror template
        open(SYNERROR_TPL, "./tpl/synerror.tpl")
        || die "Can't open template file '/tpl/synerror.tpl' : $!";
        while(my $line = <SYNERROR_TPL>) {$synerror_tpl .= $line; }
        close SYNERROR_TPL;
}

#################################################################################################
#################################################################################################
#################################################################################################
# the LibXML callbacks follow
# these callbacks are used for both the original parse AND the XInclude (if set)
#################################################################################################
#################################################################################################
#################################################################################################

sub match_uri {
    my $uri = shift;
    return $uri !~ /:\/\// ? 1 : 0; # we handle only files
}

sub open_uri {
    my $uri = shift;

    my $handler = new IO::File;
    if ( not $handler->open( "<$uri" ) ){
        $file = 0;
    }

    return $file;
}

sub read_uri {
    my $handler = shift;
    my $length  = shift;
    my $buffer = undef;
    if ( $handler ) {
        $handler->read( $rv , $length );
    }
    return $buffer;
}

sub close_uri {
    my $handler = shift;
    if ( $handler ) {
        $handler->close();
    }
    return 1;
}
