From b229325170c02aeb2a009737486f7162ac89ed99 Mon Sep 17 00:00:00 2001 From: Stefano Zacchiroli Date: Thu, 22 Feb 2001 14:21:44 +0000 Subject: [PATCH] Changed syntax for 'ls' method: wget http....localhost:8081/ls?baseuri=&format=[txt|xml] Now is possibile to: - use ls for 'cic:' uris - use ls for 'theory:' uris - coming soon support for 'any' uris Now getter use CGI module, added this dep. to configure.in --- helm/http_getter/configure.in | 2 +- helm/http_getter/http_getter.pl.in | 110 +++++++++++++++++++++++------ 2 files changed, 89 insertions(+), 23 deletions(-) diff --git a/helm/http_getter/configure.in b/helm/http_getter/configure.in index 636173a90..7d0c82781 100644 --- a/helm/http_getter/configure.in +++ b/helm/http_getter/configure.in @@ -64,7 +64,7 @@ if test $PERL_BINARY = no ; then fi dnl Perl modules checks -PERL_MODS="HTTP::Daemon HTTP::Status HTTP::Request LWP::UserAgent DB_File Compress::Zlib" +PERL_MODS="HTTP::Daemon HTTP::Status HTTP::Request LWP::UserAgent DB_File Compress::Zlib CGI" PERL_INC=`perl -e 'print(join(" ",@INC))'` for perl_mod in $PERL_MODS; do AC_MSG_CHECKING("for perl module: $perl_mod") diff --git a/helm/http_getter/http_getter.pl.in b/helm/http_getter/http_getter.pl.in index 83c8382a7..ec2814e48 100755 --- a/helm/http_getter/http_getter.pl.in +++ b/helm/http_getter/http_getter.pl.in @@ -58,6 +58,7 @@ use HTTP::Request; use LWP::UserAgent; use DB_File; use Compress::Zlib; +use CGI; use URI::Escape; #CSC: mancano i controlli sulle condizioni di errore di molte funzioni @@ -96,6 +97,7 @@ while (my $c = $d->accept) { my $http_method = $r->method; my $http_path = $r->url->path; my $http_query = uri_unescape($r->url->query); + my $cgi = new CGI($http_query); print "\nUnescaped query: ".$http_query."\n"; @@ -302,30 +304,36 @@ EOT answer($c,"

Update done

"); } elsif ($http_method eq 'GET' and $http_path eq "/ls") { # send back keys that begin with a given uri - my $baseuri = $http_query; - $baseuri =~ s/^.*baseuri=(.*)&.*$/$1/; + my ($uritype,$uripattern,$uriprefix); + my $baseuri = $cgi->param('baseuri'); chop $baseuri if ($baseuri =~ /.*\/$/); # remove trailing "/" - my $outype = $http_query; # output type, might be 'txt' or 'xml' - $outype =~ s/^.*&type=(.*)$/$1/; - if (($outype ne 'txt') and ($outype ne 'xml')) { # invalid out type - print "Invalid output type specified: $outype\n"; - answer($c,"

Invalid output type, may be ". - "\"txt\" or \"xml\"

"); - } else { # valid output type - print "BASEURI $baseuri, TYPE $outype\n"; - my $key; - $cont = ""; - $cont .= "\n" if ($outype eq "xml"); - foreach (keys(%map)) { # search for uri that begin with $baseuri - if ($_ =~ /^$baseuri\//) { - $cont .= "" if ($outype eq "xml"); - $cont .= $_; - $cont .= "\n" if ($outype eq "txt"); - $cont .= "\n" if ($outype eq "xml"); - } + my $outype = $cgi->param('format'); # output type, might be 'txt' or 'xml' + $uripattern = $baseuri; + $uripattern =~ s/^.*:(.*)/$1/; + if ($baseuri =~ /^cic:/) { + $uritype = "cic"; + } elsif ($baseuri =~ /^theory:/) { + $uritype = "theory"; + } elsif ($baseuri =~ /^\*:/) { + $uritype = "any"; + } else { + $uritype = "invalid"; + } + if ($uritype ne "invalid") { # uri is valid + if (($outype ne 'txt') and ($outype ne 'xml')) { # invalid out type + print "Invalid output type specified: $outype\n"; + answer($c,"

Invalid output type, may be ". + "\"txt\" or \"xml\"

"); + } else { # valid output + print "BASEURI $baseuri, FORMAT $outype\n"; + $cont = finduris($uritype,$uripattern,$outype); + answer($c,$cont); } - $cont .= "" if ($outype eq "xml"); - answer($c,$cont); + } else { # invalid uri + print "Invalid uri: $baseuri, may begin with 'cic:', ". + "'theory:' or '*:'\n"; + answer($c,"

Invalid uri , may begin with ". + "\"cic:\", \"theory:\" or \"*:\"

"); } } elsif ($http_method eq 'GET' and $http_path eq "/version") { print "Version requested!"; @@ -349,6 +357,64 @@ EOT #================================ +sub finduris { # find uris for cic and theory trees generation + my ($uritype,$uripattern,$format) = @_; + my $content = ""; + my ($uri,$localpart,$dirname); + my (@itemz,@already_pushed_dir); + + print "FINDURIS, uritype: $uritype, uripattern: $uripattern, ". + "format: $format\n\n"; + + if (($uritype eq "cic") or ($uritype eq "theory")) { + # get info only of one type: cic or theory + foreach (keys(%map)) { # select matching uris + $uri = $_; + if ($uri =~ /^$uritype:$uripattern\//) { + $localpart = $uri; + $localpart =~ s/^$uritype:$uripattern\/(.*)/$1/; + if ($localpart =~ /^[^\/]*$/) { # no slash, i.e. no dir + push @itemz, "object," . $localpart; + } else { # exists at least one slash, i.e. a dir + ($dirname) = split (/\//, $localpart); + push @itemz, "dir," . $dirname; + #print "LOCALPART $localpart, DIRNAME $dirname\n"; #DEBUG + } + } + } + } elsif ($uritype eq "any") { # get info for both cic and theory + foreach (keys(%map)) { + $uri = $_; + } + } else { + die "getter internal error: unsupported uritype: \"$uritype\""; + } + @itemz = sort @itemz; # sort itemz and remove duplicates + my $lastitem = ""; + if ($format eq "txt") { #now generate output + foreach (@itemz) { + next if ($_ eq $last); + $content .= ($_ . "\n"); + $last = $_; + } + } elsif ($format eq "xml") { + $content .= "\n"; + foreach (@itemz) { + next if ($_ eq $last); + $last = $_; + ($itemtype,$itemdata) = split(/,/, $_); + if ($itemtype eq "object") { + $content .= "

\n"; + } elsif ($itemtype eq "dir") { + $content .= "

$itemdata

\n"; + } + } + $content .= "\n" + } else { # may not enter this branch + die "Getter internal error: invalid format received by finduris sub"; + } + return $content; +} #CSC: Too much powerful: creates even /home, /home/users/, ... #CSC: Does not raise errors if could not create dirs/files -- 2.39.2