+++ /dev/null
-#!/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/</</g;
- $no_at =~ s/>/>/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;
-}
projects / helm.git / blobdiff