-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 11/10/2000 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-let resolve s =
- let starts_with s s' =
- if String.length s < String.length s' then
- false
- else
- (String.sub s 0 (String.length s')) = s'
- in
- if starts_with s "http:" then
- ClientHTTP.get_and_save_to_tmp s
- else
- s
-;;
-
-let url_syntax =
- let enable_if =
- function
- `Not_recognized -> Neturl.Url_part_not_recognized
- | `Allowed -> Neturl.Url_part_allowed
- | `Required -> Neturl.Url_part_required
- in
- { Neturl.null_url_syntax with
- Neturl.url_enable_scheme = enable_if `Allowed;
- Neturl.url_enable_host = enable_if `Allowed;
- Neturl.url_enable_path = Neturl.Url_part_required;
- Neturl.url_accepts_8bits = true;
- }
-;;
-
-let file_url_of_id xid =
- let file_url_of_sysname sysname =
- (* By convention, we can assume that sysname is a URL conforming
- * to RFC 1738 with the exception that it may contain non-ASCII
- * UTF-8 characters.
- *)
- try
- Neturl.url_of_string url_syntax sysname
- (* may raise Malformed_URL *)
- with
- Neturl.Malformed_URL -> raise Pxp_reader.Not_competent
- in
- let url =
- match xid with
- Pxp_types.Anonymous -> raise Pxp_reader.Not_competent
- | Pxp_types.Public (_,sysname) ->
- let sysname = resolve sysname in
- if sysname <> "" then file_url_of_sysname sysname
- else raise Pxp_reader.Not_competent
- | Pxp_types.System sysname ->
- let sysname = resolve sysname in
- file_url_of_sysname sysname
- in
- let scheme =
- try Neturl.url_scheme url with Not_found -> "file" in
- let host =
- try Neturl.url_host url with Not_found -> "" in
-
- if scheme <> "file" then raise Pxp_reader.Not_competent;
- if host <> "" && host <> "localhost" then raise Pxp_reader.Not_competent;
-
- url
-;;
-
-let from_file ?system_encoding utf8_filename =
-
- let r =
- new Pxp_reader.resolve_as_file
- ?system_encoding:system_encoding
- ~url_of_id:file_url_of_id
- ()
- in
-
- let utf8_abs_filename =
- if utf8_filename <> "" && utf8_filename.[0] = '/' then
- utf8_filename
- else
- Sys.getcwd() ^ "/" ^ utf8_filename
- in
-
- let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in
- let url = Neturl.make_url
- ~scheme:"file"
- ~host:"localhost"
- ~path:(Neturl.split_path utf8_abs_filename)
- syntax
- in
-
- let xid = Pxp_types.System (Neturl.string_of_url url) in
-
-
- Pxp_yacc.ExtID(xid, r)
-;;
-
-