helm/hxsp/hxsp.pl

   1 #!/usr/bin/perl
   2
   3 #################################################################################################
   4 #################################################################################################
   5 #################################################################################################
   6 #
   7 #  H.X.S.P.    V 1.0
   8 #  T S T R
   9 #  T L Y O
  10 #  P T E C
  11 #      S E
  12 #      H S
  13 #      E S
  14 #      E O
  15 #      T R
  16 #
  17 #################################################################################################
  18 #################################################################################################
  19 #################################################################################################
  20
  21 use HTTP::Daemon;
  22 use HTTP::Status;
  23 use HTTP::Request;
  24 use LWP::UserAgent;
  25 use URI::Escape;
  26 use CGI;
  27 use FindBin;
  28 use XML::LibXML;
  29 use XML::LibXSLT;
  30 use IO;
  31
  32 #################################################################################################
  33 #################################################################################################
  34 #################################################################################################
  35 # Global Variables
  36 #################################################################################################
  37 #################################################################################################
  38 #################################################################################################
  39
  40 # Version number
  41 my $ver ="1.0";
  42
  43 # Working path of hxsp (loaded from config)
  44 my $working_path;
  45
  46 # Interface language (loaded from config)
  47 my $language;
  48
  49 # Port to use for hxsp (loaded from config)
  50 my $port;
  51
  52 # Use complete command description on syntax error if ON (loaded from config)
  53 my $all_usage_synerr;
  54
  55 # Include XIncludes on the fly if ON (loaded from config)
  56 my $expand_xinc;
  57
  58 # Max Depth of the DOM tree while parsing
  59 my $max_depth;
  60
  61 # Message sent when hxsp was called without commands (loaded from message.##)
  62 my $home_message;
  63
  64 # Message sent when hxsp was called with the help command (loaded from message.##)
  65 my $help_message;
  66
  67 # Message sent when a stylesheet is added (loaded from message.##)
  68 my $s_add;
  69
  70 # Message sent when a stylesheet is reloaded (loaded from message.##)
  71 my $s_reload;
  72
  73 # Message sent when a stylesheet is removed (loaded from message.##)
  74 my $s_remove;
  75
  76 # Message to print the stylesheet status for list command (loaded from message.##)
  77 my $list;
  78
  79 # Message sent when the list command was called
  80 # and there is no stylesheet loaded (loaded from message.##)
  81 my $empty;
  82
  83 # Message sent after "home_message" when hxsp was called without commands
  84 # and sent after "help_message" when hxsp was called with the help command
  85 # and after all syntax errors if "all_usage_synerr" is set ON (loaded from message.##)
  86 my $all_usage;
  87
  88 # All the following syntax errors messages are used #only# if "all_usage_synerr" is set OFF
  89
  90 # Message sent on help syntax errors (loaded from message.##)
  91 my $help_usage;
  92
  93 # Message sent on add syntax errors (loaded from message.##)
  94 my $add_usage;
  95
  96 # Message sent on remove syntax errors (loaded from message.##)
  97 my $remove_usage;
  98
  99 # Message sent on list syntax errors (loaded from message.##)
 100 my $list_usage;
 101
 102 # Message sent on reload syntax errors (loaded from message.##)
 103 my $reload_usage;
 104
 105 # Message sent on apply syntax errors (loaded from message.##)
 106 my $apply_usage;
 107
 108 # The error hash contains the error messages to call in case of syntax
 109 # or operative errors, the keys are defined by the left value of each line in error##
 110 my %error;
 111
 112 # load ok template
 113 my $ok_tpl;
 114
 115 # load operror template
 116 my $operror_tpl;
 117
 118 # load synerror template
 119 my $synerror_tpl;
 120
 121 # This is the data structure to store the loaded stylesheets (hash of array)
 122 # [0] :Styleseet URI , [1] : Loaded styleseet
 123 my %stylesheet_hash;
 124
 125 # This is a hash for fast duplicate uri detection
 126 my %by_name;
 127
 128 #################################################################################################
 129 #################################################################################################
 130 #################################################################################################
 131 # Starting Operations
 132 #################################################################################################
 133 #################################################################################################
 134 #################################################################################################
 135
 136 # chdir to the directory of this perl script
 137 chdir $FindBin::Bin;
 138
 139 # load CONFIG
 140 load_conf();
 141
 142 # initialize the objects to use LibXML and LibXSLT
 143 my $parser = XML::LibXML->new();
 144 my $xslt = XML::LibXSLT->new();
 145
 146 # initialize the LibXML callbacks to load uri's
 147 XML::LibXML->callbacks(\&match_uri,\&open_uri,\&read_uri,\&close_uri);
 148
 149 # include XIncludes on the fly if required
 150 if ($expand_xinc eq "ON") { $parser->expand_xinclude( 1 ); }
 151
 152 # initialize the hxsp as HTTP::Daemon
 153 my $d = new HTTP::Daemon LocalPort => $port;
 154
 155 # get the complete working url of hxsp
 156 my $puwobo_url = $d->url().$working_path;
 157
 158 # set the working path to be comparable with url->path
 159 $working_path = "/". $working_path;
 160
 161 # load messages
 162 load_messages();
 163
 164 # load error
 165 load_err();
 166
 167 # load templates
 168 load_templates();
 169
 170 # print starting information on console
 171 print qq{
 172 hxsp v$ver active at: <URL:$puwobo_url>
 173    Language is $language
 174    On syntax error usage of every command is $all_usage_synerr
 175    Include XIncludes on the fly is $expand_xinc;
 176 };
 177
 178 #################################################################################################
 179 #################################################################################################
 180 # HTTP::Daemon Operations
 181 #################################################################################################
 182 #################################################################################################
 183
 184 # do not accumulate defunct processes
 185 $SIG{CHLD} = "IGNORE";
 186 $SIG{USR1} = \&listen; # sent by the child to make the parent read the pipe
 187
 188 pipe LIST_CHILD, TELL_PARENT;
 189 pipe LIST_PARENT, TELL_CHILD;
 190 TELL_PARENT->autoflush(1);
 191 TELL_CHILD->autoflush(1);
 192
 193
 194 sub listen {
 195    my $res;
 196    my $query = <LIST_CHILD>;
 197    if ($query =~ /^add /) {
 198       $query =~ s/^add //;
 199       chomp($query);
 200       $res = add($query);
 201    }
 202    elsif ($query =~ /^reload /) {
 203       $query =~ s/^reload //;
 204       chomp($query);
 205       $res = reload($query);
 206    }
 207    elsif ($query =~ /^remove /) {
 208       $query =~ s/^remove //;
 209       chomp($query);
 210       $res = remove($query);
 211    }
 212    print TELL_CHILD "$res\n";
 213    print TELL_CHILD "____\n"; # end of response
 214 }
 215
 216 while (my $c = $d->accept) #connect
 217 {
 218    if (fork() == 0) #start new concurrent process
 219    {
 220       while (my $r = $c->get_request) #get http request
 221       {
 222          if ($r->method eq 'GET' &&
 223          ($r->url->path eq $working_path or $r->url->path eq $working_path."/"))#start dir
 224          {
 225              my $response = new HTTP::Response;
 226              $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
 227              $response->content(home($r->url->query));
 228              $c->send_response($response);
 229          }
 230          elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/help")#usage
 231          {
 232              my $response = new HTTP::Response;
 233              $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
 234              $response->content(help($r->url->query));
 235              $c->send_response($response);
 236          }
 237          elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/add")#add
 238          {
 239              my $response = new HTTP::Response;
 240              kill(USR1,getppid()); # ask the parent to read the pipe
 241              my $qs = $r->url->query;
 242              print TELL_PARENT "add $qs\n";
 243              my $in;
 244              while (($in = <LIST_PARENT>) ne "____\n") {
 245                 $res .= $in;
 246              }
 247              chomp($res);
 248              $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
 249              $response->content($res);
 250              $c->send_response($response);
 251          }
 252          elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/remove")#remove
 253          {
 254              my $response = new HTTP::Response;
 255              kill(USR1,getppid()); # ask the parent to read the pipe
 256              my $qs = $r->url->query;
 257              print TELL_PARENT "remove $qs\n";
 258              my $in;
 259              my $res="";
 260              while (($in = <LIST_PARENT>) ne "____\n") {
 261                  $res .= $in;
 262              }
 263              chomp($res);
 264              $response->content($res);
 265              $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
 266              $c->send_response($response);
 267          }
 268          elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/reload")#reload
 269          {
 270              my $response = new HTTP::Response;
 271              kill(USR1,getppid()); # ask the parent to read the pipe
 272              my $qs = $r->url->query;
 273              print TELL_PARENT "reload $qs\n";
 274              my $in;
 275              my $res="";
 276              while (($in = <LIST_PARENT>) ne "____\n") {
 277                  $res .= $in;
 278              }
 279              chomp($res);
 280              $response->content($res);
 281              $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
 282              $c->send_response($response);
 283          }
 284          elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/list")#list
 285          {
 286              my $response = new HTTP::Response;
 287              $response->header('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
 288              $response->content(list($r->url->query));
 289              $c->send_response($response);
 290          }
 291          elsif ($r->method eq 'GET' && $r->url->path eq $working_path."/apply")#apply
 292          {
 293              my %headers;
 294              my $response = new HTTP::Response;
 295              $response->content(apply($r->url->query,\%headers));
 296              $response->header(%headers);
 297              $c->send_response($response);
 298          }
 299          else #wrong command or not working_path
 300          {
 301              $c->send_error(RC_FORBIDDEN)
 302          }
 303       }
 304       $c->close;
 305       undef($c);
 306       exit;
 307    } # fork
 308 }
 309
 310 #################################################################################################
 311 #################################################################################################
 312 #################################################################################################
 313 # Stylesheet hash check subrutines
 314 #################################################################################################
 315 #################################################################################################
 316 #################################################################################################
 317
 318 #################################################################################################
 319 # sub addcheckvalues
 320 # Usage: addcheckvalues($key,$uri);
 321 # Returns: error message or  0 if no errors found
 322 # Do: check if key and uri are already loaded
 323 # Used by: addvalues
 324 # Uses : err_replace
 325 #################################################################################################
 326 sub addcheckvalues
 327 {
 328    my $ac_key = shift(@_);
 329    my $ac_uri = shift(@_);
 330    if (exists $stylesheet_hash{$ac_key})
 331    {
 332       return err_replace($error{"add_dup_key"},$ac_key,$ac_uri,"");
 333    }
 334    elsif (exists $by_name{$ac_uri})
 335    {
 336      return err_replace($error{"add_dup_value"},$ac_key,$ac_uri,$by_name{$ac_key});
 337    }
 338    else  {   return 0;  }
 339 }
 340 #################################################################################################
 341
 342 #################################################################################################
 343 # sub recheckvalues
 344 # Usage: recheckvalues($key);
 345 # Returns: error message or  0 if no errors found
 346 # Do: check if key are loaded
 347 # Used by: remove, reloadvalues
 348 # Uses : err_replace
 349 #################################################################################################
 350 sub recheckvalues
 351 {
 352    my $re_key = shift(@_);
 353    if (not exists $stylesheet_hash{$re_key})
 354    {
 355      return err_replace($error{"re_inv_key"},$re_key,"","");
 356    }
 357    else { return 0; }
 358 }
 359 #################################################################################################
 360
 361 #################################################################################################
 362 # sub applycheckvalues
 363 # Usage: applycheckvalues(\@keys);
 364 # Returns: error message or  0 if no errors found
 365 # Do: check if keys in @keys are loaded
 366 # Used by: remove, reloadvalues
 367 # Uses : err_replace
 368 #################################################################################################
 369 sub applycheckvalues
 370 {
 371    my $applykeys_ptr = shift(@_);
 372    foreach $applykey (@$applykeys_ptr)
 373    {
 374       if (not exists $stylesheet_hash{$applykey})
 375       {
 376          return err_replace($error{"apply_inv_key"},$applykey,"","");
 377       }
 378    }
 379    return 0;
 380 }
 381 #################################################################################################
 382
 383 #################################################################################################
 384 #################################################################################################
 385 #################################################################################################
 386 # Stylesheet hash modify subrutines
 387 #################################################################################################
 388 #################################################################################################
 389 #################################################################################################
 390
 391 #################################################################################################
 392 # sub addvalues
 393 # Usage: if add_halt_on_errors is ON addvalues($key,$uri,@added);
 394 #        else addvalues($key,$uri)
 395 # Returns: error message or 0 on success,
 396 #             if add_halt_on_errors is ON return all the added keys on @added
 397 # Do: add the values to the stylesheet hash
 398 # Used by: add
 399 # Uses : addcheckvalues, loadstyle
 400 #################################################################################################
 401 sub addvalues
 402 {
 403    my $av_key = shift(@_);
 404    my $av_uri = shift(@_);
 405    my $av_stylesheet; #parsed stylesheet to be placed in hash
 406    if (my $err = addcheckvalues($av_key,$av_uri)) { return $err; }
 407    elsif (my $err = loadstyle($av_key, $av_uri, $av_stylesheet)) { return $err; }
 408    else
 409    {
 410       $stylesheet_hash{$av_key}[0]=$av_uri;
 411       $stylesheet_hash{$av_key}[1]=$av_stylesheet;
 412       $by_name{$av_uri}=$av_key;
 413       return 0;
 414    }
 415 }
 416 #################################################################################################
 417
 418 #################################################################################################
 419 # sub removevalues
 420 # Usage: removevalues($key);
 421 # Returns: message
 422 # Do: remove the key specified and relative values from the stylesheet hash
 423 # Used by: remove, do_remove
 424 # Uses : ok_replace
 425 #################################################################################################
 426 sub removevalues
 427 {
 428    my $cr_key = shift(@_);
 429    my $cr_uri = $stylesheet_hash{$cr_key}[0];
 430    delete $stylesheet_hash{$cr_key};
 431    delete $by_name{$cr_uri};
 432    return ok_replace("$s_remove\n",$cr_key,$cr_uri);
 433 }
 434 #################################################################################################
 435
 436 #################################################################################################
 437 # sub reloadvalues
 438 # Usage: if add_halt_on_errors is ON reloadvalues($key.\%reloaded);
 439 #        else reloadvalues($key);
 440 # Returns: error message or 0 on success,
 441 #             if add_halt_on_errors is ON return the old stylesheets in %reloaded
 442 # Do: reload the stlylesheet with the key specified
 443 # Used by: do_reload
 444 # Uses : recheckvalues, loadstyle
 445 #################################################################################################
 446 sub reloadvalues
 447 {
 448    my $rv_key = shift(@_);
 449    my $rv_uri = $stylesheet_hash{$rv_key}[0];
 450    my $rv_stylesheet; #parsed stylesheet to be placed in hash
 451    if (my $err = recheckvalues($rv_key)) { return $err; }
 452    elsif (my $err = loadstyle($rv_key, $rv_uri, $rv_stylesheet)) { return $err; }
 453    else
 454    {
 455       $stylesheet_hash{$rv_key}[1] = $rv_stylesheet;
 456       return 0;
 457    }
 458 }
 459 #################################################################################################
 460
 461 #################################################################################################
 462 #################################################################################################
 463 #################################################################################################
 464 # LibXML LIBXSLT access subrutines
 465 #################################################################################################
 466 #################################################################################################
 467 #################################################################################################
 468
 469 #################################################################################################
 470 # sub loadstyle
 471 # Usage: loadstyle($key,$uri,$stylesheet);
 472 # Returns: error message or 0 on success,
 473 #             parsed stylesheet in $stylesheet
 474 # Do: parse the stylesheet at the given uri
 475 # Used by: addvalues , reloadvalues
 476 # Uses : err_replace, parser_error_replace
 477 #################################################################################################
 478 sub loadstyle
 479 {
 480    my $ls_key= shift(@_);
 481    my $ls_uri= shift(@_);
 482    my $uncatched = "";
 483    my $line = "";
 484    my $style_doc;
 485    pipe P, STDERR;
 486    STDERR->autoflush(1);
 487    eval { $style_doc  = $parser->parse_file($ls_uri);  };
 488    print STDERR "____\n";
 489    while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 490    close P;
 491
 492    if ($@ or $uncatched ne "")
 493    {
 494       return err_replace($error{"add_xml_error"},$ls_key,$ls_uri,parser_error_replace($@.$uncatched));
 495    }
 496    else
 497    {
 498       pipe P, STDERR;
 499       STDERR->autoflush(1);
 500       $uncatched = "";
 501       $line = "";
 502       eval { $_[0] = $xslt->parse_stylesheet($style_doc); };
 503       print STDERR "____\n";
 504       while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 505       close P;
 506       if ($@ or $uncatched ne "")
 507       {
 508          return err_replace($error{"add_xslt_error"},$ls_key,$ls_uri,parser_error_replace($@.$uncatched));
 509       }
 510       else  {return 0}
 511    }
 512 }
 513
 514 sub load_xml_doc
 515 {
 516    my $xmluri = shift(@_);
 517    my $uncatched = "";
 518    my $line = "";
 519    pipe P, STDERR;
 520    STDERR->autoflush(1);
 521    eval { $_[0] = $parser->parse_file($xmluri); };
 522    print STDERR "____\n";
 523    while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 524    close P;
 525    if ($@ or $uncatched ne "")
 526    {
 527       return err_replace($error{"apply_xml_error"},"",$xmluri,parser_error_replace($@.$uncatched));
 528    }
 529    else  {return 0}
 530 }
 531
 532 sub apply_style
 533 {
 534    my $k = shift(@_);
 535    my $params_ptr = shift(@_);
 536    my %params = XML::LibXSLT::xpath_to_string(%$params_ptr);
 537    my $pippo;
 538    my $uncatched = "";
 539    my $line = "";
 540    pipe P, STDERR;
 541    STDERR->autoflush(1);
 542    XML::LibXSLT->max_depth($max_depth);
 543    eval { $_[0] = $stylesheet_hash{$k}[1]->transform($_[0],%params); };
 544    print STDERR "____\n";
 545    while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 546    close P;
 547    if ($@ or $uncatched ne "")
 548    {
 549       my $e_r = parser_error_replace($@.$uncatched);
 550       return  err_replace($error{"apply_xslt_error"},$k,$stylesheet_hash{$k}[0],$e_r);
 551    }
 552    else  {return 0}
 553 }
 554 sub get_results
 555 {
 556    my $k = shift(@_);
 557    my $results = shift(@_);
 558    my $retval;
 559    my $uncatched = "";
 560    my $line = "";
 561    pipe P, STDERR;
 562    STDERR->autoflush(1);
 563    eval { $retval = $stylesheet_hash{$k}[1]->output_string($results); };
 564    print STDERR "____\n";
 565    while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 566    close P;
 567    if ($@ or $uncatched ne "")
 568    {
 569       my $e_r = parser_error_replace($@.$uncatched);
 570       return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
 571    }
 572    else { return $retval; }
 573 }
 574 sub get_results_prop
 575 {
 576    my $result = shift(@_);
 577    my $retval;
 578    my $uncatched = "";
 579    my $line = "";
 580    pipe P, STDERR;
 581    STDERR->autoflush(1);
 582    eval { $retval = $result->toString; };
 583    print STDERR "____\n";
 584    while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 585    close P;
 586    if ($@ or $uncatched ne "")
 587    {
 588       my $e_r = parser_error_replace($@.$uncatched);
 589       return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
 590    }
 591    else { return $retval; }
 592 }
 593
 594 sub get_results_html
 595 {
 596    my $result = shift(@_);
 597    my $retval;
 598    my $uncatched = "";
 599    my $line = "";
 600    pipe P, STDERR;
 601    STDERR->autoflush(1);
 602    eval { $retval = $result->toStringHTML();};
 603    print STDERR "____\n";
 604    while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 605    close P;
 606    if ($@ or $uncatched ne "")
 607    {
 608       my $e_r = parser_error_replace($@.$uncatched);
 609       return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
 610    }
 611    else { return $retval; }
 612 }
 613
 614 sub decode
 615 {
 616    my $result = shift(@_);
 617    my $enc = shift(@_);
 618    my $retval;
 619    my $uncatched = "";
 620    my $line = "";
 621    pipe P, STDERR;
 622    STDERR->autoflush(1);
 623    eval { $retval = decodeFromUTF8($enc, $result);};
 624    print STDERR "____\n";
 625    while(($line = <P>) ne "____\n") { $uncatched .= $line; }
 626    close P;
 627    if ($@ or $uncatched ne "")
 628    {
 629       my $e_r = parser_error_replace($@.$uncatched);
 630       return operror_print(err_replace($error{"apply_xslt_out_error"},"","",$e_r));
 631    }
 632    else { return $retval; }
 633 }
 634 #################################################################################################
 635
 636 #################################################################################################
 637 #################################################################################################
 638 #################################################################################################
 639 # Commands subrutines
 640 #################################################################################################
 641 #################################################################################################
 642 #################################################################################################
 643
 644 #################################################################################################
 645 # sub add
 646 # Usage: add($http_query);
 647 # Returns: values for HTTP::Response
 648 # Do: add stylesheet(s) to hash
 649 # Used by: daemon
 650 # Uses : addparsequery, addvalues, ok_replace,
 651 #        ok_print, synerror_print, operror_print
 652 #################################################################################################
 653 sub add
 654 {
 655    my $http_query = shift(@_); # querystring
 656    my $cont =""; # return value
 657    my @binds; #values of binds passed via querystring
 658    my $err; # error string
 659    if ($err = addparsequery($http_query,\@binds)) { return synerror_print($err,$add_usage); }
 660    else
 661    {
 662       foreach my $bind (@binds)
 663       {
 664          my ($a_key , $e_uri) = split(/,/,$bind,2);
 665          my $une_uri = uri_unescape($e_uri);
 666          if ($err = addvalues($a_key,$une_uri)) { $cont .= "$err\n"; }
 667          else { $cont .= ok_replace("$s_add\n",$a_key,$une_uri); }
 668       }#foreach
 669       return ok_print($cont);
 670    }
 671 }
 672 #################################################################################################
 673
 674 #################################################################################################
 675 # sub remove
 676 # Usage: remove($http_query);
 677 # Returns: values for HTTP::Response
 678 # Do: remove stylesheet(s) from hash
 679 # Used by: daemon
 680 # Uses : reparsequery, getkeys, recheckvalues, removevalues,
 681 #        ok_print, synerror_print, operror_print
 682 #################################################################################################
 683 sub remove
 684 {
 685    my $http_query = shift(@_); # querystring
 686    my $rem_keys;
 687    my $cont="";
 688    my $err;
 689    if ($http_query eq "")
 690    {
 691       my $i=0;
 692       foreach my $rem_key (keys %stylesheet_hash)
 693       {
 694          $cont .= removevalues($rem_key);
 695          $i++;
 696       }
 697       if ($i==0) { return operror_print($error{"re_no_sl"}); }
 698    }
 699    elsif ($err = reparsequery($http_query,$rem_keys)){return synerror_print($err,$remove_usage);}
 700    else
 701    {
 702       foreach my $rem_key (split (/,/,$rem_keys))
 703       {
 704          if (my $err = recheckvalues($rem_key)) { $cont .= "$err\n"; }
 705          else { $cont .= removevalues($rem_key); }
 706       }
 707    }
 708    return ok_print($cont);
 709 }
 710 #################################################################################################
 711
 712 #################################################################################################
 713 # sub reload
 714 # Usage: remove($http_query);
 715 # Returns: values for HTTP::Response
 716 # Do: remove stylesheet(s) from hash
 717 # Used by: daemon
 718 # Uses : reparsequery, getkeys, recheckvalues, removevalues,
 719 #        ok_print, synerror_print, operror_print
 720 #################################################################################################
 721 sub reload #reload stylesheet(s) from hash
 722 {
 723    my $http_query = shift(@_);
 724    my $rel_keys;
 725    my @rel_k;
 726    my $dr_cont = "";
 727    if ($http_query eq "")
 728    {
 729       my $i=0;
 730       foreach my $key (keys %stylesheet_hash)
 731       {
 732          if (my $err = reloadvalues($key))  {  return $dr_cont .= $err; }
 733          else {$dr_cont .= ok_replace("$s_reload\n",$key,$stylesheet_hash{$key}[0]);}
 734          $i++;
 735       }
 736       if ($i==0) { return operror_print($error{"re_no_sl"}); }
 737    }
 738    elsif ($err = reparsequery($http_query,$rel_keys)){return synerror_print($err,$reload_usage);}
 739    else
 740    {
 741       foreach my $key (split (/,/,$rel_keys))
 742       {
 743          if (my $err = reloadvalues($key))  {  return $dr_cont .= $err; }
 744          else {$dr_cont .= ok_replace("$s_reload\n",$key,$stylesheet_hash{$key}[0]);}
 745       }
 746    }
 747    return ok_print($dr_cont);
 748 }
 749 #################################################################################################
 750
 751 sub apply #apply stylesheets
 752 {
 753    my $http_query = shift(@_);
 754    my $headers_ptr = shift(@_);
 755    my $xmluri;
 756    my @applykeys;
 757    my %app_param;
 758    my %app_prop;
 759    my $results;
 760    my $lastkey;
 761    my $enc;
 762
 763    if (my $err=applyparsequery($http_query,\@applykeys,\%app_param,\%app_prop,$xmluri))
 764    {
 765       return synerror_print($err,$apply_usage);
 766    }
 767    elsif (my $err=applycheckvalues(\@applykeys)) { return operror_print($err); }
 768    elsif (my $err=load_xml_doc($xmluri,$results)) { return operror_print($err); }
 769    #apply
 770    foreach my $applykey (@applykeys)
 771    {
 772       $lastkey=$applykey;
 773       if (my $err=apply_style($applykey,\%{$app_param{$applykey}},$results))
 774       {
 775          return operror_print($err);
 776       }
 777    }#foreach
 778    my $i=0;
 779    while (my ($n, $v) = each %app_prop)
 780    {
 781       if (($n eq "method") or ($n eq "METHOD"))
 782       {
 783         if ($v eq 'html') { $headers_ptr->{'Content-Type'}='text/html'; }
 784         elsif ($v eq 'text') { $headers_ptr->{'Content-Type'}='text/plain'; }
 785         else { $headers_ptr->{'Content-Type'}='text/xml'; }
 786       }
 787       if (($n eq "encoding") or ($n eq "ENCODING"))
 788       {
 789         $headers_ptr->{'Content-Encoding'}=$v;
 790         if ($v ne "UTF-8") { $enc = $v; }
 791       }
 792       if (($n eq "media-type") or ($n eq "MEDIA_TYPE") or ($n eq "MEDIA-TYPE"))
 793       {
 794         $headers_ptr->{'Content-Type'}=$v;
 795       }
 796       $i++;
 797    }
 798    if ($i == 0)
 799    {
 800       %$headers_ptr= ('Cache-Control' => 'no-cache','Pragma' => "no-cache",'Expires' => '0');
 801       return get_results($lastkey,$results);
 802    }
 803    else
 804    {
 805       my $result;
 806       $headers_ptr->{'Cache-Control'} = 'no-cache';
 807       $headers_ptr->{'Pragma'} = "no-cache";
 808       $headers_ptr->{'Expires'} = '0';
 809       if ($headers_ptr->{'Content-Type'} eq 'text/html')
 810       {
 811          $result = get_results_html($results);
 812       }
 813       else
 814       {
 815          $result = get_results_prop($results);
 816          if ($enc)
 817          {
 818            $result = decode($result,$enc);
 819          }
 820       }
 821       return $result;
 822    }
 823 }
 824
 825 sub list #list all the stylesheet loaded
 826 {
 827    my $cont="";
 828    my $ind = 0;
 829    foreach $key (keys %stylesheet_hash)
 830    {
 831       $cont .= ok_replace("$list\n",$key,$stylesheet_hash{$key}[0]);
 832       $ind++;
 833    }
 834    if ($ind > 0) {   return ok_print($cont);  }
 835    else { return ok_print($empty);  }
 836 }
 837
 838 sub home #return Dispay active
 839 {
 840    if ($_[0] ne "") { return synerror_print($error{"home_qs"},$all_usage); }
 841    else {
 842       return ok_print($home_message.$all_usage);
 843    }
 844 }
 845
 846 sub help #return html help
 847 {
 848    if ($_[0] ne "") { return synerror_print($error{"help_qs"},$help_usage); }
 849    return ok_print($help_message.$all_usage);
 850 }
 851
 852 #################################################################################################
 853 #################################################################################################
 854 # Subrutines to get parameters for commands from Query String (query string parsing)
 855 #################################################################################################
 856 #################################################################################################
 857
 858 sub add_comma_analysis
 859 {
 860    my $bind = shift(@_);
 861    my ($l , $r) = split(/,/,$bind,2);
 862    if (index($bind ,",") == -1) { return $error{"add_no_sep"}; }
 863    elsif (index($r ,",") != -1) { return $error{"add_many_sep"}; }
 864    elsif (($l eq "") or ($r eq "")) { return $error{"add_null_bind"}; }
 865    else { return 0; }
 866 }
 867 ##
 868 #usage:
 869 #addparsequery($querystring,\@binds)
 870 #returns $errcode;
 871 sub addparsequery
 872 {
 873    my $query = shift(@_);
 874    my $value_ptr = shift(@_);
 875    if ($query eq "")  { return $error{"add_no_bind"}; }
 876    else
 877    {
 878       foreach my $params (split(/&/,$query))
 879       {
 880          my ($k , $v) = split(/=/,$params,2);
 881          $v=uri_unescape($v);
 882          if ($k ne "bind") { return $error{"add_oth"}; }
 883          elsif ($v eq "") { return $error{"add_null_bind"}; }
 884          elsif (my $err=add_comma_analysis($v)) { return $err; }
 885          else {  push @$value_ptr,$v;}
 886       }#foreach
 887       return 0;
 888    }
 889 }
 890
 891 sub reparsequery
 892 {
 893    my $query = shift(@_);
 894    my $k;
 895    my $v;
 896    my $err;
 897    if (index($query, "&") == -1)
 898    {
 899       ($k , $v) = split(/=/,$query,2);
 900       $v=uri_unescape($v);
 901       if ($k ne "keys") {  return $error{"re_oth"}; }
 902       elsif ($v eq "") { return $error{"re_null_keys"}; }
 903       elsif ((index($v,",")==0) or (index($v,",,")!=-1) or (substr($v,-1) eq ","))
 904       {
 905          return $error{"re_null_keys"};
 906       }
 907       else { $_[0] = $v; return 0; }
 908    }
 909    else { return $error{"re_many"}; }
 910 }
 911
 912 sub get_req
 913 {
 914    my $arr_ptr = shift(@_);
 915    my $xmluri_found = 0;
 916    my $keys_found = 0;
 917    foreach my $el (@$arr_ptr)
 918    {
 919        my ($k , $v) = split(/=/,$el,2);
 920        $v=uri_unescape($v);
 921        if ($k eq "param") { return $error{"apply_no_dots_param"}; }
 922        elsif ($k eq "prop") { return $error{"apply_no_dots_prop"}; }
 923        elsif ($k eq "xmluri")
 924        {
 925           if ($xmluri_found) { return $error{"apply_many_uri"}; }
 926           else
 927           {
 928              if ($v eq "") { return $error{"apply_null_uri"}; }
 929              else { $_[0] = $v;  $xmluri_found = 1; }
 930           }
 931        }
 932        elsif ($k eq "keys")
 933        {
 934            if ($keys_found) { return $error{"apply_many_keys"}; }
 935            else
 936            {
 937               if ($v eq "") { return $error{"apply_null_keys"}; }
 938               elsif ((index($v,",")==0) or (index($v,",,")!=-1) or (substr($v,-1) eq ","))
 939               {
 940                  return $error{"apply_null_keys"};
 941               }
 942               else { $_[1] = $v; $keys_found = 1; }
 943            }
 944        }
 945        else { return $error{"apply_oth"}; }
 946    }#foreach my $el (@$arr_ptr)
 947    if ((!$xmluri_found or !$keys_found)) { return $error{"apply_few_pars"}; }
 948    else  { return 0; }
 949 }
 950
 951 sub applyparsequery
 952 {
 953    my $query = shift(@_);
 954    my $apply_keys_ptr = shift(@_);
 955    my $keyparshoh = shift(@_);
 956    my $proph_ptr = shift(@_);
 957    my $applykeys;
 958    my %prop_h;
 959    my %genparam_h;
 960    my %keyparam_h;
 961    my @nodots;
 962
 963    if ($query eq "") { return $error{"apply_few_pars"}; }
 964    if (index($query, "&") == -1) { return $error{"apply_few_pars"}; }
 965    foreach my $param (split(/&/,$query))
 966    {
 967        my ($k , $v) = split(/=/,$param,2);
 968        $v=uri_unescape($v);
 969        if (index($k, ".") == -1) { push @nodots,$param; }
 970        else
 971        {
 972             my ($l , $r) = split(/\./,$k,2);
 973             if ($l eq "prop")
 974             {
 975                 if (($r eq "") or ($v eq "")) { return $error{"apply_null_prop"}; }
 976                 elsif (index($r, ".") > -1)  { return $error{"apply_dots_prop"}; }
 977                 else { $prop_h{$r} = $v; }
 978             }
 979             elsif ($l eq "param")
 980             {
 981                 if (($r eq "") or ($v eq "")) { return $error{"apply_null_param"}; }
 982                 elsif (index($r, ".") == -1)   { $genparam_h{$r} = $v; }
 983                 else
 984                 {
 985                     my ($kk , $va) = split(/\./,$r,2);
 986                     if (index($va, ".") > -1) {  return $error{"apply_dots_param"}; }
 987                     elsif (($kk eq "") or ($va eq "")) { return $error{"apply_null_param"}; }
 988                     else { $keyparam_h{$kk}{$va}=$v; }
 989                 }
 990             }
 991             else  { return $error{"apply_oth"}; }
 992        }
 993    }
 994
 995    if (my $err = get_req(\@nodots,$_[0],$applykeys)) { return $err; }
 996    while (my ($gn, $gv) = each %prop_h)
 997    {
 998       $proph_ptr->{$gn} = $gv;
 999    }
1000    foreach my $pkey ( keys %keyparam_h )
1001    {
1002        my $k_found=0;
1003        foreach my $verkey (split (/,/,$applykeys))
1004        {
1005           if ($pkey eq $verkey) { $k_found = 1; }
1006        }
1007        if (! $k_found) { return $error{"apply_inv_param"}; }
1008    }
1009
1010    foreach my $applykey (split (/,/,$applykeys))
1011    {
1012          while (my ($gn, $gv) = each %genparam_h)
1013          {
1014             $keyparshoh->{$applykey}{$gn} = $gv;
1015          }
1016          while (my ($kn, $kv) = each %{ $keyparam_h{$applykey} } )
1017          {
1018            $keyparshoh->{$applykey}{$kn} = $kv;
1019          }
1020          push  @$apply_keys_ptr, $applykey;
1021    }#foreach
1022    return 0;
1023 }
1024
1025 #################################################################################################
1026 #################################################################################################
1027 #################################################################################################
1028 # Subrutines to replace values between {} on loaded templates
1029 #################################################################################################
1030 #################################################################################################
1031 #################################################################################################
1032
1033 sub ok_print
1034 {
1035    my $message = shift(@_);
1036    $message =~ s/(\n)/<br>\1/g;
1037    my $retval = $ok_tpl;
1038    $retval =~ s/\{MESSAGE\}/$message/g;
1039    return $retval;
1040 }
1041
1042 sub operror_print
1043 {
1044    my $message = shift(@_);
1045    $message =~ s/(\n)/<br>\1/g;
1046    my $retval = $operror_tpl;
1047    $retval =~ s/\{ERROR\}/$message/g;
1048    return $retval;
1049 }
1050
1051 sub synerror_print
1052 {
1053    my $message = shift(@_);
1054    my $us = shift(@_);
1055    $message =~ s/(\n)/<br>\1/g;
1056    my $retval = $synerror_tpl;
1057    $retval =~ s/\{ERROR\}/$message/g;
1058    $retval =~ s/\{USAGE\}/$us/g;
1059    return $retval;
1060 }
1061
1062 #################################################################################################
1063 #################################################################################################
1064 #################################################################################################
1065 # Subrutines to replace values between {} on loaded messages
1066 #################################################################################################
1067 #################################################################################################
1068 #################################################################################################
1069
1070 sub ok_replace
1071 {
1072    my $message = shift(@_);
1073    my $key = shift(@_);
1074    my $s_uri = shift(@_);
1075    $message =~ s/\{KEY\}/$key/g;
1076    $message =~ s/\{URI\}/$s_uri/g;
1077    return $message;
1078 }
1079
1080 sub err_replace
1081 {
1082    my $message = shift(@_);
1083    my $key = shift(@_);
1084    my $s_uri = shift(@_);
1085    my $errr = shift(@_);
1086    $message =~ s/\{KEY\}/$key/g;
1087    $message =~ s/\{URI\}/$s_uri/g;
1088    $message =~ s/\{ERROR\}/$errr/g;
1089    $message =~ s/\{OLDKEY\}/$errr/g;
1090    return $message;
1091 }
1092
1093 sub parser_error_replace
1094 {
1095     my $no_at = shift(@_);
1096     $no_at =~ s/(.*)\sat\s(.*)/\1/g;
1097     $no_at =~ s/</&lt;/g;
1098     $no_at =~ s/>/&gt;/g;
1099     return $no_at;
1100 }
1101
1102 #################################################################################################
1103 #################################################################################################
1104 #################################################################################################
1105 # Subrutines to load config files and templates
1106 #################################################################################################
1107 #################################################################################################
1108 #################################################################################################
1109
1110 sub load_messages
1111 {
1112    if ($language eq "IT")
1113    {
1114        open(MESSAGE, "./msg/message.it") || die "Can't open config file '/msg/message.it' : $!";
1115    }
1116    else
1117    {
1118        open(MESSAGE, "./msg/message.en") || die "Can't open config file '/msg/message.en' : $!";
1119    }
1120    while(my $line = <MESSAGE>) {
1121       # ignore comments and full line comments
1122       $line =~ s/#.*$//;
1123       next unless $line =~ /\S/;
1124       $line =~ s/\{URL\}/$puwobo_url/g;
1125       $line =~ s/\{VER\}/$ver/g;
1126       if ($line =~ /^(home_message)\s*=\s*(.*)$/) {$home_message = $2; }
1127       if ($line =~ /^(help_message)\s*=\s*(.*)$/) {$help_message = $2; }
1128       if ($line =~ /^(s_add)\s*=\s*(.*)$/) {$s_add = $2; }
1129       if ($line =~ /^(s_reload)\s*=\s*(.*)$/) {$s_reload = $2; }
1130       if ($line =~ /^(s_remove)\s*=\s*(.*)$/) {$s_remove = $2; }
1131       if ($line =~ /^(list)\s*=\s*(.*)$/) {$list = $2; }
1132       if ($line =~ /^(empty)\s*=\s*(.*)$/) {$empty = $2; }
1133       if ($line =~ /^(all_usage)\s*=\s*(.*)$/) {$all_usage = $2; }
1134       if ($all_usage_synerr eq "ON")
1135       {
1136          $help_usage=$add_usage=$remove_usage=$list_usage=$reload_usage=$apply_usage=$all_usage;
1137       }
1138       else
1139       {
1140          if ($line =~ /^(help_usage)\s*=\s*(.*)$/) {$help_usage = $2; }
1141          if ($line =~ /^(add_usage)\s*=\s*(.*)$/) {$add_usage = $2; }
1142          if ($line =~ /^(remove_usage)\s*=\s*(.*)$/) {$remove_usage = $2; }
1143          if ($line =~ /^(list_usage)\s*=\s*(.*)$/) {$list_usage = $2; }
1144          if ($line =~ /^(reload_usage)\s*=\s*(.*)$/) {$reload_usage = $2; }
1145          if ($line =~ /^(apply_usage)\s*=\s*(.*)$/) {$apply_usage = $2; }
1146       }
1147    }
1148    close MESSAGE;
1149 }
1150
1151 sub load_conf
1152 {
1153    open(CONFIG, "./config") || die "Can't open config file 'config' : $!";
1154    while(my $line = <CONFIG>) {
1155        # ignore comments and full line comments
1156        $line =~ s/#.*$//;
1157        next unless $line =~ /\S/;
1158        if ($line =~ /^(working_path)\s*=\s*(.*)$/) {$working_path = $2; }
1159        if ($line =~ /^(language)\s*=\s*(.*)$/) {$language = $2; }
1160        if ($line =~ /^(port)\s*=\s*(.*)$/) {$port = $2; }
1161        if ($line =~ /^(all_usage_synerr)\s*=\s*(.*)$/) {$all_usage_synerr = $2; }
1162        if ($line =~ /^(expand_xinc)\s*=\s*(.*)$/) {$expand_xinc = $2; }
1163        if ($line =~ /^(max_depth)\s*=\s*(.*)$/) {$max_depth = $2; }
1164    }
1165    close CONFIG;
1166 }
1167
1168 sub load_err
1169 {
1170    if ($language eq "IT")
1171    {
1172       open(ERRO, "./msg/error.it") || die "Can't open config file '/msg/error.it' : $!";
1173    }
1174    else
1175    {
1176       open(ERRO, "./msg/error.en") || die "Can't open config file '/msg/error.en' : $!";
1177    }
1178    while(my $line = <ERRO>)
1179    {
1180       # ignore comments and full line comments
1181       $line =~ s/#.*$//;
1182        next unless $line =~ /\S/;
1183        if ($line =~ /^(.*?)\s*=\s*(.*)$/) {$error{$1} = $2; }
1184    }
1185    close ERRO;
1186 }
1187
1188 sub load_templates
1189 {
1190         # load ok template
1191         open(OK_TPL, "./tpl/ok.tpl")
1192         || die "Can't open template file '/tpl/ok.tpl' : $!";
1193         while(my $line = <OK_TPL>) {$ok_tpl .= $line; }
1194         close OK_TPL;
1195
1196         # load operror template
1197         open(OPERROR_TPL, "./tpl/operror.tpl")
1198         || die "Can't open template file '/tpl/operror.tpl' : $!";
1199         while(my $line = <OPERROR_TPL>) {$operror_tpl .= $line; }
1200         close OPERROR_TPL;
1201
1202         # load synerror template
1203         open(SYNERROR_TPL, "./tpl/synerror.tpl")
1204         || die "Can't open template file '/tpl/synerror.tpl' : $!";
1205         while(my $line = <SYNERROR_TPL>) {$synerror_tpl .= $line; }
1206         close SYNERROR_TPL;
1207 }
1208
1209 #################################################################################################
1210 #################################################################################################
1211 #################################################################################################
1212 # the LibXML callbacks follow
1213 # these callbacks are used for both the original parse AND the XInclude (if set)
1214 #################################################################################################
1215 #################################################################################################
1216 #################################################################################################
1217
1218 sub match_uri {
1219     my $uri = shift;
1220     return $uri !~ /:\/\// ? 1 : 0; # we handle only files
1221 }
1222
1223 sub open_uri {
1224     my $uri = shift;
1225
1226     my $handler = new IO::File;
1227     if ( not $handler->open( "<$uri" ) ){
1228         $file = 0;
1229     }
1230
1231     return $file;
1232 }
1233
1234 sub read_uri {
1235     my $handler = shift;
1236     my $length  = shift;
1237     my $buffer = undef;
1238     if ( $handler ) {
1239         $handler->read( $rv , $length );
1240     }
1241     return $buffer;
1242 }
1243
1244 sub close_uri {
1245     my $handler = shift;
1246     if ( $handler ) {
1247         $handler->close();
1248     }
1249     return 1;
1250 }