First version of hxsp (new version of UWOBO implemented in Perl by

[helm.git] / helm / hxsp / splitted / 7.qsparse.p.pl

diff --git a/helm/hxsp/splitted/7.qsparse.p.pl b/helm/hxsp/splitted/7.qsparse.p.pl
new file mode 100644 (file)
index 0000000..aa7be53
--- /dev/null
+++ b/helm/hxsp/splitted/7.qsparse.p.pl
@@ -0,0 +1,172 @@
+#################################################################################################
+#################################################################################################
+# 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;
+}