+++ /dev/null
-(* $Id$
- * ----------------------------------------------------------------------
- * PXP: The polymorphic XML parser for Objective Caml.
- * Copyright by Gerd Stolpmann. See LICENSE for details.
- *)
-
-open Pxp_types;;
-exception Not_competent;;
-exception Not_resolvable of exn;;
-
-class type resolver =
- object
- method init_rep_encoding : rep_encoding -> unit
- method init_warner : collect_warnings -> unit
- method rep_encoding : rep_encoding
- method open_in : ext_id -> Lexing.lexbuf
- method close_in : unit
- method close_all : unit
- method change_encoding : string -> unit
- method clone : resolver
- end
-;;
-
-
-class virtual resolve_general
- =
- object (self)
- val mutable internal_encoding = `Enc_utf8
-
- val mutable encoding = `Enc_utf8
- val mutable encoding_requested = false
-
- val mutable warner = new drop_warnings
-
- val mutable enc_initialized = false
- val mutable wrn_initialized = false
-
- val mutable clones = []
-
- method init_rep_encoding e =
- internal_encoding <- e;
- enc_initialized <- true;
-
- method init_warner w =
- warner <- w;
- wrn_initialized <- true;
-
- method rep_encoding = (internal_encoding :> rep_encoding)
-
-(*
- method clone =
- ( {< encoding = `Enc_utf8;
- encoding_requested = false;
- >}
- : # resolver :> resolver )
-*)
-
- method private warn (k:int) =
- (* Called if a character not representable has been found.
- * k is the character code.
- *)
- if k < 0xd800 or (k >= 0xe000 & k <= 0xfffd) or
- (k >= 0x10000 & k <= 0x10ffff) then begin
- warner # warn ("Code point cannot be represented: " ^ string_of_int k);
- end
- else
- raise (WF_error("Code point " ^ string_of_int k ^
- " outside the accepted range of code points"))
-
-
- method private autodetect s =
- (* s must be at least 4 bytes long. The slot 'encoding' is
- * set to:
- * "UTF-16-BE": UTF-16/UCS-2 encoding big endian
- * "UTF-16-LE": UTF-16/UCS-2 encoding little endian
- * "UTF-8": UTF-8 encoding
- *)
- if String.length s < 4 then
- encoding <- `Enc_utf8
- else if String.sub s 0 2 = "\254\255" then
- encoding <- `Enc_utf16
- (* Note: Netconversion.recode will detect the big endianess, too *)
- else if String.sub s 0 2 = "\255\254" then
- encoding <- `Enc_utf16
- (* Note: Netconversion.recode will detect the little endianess, too *)
- else
- encoding <- `Enc_utf8
-
-
- method private virtual next_string : string -> int -> int -> int
- method private virtual init_in : ext_id -> unit
- method virtual close_in : unit
-
- method close_all =
- List.iter (fun r -> r # close_in) clones
-
- method open_in xid =
- assert(enc_initialized && wrn_initialized);
-
- encoding <- `Enc_utf8;
- encoding_requested <- false;
- self # init_in xid; (* may raise Not_competent *)
- (* init_in: may already set 'encoding' *)
-
- let buffer_max = 512 in
- let buffer = String.make buffer_max ' ' in
- let buffer_len = ref 0 in
- let buffer_end = ref false in
- let fillup () =
- if not !buffer_end & !buffer_len < buffer_max then begin
- let l =
- self # next_string buffer !buffer_len (buffer_max - !buffer_len) in
- if l = 0 then
- buffer_end := true
- else begin
- buffer_len := !buffer_len + l
- end
- end
- in
- let consume n =
- let l = !buffer_len - n in
- String.blit buffer n buffer 0 l;
- buffer_len := l
- in
-
- fillup();
- if not encoding_requested then self # autodetect buffer;
-
- Lexing.from_function
- (fun s n ->
- (* TODO: if encoding = internal_encoding, it is possible to
- * avoid copying buffer to s because s can be directly used
- * as buffer.
- *)
-
- fillup();
- if !buffer_len = 0 then
- 0
- else begin
- let m_in = !buffer_len in
- let m_max = if encoding_requested then n else 1 in
- let n_in, n_out, encoding' =
- if encoding = (internal_encoding : rep_encoding :> encoding) &&
- encoding_requested
- then begin
- (* Special case encoding = internal_encoding *)
- String.blit buffer 0 s 0 m_in;
- m_in, m_in, encoding
- end
- else
- Netconversion.recode
- ~in_enc:encoding
- ~in_buf:buffer
- ~in_pos:0
- ~in_len:m_in
- ~out_enc:(internal_encoding : rep_encoding :> encoding)
- ~out_buf:s
- ~out_pos:0
- ~out_len:n
- ~max_chars:m_max
- ~subst:(fun k -> self # warn k; "")
- in
- if n_in = 0 then
- (* An incomplete character at the end of the stream: *)
- raise Netconversion.Malformed_code;
- (* failwith "Badly encoded character"; *)
- encoding <- encoding';
- consume n_in;
- assert(n_out <> 0);
- n_out
- end)
-
- method change_encoding enc =
- if not encoding_requested then begin
- if enc <> "" then begin
- match Netconversion.encoding_of_string enc with
- `Enc_utf16 ->
- (match encoding with
- (`Enc_utf16_le | `Enc_utf16_be) -> ()
- | `Enc_utf16 -> assert false
- | _ ->
- raise(WF_error "Encoding of data stream and encoding declaration mismatch")
- )
- | e ->
- encoding <- e
- end;
- (* else: the autodetected encoding counts *)
- encoding_requested <- true;
- end;
- end
-;;
-
-
-class resolve_read_any_channel ?(auto_close=true) ~channel_of_id =
- object (self)
- inherit resolve_general as super
-
- val f_open = channel_of_id
- val mutable current_channel = None
- val auto_close = auto_close
-
- method private init_in (id:ext_id) =
- if current_channel <> None then
- failwith "Pxp_reader.resolve_read_any_channel # init_in";
- let ch, enc_opt = f_open id in (* may raise Not_competent *)
- begin match enc_opt with
- None -> ()
- | Some enc -> encoding <- enc; encoding_requested <- true
- end;
- current_channel <- Some ch;
-
- method private next_string s ofs len =
- match current_channel with
- None -> failwith "Pxp_reader.resolve_read_any_channel # next_string"
- | Some ch ->
- input ch s ofs len
-
- method close_in =
- match current_channel with
- None -> ()
- | Some ch ->
- if auto_close then close_in ch;
- current_channel <- None
-
- method clone =
- let c = new resolve_read_any_channel
- ?auto_close:(Some auto_close) f_open in
- c # init_rep_encoding internal_encoding;
- c # init_warner warner;
- clones <- c :: clones;
- (c :> resolver)
-
- end
-;;
-
-
-class resolve_read_this_channel1 is_stale ?id ?fixenc ?auto_close ch =
-
- let getchannel = ref (fun xid -> assert false) in
-
- object (self)
- inherit resolve_read_any_channel
- ?auto_close:auto_close
- (fun xid -> !getchannel xid)
- as super
-
- val mutable is_stale = is_stale
- (* The channel can only be read once. To avoid that the channel
- * is opened several times, the flag 'is_stale' is set after the
- * first time.
- *)
-
- val fixid = id
- val fixenc = fixenc
- val fixch = ch
-
- initializer
- getchannel := self # getchannel
-
- method private getchannel xid =
- begin match fixid with
- None -> ()
- | Some bound_xid ->
- if xid <> bound_xid then raise Not_competent
- end;
- ch, fixenc
-
- method private init_in (id:ext_id) =
- if is_stale then
- raise Not_competent
- else begin
- super # init_in id;
- is_stale <- true
- end
-
- method close_in =
- current_channel <- None
-
- method clone =
- let c = new resolve_read_this_channel1
- is_stale
- ?id:fixid ?fixenc:fixenc ?auto_close:(Some auto_close) fixch
- in
- c # init_rep_encoding internal_encoding;
- c # init_warner warner;
- clones <- c :: clones;
- (c :> resolver)
-
- end
-;;
-
-
-class resolve_read_this_channel =
- resolve_read_this_channel1 false
-;;
-
-
-class resolve_read_any_string ~string_of_id =
- object (self)
- inherit resolve_general as super
-
- val f_open = string_of_id
- val mutable current_string = None
- val mutable current_pos = 0
-
- method private init_in (id:ext_id) =
- if current_string <> None then
- failwith "Pxp_reader.resolve_read_any_string # init_in";
- let s, enc_opt = f_open id in (* may raise Not_competent *)
- begin match enc_opt with
- None -> ()
- | Some enc -> encoding <- enc; encoding_requested <- true
- end;
- current_string <- Some s;
- current_pos <- 0;
-
- method private next_string s ofs len =
- match current_string with
- None -> failwith "Pxp_reader.resolve_read_any_string # next_string"
- | Some str ->
- let l = min len (String.length str - current_pos) in
- String.blit str current_pos s ofs l;
- current_pos <- current_pos + l;
- l
-
- method close_in =
- match current_string with
- None -> ()
- | Some _ ->
- current_string <- None
-
- method clone =
- let c = new resolve_read_any_string f_open in
- c # init_rep_encoding internal_encoding;
- c # init_warner warner;
- clones <- c :: clones;
- (c :> resolver)
- end
-;;
-
-
-class resolve_read_this_string1 is_stale ?id ?fixenc str =
-
- let getstring = ref (fun xid -> assert false) in
-
- object (self)
- inherit resolve_read_any_string (fun xid -> !getstring xid) as super
-
- val is_stale = is_stale
- (* For some reasons, it is not allowed to open a clone of the resolver
- * a second time when the original resolver is already open.
- *)
-
- val fixid = id
- val fixenc = fixenc
- val fixstr = str
-
- initializer
- getstring := self # getstring
-
- method private getstring xid =
- begin match fixid with
- None -> ()
- | Some bound_xid ->
- if xid <> bound_xid then raise Not_competent
- end;
- fixstr, fixenc
-
-
- method private init_in (id:ext_id) =
- if is_stale then
- raise Not_competent
- else
- super # init_in id
-
- method clone =
- let c = new resolve_read_this_string1
- (is_stale or current_string <> None)
- ?id:fixid ?fixenc:fixenc fixstr
- in
- c # init_rep_encoding internal_encoding;
- c # init_warner warner;
- clones <- c :: clones;
- (c :> resolver)
- end
-;;
-
-
-class resolve_read_this_string =
- resolve_read_this_string1 false
-;;
-
-
-class resolve_read_url_channel
- ?(base_url = Neturl.null_url)
- ?auto_close
- ~url_of_id
- ~channel_of_url
-
- : resolver
- =
-
- let getchannel = ref (fun xid -> assert false) in
-
- object (self)
- inherit resolve_read_any_channel
- ?auto_close:auto_close
- (fun xid -> !getchannel xid)
- as super
-
- val base_url = base_url
- val mutable own_url = Neturl.null_url
-
- val url_of_id = url_of_id
- val channel_of_url = channel_of_url
-
-
- initializer
- getchannel := self # getchannel
-
- method private getchannel xid =
- let rel_url = url_of_id xid in (* may raise Not_competent *)
-
- try
- (* Now compute the absolute URL: *)
- let abs_url = Neturl.apply_relative_url base_url rel_url in
- (* may raise Malformed_URL *)
-
- (* Simple check whether 'abs_url' is really absolute: *)
- if not(Neturl.url_provides ~scheme:true abs_url)
- then raise Not_competent;
-
- own_url <- abs_url;
- (* FIXME: Copy 'abs_url' ? *)
-
- (* Get and return the channel: *)
- channel_of_url abs_url (* may raise Not_competent *)
- with
- Neturl.Malformed_URL -> raise (Not_resolvable Neturl.Malformed_URL)
- | Not_competent -> raise (Not_resolvable Not_found)
-
- method clone =
- let c =
- new resolve_read_url_channel
- ?base_url:(Some own_url)
- ?auto_close:(Some auto_close)
- ~url_of_id:url_of_id
- ~channel_of_url:channel_of_url
- in
- c # init_rep_encoding internal_encoding;
- c # init_warner warner;
- clones <- c :: clones;
- (c :> resolve_read_url_channel)
- end
-;;
-
-
-type spec = [ `Not_recognized | `Allowed | `Required ]
-
-class resolve_as_file
- ?(file_prefix = (`Allowed :> spec))
- ?(host_prefix = (`Allowed :> spec))
- ?(system_encoding = `Enc_utf8)
- ?url_of_id:passed_url_of_id
- ?channel_of_url:passed_channel_of_url
- ()
- =
-
- 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 file_prefix;
- Neturl.url_enable_host = enable_if host_prefix;
- Neturl.url_enable_path = Neturl.Url_part_required;
- Neturl.url_accepts_8bits = true;
- }
- in
-
- let base_url_syntax =
- { Neturl.null_url_syntax with
- Neturl.url_enable_scheme = Neturl.Url_part_required;
- Neturl.url_enable_host = Neturl.Url_part_allowed;
- Neturl.url_enable_path = Neturl.Url_part_required;
- Neturl.url_accepts_8bits = true;
- }
- in
-
- let default_base_url =
- Neturl.make_url
- ~scheme: "file"
- ~host: ""
- ~path: (Neturl.split_path (Sys.getcwd() ^ "/"))
- base_url_syntax
- in
-
- 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 Not_competent
- in
- let url =
- match xid with
- Anonymous -> raise Not_competent
- | Public (_,sysname) -> if sysname <> "" then file_url_of_sysname sysname
- else raise Not_competent
- | System sysname -> 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 Not_competent;
- if host <> "" && host <> "localhost" then raise Not_competent;
-
- url
- in
-
- let channel_of_file_url url =
- try
- let path_utf8 =
- try Neturl.join_path (Neturl.url_path ~encoded:false url)
- with Not_found -> raise Not_competent
- in
-
- let path =
- Netconversion.recode_string
- ~in_enc: `Enc_utf8
- ~out_enc: system_encoding
- path_utf8 in
- (* May raise Bad_character_stream *)
-
- open_in_bin path, None
- (* May raise Sys_error *)
-
- with
- | Netconversion.Malformed_code -> assert false
- (* should not happen *)
-
- in
-
- let url_of_id id =
- match passed_url_of_id with
- None ->
- file_url_of_id id
- | Some f ->
- begin
- try f id
- with
- Not_competent -> file_url_of_id id
- end
- in
-
- let channel_of_url url =
- match passed_channel_of_url with
- None ->
- channel_of_file_url url
- | Some f ->
- begin
- try f url
- with
- Not_competent -> channel_of_file_url url
- end
- in
-
- resolve_read_url_channel
- ~base_url: default_base_url
- ~auto_close: true
- ~url_of_id: url_of_id
- ~channel_of_url: channel_of_url
-;;
-
-
-class combine ?prefer rl =
- object (self)
- val prefered_resolver = prefer
- val resolvers = (rl : resolver list)
- val mutable internal_encoding = `Enc_utf8
- val mutable warner = new drop_warnings
- val mutable active_resolver = None
- val mutable clones = []
-
- method init_rep_encoding enc =
- List.iter
- (fun r -> r # init_rep_encoding enc)
- rl;
- internal_encoding <- enc
-
- method init_warner w =
- List.iter
- (fun r -> r # init_warner w)
- rl;
- warner <- w;
-
- method rep_encoding = internal_encoding
- (* CAUTION: This may not be the truth! *)
-
- method open_in xid =
- let rec find_competent_resolver rl =
- match rl with
- r :: rl' ->
- begin try
- r, (r # open_in xid)
- with
- Not_competent -> find_competent_resolver rl'
- end;
- | [] ->
- raise Not_competent
- in
-
- if active_resolver <> None then failwith "Pxp_reader.combine # open_in";
- let r, lb =
- match prefered_resolver with
- None -> find_competent_resolver resolvers
- | Some r -> find_competent_resolver (r :: resolvers)
- in
- active_resolver <- Some r;
- lb
-
- method close_in =
- match active_resolver with
- None -> ()
- | Some r -> r # close_in;
- active_resolver <- None
-
- method close_all =
- List.iter (fun r -> r # close_in) clones
-
- method change_encoding (enc:string) =
- match active_resolver with
- None -> failwith "Pxp_reader.combine # change_encoding"
- | Some r -> r # change_encoding enc
-
- method clone =
- let c =
- match active_resolver with
- None ->
- new combine ?prefer:None (List.map (fun q -> q # clone) resolvers)
- | Some r ->
- let r' = r # clone in
- new combine
- ?prefer:(Some r')
- (List.map
- (fun q -> if q == r then r' else q # clone)
- resolvers)
- in
- c # init_rep_encoding internal_encoding;
- c # init_warner warner;
- clones <- c :: clones;
- c
- end
-
-
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:29 lpadovan
- * Initial revision
- *
- * Revision 1.9 2000/08/14 22:24:55 gerd
- * Moved the module Pxp_encoding to the netstring package under
- * the new name Netconversion.
- *
- * Revision 1.8 2000/07/16 18:31:09 gerd
- * The exception Illegal_character has been dropped.
- *
- * Revision 1.7 2000/07/09 15:32:01 gerd
- * Fix in resolve_this_channel, resolve_this_string
- *
- * Revision 1.6 2000/07/09 01:05:33 gerd
- * New methode 'close_all' that closes the clones, too.
- *
- * Revision 1.5 2000/07/08 16:24:56 gerd
- * Introduced the exception 'Not_resolvable' to indicate that
- * 'combine' should not try the next resolver of the list.
- *
- * Revision 1.4 2000/07/06 23:04:46 gerd
- * Quick fix for 'combine': The active resolver is "prefered",
- * but the other resolvers are also used.
- *
- * Revision 1.3 2000/07/06 21:43:45 gerd
- * Fix: Public(_,name) is now treated as System(name) if
- * name is non-empty.
- *
- * Revision 1.2 2000/07/04 22:13:30 gerd
- * Implemented the new API rev. 1.2 of pxp_reader.mli.
- *
- * Revision 1.1 2000/05/29 23:48:38 gerd
- * Changed module names:
- * Markup_aux into Pxp_aux
- * Markup_codewriter into Pxp_codewriter
- * Markup_document into Pxp_document
- * Markup_dtd into Pxp_dtd
- * Markup_entity into Pxp_entity
- * Markup_lexer_types into Pxp_lexer_types
- * Markup_reader into Pxp_reader
- * Markup_types into Pxp_types
- * Markup_yacc into Pxp_yacc
- * See directory "compatibility" for (almost) compatible wrappers emulating
- * Markup_document, Markup_dtd, Markup_reader, Markup_types, and Markup_yacc.
- *
- * ======================================================================
- * Old logs from markup_reader.ml:
- *
- * Revision 1.3 2000/05/29 21:14:57 gerd
- * Changed the type 'encoding' into a polymorphic variant.
- *
- * Revision 1.2 2000/05/20 20:31:40 gerd
- * Big change: Added support for various encodings of the
- * internal representation.
- *
- * Revision 1.1 2000/03/13 23:41:44 gerd
- * Initial revision; this code was formerly part of Markup_entity.
- *
- *
- *)
projects / helm.git / blobdiff