-sub finduris { # find uris for cic and theory trees generation
- my ($uritype,$uripattern,$format) = @_;
- my $content = "";
- my ($uri,$localpart,$basepart,$dirname,$suffix,$flags,$key);
- my (@itemz,@already_pushed_dir);
- my (%objects,%dirs); # map uris to suffixes' flags
-
- 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, an OBJECT
- $basepart = $localpart;
- $basepart =~ s/^(.*)\.types(\.ann)?/$1/; # remove exts .types or
- # .types.ann
- $flags = $objects{$basepart}; # get old flags
- if ($localpart =~ /\.ann$/) {
- $flags = add_flag("ann","YES",$flags);
- } else {
- $flags = add_flag("ann","NO",$flags);
- }
- if ($localpart =~ /\.types$/) {
- $flags = add_flag("types","YES",$flags);
- } elsif ($localpart =~ /\.types\.ann$/) {
- $flags = add_flag("types","ANN",$flags);
- } else {
- $flags = add_flag("types","NO",$flags);
- }
- $objects{$basepart} = $flags; # save new flags
- } else { # exists at least one slash, a DIR
- ($dirname) = split (/\//, $localpart);
- $dirs{$dirname} = ""; # no flags requirement for dir
- }
- }
- }
- } else {
- die "getter internal error: unsupported uritype: \"$uritype\"";
- }
- # now generate OUTPUT:
- # output will be saved in $content
- if ($format eq "txt") {
- foreach $key (sort(keys %dirs)) {
- $content .= "dir, " . $key . "\n";
- }
- foreach $key (sort(keys %objects)) {
- $content .= "object, $key, " . $objects{$key} . "\n";
- }
- } elsif ($format eq "xml") {
- $content .= "<ls>\n";
- foreach $key (sort(keys %dirs)) {
- $content .= "\t<section>$key</section>\n";
- }
- foreach $key (sort(keys %objects)) {
- $content .= "\t<object name=\"$key\">\n";
- $flags = $objects{$key};
- $flags =~ s/^<(.*)>$/$1/;
- my ($annflag,$typesflag) = split /,/,$flags;
- $content .= "\t\t<ann value=\"$annflag\" />\n";
- $content .= "\t\t<types value=\"$typesflag\" />\n";
- $content .= "\t</object>\n";
- }
- $content .= "</ls>\n";
- } else { # may not enter this branch
- die "Getter internal error: invalid format received by finduris sub";
- }
- return $content;
-}
-
-sub add_flag {
-# manage string like: "<ann_flag,type_flag>"
-# "ann_flag" may be one of "ann_YES", "ann_NO"
-# "type_flag" may be one of "types_NO", "types_YES", "types_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
- my ($flagtype,$newflag,$str) = @_;
- $str = "<,>" if ($str eq "");
- ($str =~ s/^<(.*,.*)>$/$1/) or die "Internal error: ".
- "wrong string format for flag adding in $str";
- my ($annflag,$typeflag) = split /,/,$str;
- if ($flagtype eq "ann") { # ANN flag handling
- if ($newflag eq "YES") {
- $annflag = "YES";
- } elsif ($newflag eq "NO") {
- $annflag = "NO" unless ($annflag eq "YES");
- } else {
- die "Internal error: annflag must be \"YES\" or \"NO\"";
- }
- } elsif ($flagtype eq "types") { # TYPES flag handling
- if ($newflag eq "ANN") {
- $typeflag = "ANN";
- } elsif ($newflag eq "YES") {
- $typeflag = "YES" unless ($typeflag eq "ANN");
- } elsif ($newflag eq "NO") {
- $typeflag = "NO"
- unless (($typeflag eq "ANN") or ($typeflag eq "YES"));
- } else {
- die "Internal error: typeflag must be \"YES\", \"NO\" or \"ANN\"";
- }
- } else {
- die "Internal error: unsupported flagtype \"$flagtype\"";
- }
- $str = "<$annflag,$typeflag>";
-}