X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fhttp_getter%2Fhttp_getter.pl.in;h=e9d1f4a3e04609137ad68b8db5658759be797f81;hb=2f28bfb47f5fad6b3c5a705d9ede95700416dee8;hp=f3484d68845d38099360016ebb4e29aec508b74b;hpb=fe80ede918357f2f3c27133d27319bf026d71163;p=helm.git

diff --git a/helm/http_getter/http_getter.pl.in b/helm/http_getter/http_getter.pl.in
index f3484d688..e9d1f4a3e 100755
--- a/helm/http_getter/http_getter.pl.in
+++ b/helm/http_getter/http_getter.pl.in
@@ -55,18 +55,15 @@ if (($cachemode ne 'gzipped') and ($cachemode ne 'normal')) {
  "'normal' or 'gzipped'\n";
 }
 
-my $helm_rdf_dir = $ENV{'HTTP_GETTER_RDF_DIR'} ||
-  "/usr/local/helm/rdf_library";
-my $rdf_dbm = $ENV{'HTTP_GETTER_RDF_DBM'} ||
-  "/usr/local/helm/rdf_urls_of_uris.db";
-my $xslt_dbm = $ENV{'HTTP_GETTER_XSLT_DBM'} ||
-  "/usr/local/helm/xslt_urls_of_uris.db";
-my $rdf_indexname = $ENV{'HTTP_GETTER_RDF_INDEXNAME'} ||
-  "rdf_index.txt";
-my $xslt_indexname = $ENV{'HTTP_GETTER_XSLT_INDEXNAME'} ||
-  "xslt_index.txt";
+$helm_rdf_dir = $ENV{'HTTP_GETTER_RDF_DIR'} || $helm_rdf_dir;
+$rdf_dbm = $ENV{'HTTP_GETTER_RDF_DBM'} || $rdf_dbm;
+$xslt_dbm = $ENV{'HTTP_GETTER_XSLT_DBM'} || $xslt_dbm;
+$rdf_indexname = $ENV{'HTTP_GETTER_RDF_INDEXNAME'} || $rdf_indexname;
+$xslt_indexname = $ENV{'HTTP_GETTER_XSLT_INDEXNAME'} || $xslt_indexname;
 $servers_file = $ENV{'HTTP_GETTER_SERVERS_FILE'} || $servers_file;
 $uris_dbm = $ENV{'HTTP_GETTER_URIS_DBM'} || $uris_dbm;
+$dtdbaseurl = $ENV{'HTTP_GETTER_DTD_BASE_URL'} || $dtdbaseurl;
+$getterport = $ENV{'HTTP_GETTER_PORT'} || $getterport;
   
 # </move_to_conf_file>
 
@@ -88,8 +85,8 @@ use URI::Escape;
 #CSC: ==> non e' robusto
 #CSC: altra roba da sistemare segnata con CSC
 
-my $d = new HTTP::Daemon LocalPort => 8081
- or die "Error: port 8081 not available.";
+my $d = new HTTP::Daemon LocalPort => $getterport
+ or die "Error: port $getterport not available.";
 my $myownurl = $d->url;
 
 # Let's patch the returned URL
@@ -120,6 +117,8 @@ print "cache mode: $cachemode\n";
 print "indexname: $indexname\n";
 print "rdf_indexname: $rdf_indexname\n";
 print "xslt_indexname: $xslt_indexname\n";
+print "dtdbaseurl: $dtdbaseurl\n";
+print "getterport: $getterport\n";
 print "\n";
 
 $SIG{CHLD} = "IGNORE"; # do not accumulate defunct processes
