- let dirs = ref [] in
- let objs = Hashtbl.create 17 in
- xml_map#iter (* BLEARGH Dbm module lacks support for fold-like functions *)
- (fun _ -> function
- | uri when Pcre.pmatch ~pat:(pat ^ "/") uri -> (* directory hit *)
- let dir =
- List.hd (Pcre.split ~pat:"/" (Pcre.replace ~pat:(pat ^ "/") uri))
- in
- dirs := dir :: !dirs
- | uri when Pcre.pmatch ~pat:(pat ^ "(\\.|$)") uri -> (* object hit *)
- let localpart = Pcre.replace ~pat:"^.*/" uri in
- let basepart = Pcre.replace ~rex:basepartRE ~templ:"$1" localpart in
- let oldflags =
- try
- Hashtbl.find objs basepart
- with Not_found -> (false, No, No) (* no ann, no types no body *)
- in
- let newflags =
- match localpart with
- | s when Pcre.pmatch ~pat:"\\.types" s -> (false, Yes, No)
- | s when Pcre.pmatch ~pat:"\\.types.ann" s -> (true, Ann, No)
- | s when Pcre.pmatch ~pat:"\\.body" s -> (false, No, Yes)
- | s when Pcre.pmatch ~pat:"\\.body.ann" s -> (true, No, Ann)
- | s ->
- raise
- (Http_getter_internal_error ("Invalid /ls localpart: " ^ s))
- in
- Hashtbl.replace objs basepart (oldflags ++ newflags)
- | _ -> () (* miss *));
- match format with
- | Fmt_text ->
- let body =
- "dir, " ^ (String.concat "\ndir, " (List.sort compare !dirs)) ^ "\n" ^
- (Http_getter_misc.hashtbl_sorted_fold
- (fun uri (annflag, typesflag, bodyflag) cont ->
- sprintf
- "%sobject, %s, <%s,%s,%s>\n"
- cont uri (if annflag then "YES" else "NO")
- (string_of_ls_flag typesflag) (string_of_ls_flag bodyflag))
- objs "")
- in Http_daemon.respond ~headers:["Content-Type", "text/txt"] ~body outchan
- | Fmt_xml ->
- let body =
- sprintf
+ let (slash_RE, til_slash_RE, no_slashes_RE) =
+ (Pcre.regexp "/", Pcre.regexp "^.*/", Pcre.regexp "^[^/]*$")
+ in
+ fun lsuri fmt outchan ->
+ let pat =
+ "^" ^
+ (match lsuri with Cic p -> ("cic:" ^ p) | Theory p -> ("theory:" ^ p))
+ in
+ let (dir_RE, obj_RE) =
+ (Pcre.regexp (pat ^ "/"), Pcre.regexp (pat ^ "(\\.|$)"))
+ in
+ let dirs = ref StringSet.empty in
+ let objs = Hashtbl.create 17 in
+ let store_dir d =
+ dirs := StringSet.add (List.hd (Pcre.split ~rex:slash_RE d)) !dirs
+ in
+ let store_obj o =
+ let basepart = Pcre.replace ~rex:basepart_RE ~templ:"$1" o in
+ let oldflags =
+ try
+ Hashtbl.find objs basepart
+ with Not_found -> (false, No, No) (* no ann, no types no body *)
+ in
+ let newflags =
+ match o with
+ | s when Pcre.pmatch ~rex:types_RE s -> (false, Yes, No)
+ | s when Pcre.pmatch ~rex:types_ann_RE s -> (true, Ann, No)
+ | s when Pcre.pmatch ~rex:body_RE s -> (false, No, Yes)
+ | s when Pcre.pmatch ~rex:body_ann_RE s -> (true, No, Ann)
+ | s -> (false, No, No)
+ in
+ Hashtbl.replace objs basepart (oldflags ++ newflags)
+ in
+ xml_map#iter (* BLEARGH Dbm module lacks support for fold-like functions *)
+ (fun key _ ->
+ match key with
+ | uri when Pcre.pmatch ~rex:dir_RE uri -> (* directory hit *)
+ let localpart = Pcre.replace ~rex:dir_RE uri in
+ if Pcre.pmatch ~rex:no_slashes_RE localpart then
+ store_obj localpart
+ else
+ store_dir localpart
+ | uri when Pcre.pmatch ~rex:obj_RE uri -> (* file hit *)
+ store_obj (Pcre.replace ~rex:til_slash_RE uri)
+ | uri -> () (* miss *));
+ match fmt with
+ | Fmt_text ->
+ let body =
+ (List.fold_left
+ (fun s d -> sprintf "%sdir, %s\n" s d) ""
+ (StringSet.elements !dirs)) ^
+ (Http_getter_misc.hashtbl_sorted_fold
+ (fun uri (annflag, typesflag, bodyflag) cont ->
+ sprintf "%sobject, %s, <%s,%s,%s>\n"
+ cont uri (if annflag then "YES" else "NO")
+ (string_of_ls_flag typesflag) (string_of_ls_flag bodyflag))
+ objs "")
+ in
+ Http_daemon.respond
+ ~headers:(("Content-Type", "text/plain") :: common_headers)
+ ~body outchan
+ | Fmt_xml ->
+ let body =
+ sprintf