@@ -313,7 +312,21 @@ while (my $c = $d->accept) {
            print " done\n";
            html_nice_answer($c,"Update done");
 
-                                 # "/ls" does not work with rdf uris
+                                 # "/getalluris" does not work with rdf uris
+        } elsif ($http_method eq 'GET' and $http_path eq "/getalluris") {
+            # send back all the keys in xml
+            print "BASEURI $baseuri, FORMAT $outype\n";
+            $cont = getalluris();
+            answer($c,$cont,"text/xml","");
+
+                                 # "/getallrdfuris"
+        } elsif ($http_method eq 'GET' and $http_path eq "/getallrdfuris") {
+            # send back all the keys in xml
+            my $class = $cgi->param('class');
+            print "BASEURI $baseuri, FORMAT $outype, CLASS $class\n";
+            $cont = getallrdfuris($class);
+            answer($c,$cont,"text/xml","");
+
         } elsif ($http_method eq 'GET' and $http_path eq "/ls") {
             # send back keys that begin with a given uri
            my ($uritype,$uripattern,$uriprefix);
@@ -443,6 +456,49 @@ sub resolve { # resolve an uri in a url, work both with standard cic: or theory:
  }
 }
 
+sub getalluris { # get all the keys whose prefix is cic
+ my $content = "";
+ my ($uri);
+ my $debug=1; # for debug
+
+  $content .= '<?xml version="1.0" encoding="ISO-8859-1"?>' . "\n";
+  $content .= "<!DOCTYPE alluris SYSTEM ";
+  $content .= "\"$myownurl/getdtd?uri=alluris.dtd\">" . "\n\n";
+  $content .= "<alluris>\n";
+  foreach $uri (sort (keys(%xml_map))) { # select matching uris
+   if ($uri =~ /^cic:/ && not $uri =~ /.types$/) {
+    print "GETALLURI: $uri\n" if defined($debug);
+    $content .= "\t<uri value=\"$uri\"/>\n";
+   }
+  }
+  $content .= "</alluris>\n";
+ return $content;
+}
+
+sub getallrdfuris {
+ my $class = $_[0];
+ my $content = "";
+ my ($uri);
+ my $debug=1; # for debug
+
+  $content .= '<?xml version="1.0" encoding="ISO-8859-1"?>' . "\n";
+  $content .= "<!DOCTYPE allrdfuris SYSTEM ";
+  $content .= "\"$myownurl/getdtd?uri=alluris.dtd\">" . "\n\n";
+  $content .= "<allrdfuris>\n";
+  foreach $uri (sort (keys(%rdf_map))) {
+   if ($class eq "forward" &&
+        $uri =~ /^helm:rdf:www.cs.unibo.it\/helm\/rdf\/forward/
+       ||
+        $class eq "backward" &&
+         $uri =~ /^helm:rdf:www.cs.unibo.it\/helm\/rdf\/backward/) {
+      print "GETALLRDFURI: $uri\n" if defined($debug);
+      $content .= "\t<uri value=\"$uri\"/>\n";
+   }
+  }
+  $content .= "</allrdfuris>\n";
+ return $content;
+}
+
 sub finduris { # find uris for cic and theory trees generation
  my ($uritype,$uripattern,$format) = @_;
  my $content = "";
@@ -473,9 +529,9 @@ sub finduris { # find uris for cic and theory trees generation
 
     if ($localpart =~ /^[^\/]*$/) { # no slash, an OBJECT
      $basepart = $localpart;
-     $basepart =~ s/^([^.]*\.[^.]*)(\.types)?(\.ann)?/$1/;
-                                              # remove exts .types or
-                                              # .types.ann
+     $basepart =~ s/^([^.]*\.[^.]*)((\.body)|(\.types))?(\.ann)?/$1/;
+                                              # remove exts .types, .body,
+                                              # .types.ann or .body.ann
      $flags = $objects{$basepart}; # get old flags
      if ($localpart =~ /\.ann$/) {
       $flags = add_flag("ann","YES",$flags);
@@ -489,6 +545,13 @@ sub finduris { # find uris for cic and theory trees generation
      } else {
       $flags = add_flag("types","NO",$flags);
      }
+     if ($localpart =~ /\.body$/) {
+      $flags = add_flag("body","YES",$flags);
+     } elsif ($localpart =~ /\.body\.ann$/) {
+      $flags = add_flag("body","ANN",$flags);
+     } else {
+      $flags = add_flag("body","NO",$flags);
+     }
      $objects{$basepart} = $flags; # save new flags
     } else { # exists at least one slash, a DIR
      ($dirname) = split (/\//, $localpart);
@@ -520,9 +583,10 @@ sub finduris { # find uris for cic and theory trees generation
    $content .= "\t<object name=\"$key\">\n";
    $flags = $objects{$key};
    $flags =~ s/^<(.*)>$/$1/;
-   my ($annflag,$typesflag) = split /,/,$flags;
+   my ($annflag,$typesflag,$bodyflag) = split /,/,$flags;
    $content .= "\t\t<ann value=\"$annflag\" />\n";
    $content .= "\t\t<types value=\"$typesflag\" />\n";
+   $content .= "\t\t<body value=\"$bodyflag\" />\n";
    $content .= "\t</object>\n";
   }
   $content .= "</ls>\n";
@@ -533,17 +597,18 @@ sub finduris { # find uris for cic and theory trees generation
 }
 
 sub add_flag {
-# manage string like: "<ann_flag,type_flag>"
+# manage string like: "<ann_flag,type_flag,body_flag>"
 # "ann_flag" may be one of "ann_YES", "ann_NO"
 # "type_flag" may be one of "types_NO", "types_YES", "types_ANN"
+# "body_flag" may be one of "body_NO", "body_YES", "body_ANN"
 # when adding a flag the max between the current flag and the new flag
-# is taken, the orders are ann_NO < ann_YES and types_NO < types_YES <
-# types_ANN
+# is taken, the orders are ann_NO < ann_YES, types_NO < types_YES <
+# types_ANN and body_NO < body_YES < body_ANN
  my ($flagtype,$newflag,$str) = @_;
- $str = "<,>" if ($str eq "");
- ($str =~ s/^<(.*,.*)>$/$1/) or die "Internal error: ".
+ $str = "<,,>" if ($str eq "");
+ ($str =~ s/^<(.*,.*,.*)>$/$1/) or die "Internal error: ".
    "wrong string format for flag adding in $str";
- my ($annflag,$typeflag) = split /,/,$str;
+ my ($annflag,$typeflag,$bodyflag) = split /,/,$str;
  if ($flagtype eq "ann") { # ANN flag handling
   if ($newflag eq "YES") {
    $annflag = "YES";
@@ -563,10 +628,21 @@ sub add_flag {
   } else {
    die "Internal error: typeflag must be \"YES\", \"NO\" or \"ANN\"";
   }
+ } elsif ($flagtype eq "body") { # BODY flag handling
+  if ($newflag eq "ANN") {
+   $bodyflag = "ANN";
+  } elsif ($newflag eq "YES") {
+   $bodyflag = "YES" unless ($bodyflag eq "ANN");
+  } elsif ($newflag eq "NO") {
+   $bodyflag = "NO"
+     unless (($bodyflag eq "ANN") or ($bodyflag eq "YES"));
+  } else {
+   die "Internal error: typeflag must be \"YES\", \"NO\" or \"ANN\"";
+  }
  } else {
   die "Internal error: unsupported flagtype \"$flagtype\"";
  }
- $str = "<$annflag,$typeflag>";
+ $str = "<$annflag,$typeflag,$bodyflag>";
 }
 
 #CSC: Too much powerful: creates even /home, /home/users/, ...
@@ -711,7 +787,7 @@ sub download {
    # $cont now contained uncompressed data
  }
  if ($patch_dtd eq "yes") {
-    $cont =~ s/DOCTYPE (.*) SYSTEM\s+"http:\/\/www.cs.unibo.it\/helm\/dtd\//DOCTYPE $1 SYSTEM "$myownurl\/getdtd?uri=/g;
+    $cont =~ s/DOCTYPE (.*) SYSTEM\s+"$dtdbaseurl\//DOCTYPE $1 SYSTEM "$myownurl\/getdtd?uri=/g;
  }
  if ($format eq "gz") {
   gzip($cont,"$basefname.tmp");
@@ -743,6 +819,7 @@ sub answer {
  $res->push_header("Pragma" => "no-cache");
  $res->push_header("Expires" => "0");
  $c->send_response($res);
+ $c->force_last_request();
 }
 
 sub html_nice_answer {