--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *)
+
+open Markup_types
+open Markup_dtd
+open Markup_document
+
+type config =
+ { warner : collect_warnings;
+ errors_with_line_numbers : bool;
+ processing_instructions_inline : bool;
+ virtual_root : bool;
+ debugging_mode : bool;
+ }
+
+
+type source =
+ Entity of ((dtd -> Pxp_entity.entity) * Markup_reader.resolver)
+ | Channel of in_channel
+ | File of string
+ | Latin1 of string
+ | ExtID of (ext_id * Markup_reader.resolver)
+
+type 'ext domspec =
+ { map : (node_type, 'ext node) Hashtbl.t;
+ default_element : 'ext node;
+ }
+
+
+class default_ext =
+ object(self)
+ val mutable node = (None : ('a extension node as 'a) option)
+ method clone = {< >}
+ method node =
+ match node with
+ None ->
+ assert false
+ | Some n -> n
+ method set_node n =
+ node <- Some n
+ end
+;;
+
+
+let default_extension = new default_ext;;
+
+let default_config =
+ { warner = new collect_warnings;
+ errors_with_line_numbers = true;
+ processing_instructions_inline = false;
+ virtual_root = false;
+ debugging_mode = false;
+ }
+
+
+let default_dom =
+ let d = Hashtbl.create 2 in
+ Hashtbl.add d T_data (new data_impl default_extension "");
+ { map = d;
+ default_element = new element_impl default_extension
+ }
+;;
+
+
+let pxp_config cfg =
+ { Pxp_yacc.default_config with
+ Pxp_yacc.warner = (cfg.warner :> Pxp_types.collect_warnings);
+ Pxp_yacc.errors_with_line_numbers = cfg.errors_with_line_numbers;
+ Pxp_yacc.enable_pinstr_nodes = cfg.processing_instructions_inline;
+ Pxp_yacc.enable_super_root_node = cfg.virtual_root;
+ Pxp_yacc.encoding = `Enc_iso88591;
+ Pxp_yacc.recognize_standalone_declaration = false;
+ Pxp_yacc.debugging_mode = cfg.debugging_mode;
+ }
+;;
+
+
+class pxp_resolver r =
+ object (self)
+ val markup_resolver = r
+
+ method init_rep_encoding enc =
+ assert (enc = `Enc_iso88591 )
+
+ method init_warner w =
+ ()
+
+ method rep_encoding = `Enc_iso88591
+
+ method open_in xid =
+ markup_resolver # open_in xid
+
+ method close_in =
+ markup_resolver # close_in
+
+ method close_all =
+ markup_resolver # close_in
+
+ method change_encoding enc =
+ markup_resolver # change_encoding enc
+
+ method clone =
+ ( {< markup_resolver = markup_resolver # clone >}
+ : #Pxp_reader.resolver :> Pxp_reader.resolver )
+ end
+;;
+
+
+let pxp_source src =
+ match src with
+ Entity (mkent, res) -> Pxp_yacc.Entity(mkent, new pxp_resolver res)
+ | ExtID (id, res) -> Pxp_yacc.ExtID(id, new pxp_resolver res)
+ | Channel ch -> Pxp_yacc.from_channel
+ ~system_encoding:`Enc_iso88591 ch
+ | File f -> Pxp_yacc.from_file
+ ~system_encoding:`Enc_iso88591 f
+ | Latin1 s -> Pxp_yacc.from_string ~fixenc:`Enc_iso88591 s
+;;
+
+
+let pxp_dom dom =
+ let dex =
+ try Hashtbl.find dom.map T_data
+ with Not_found -> assert false
+ in
+ let eex = dom.default_element in
+ let m = Hashtbl.create 100 in
+ Hashtbl.iter
+ (fun nt ex ->
+ match nt with
+ T_element name when name <> "-vr" && name <> "-pi" ->
+ let pxp_ex = ex # pxp_node in
+ Hashtbl.add m name pxp_ex
+ | _ -> ()
+ )
+ dom.map;
+ let srex =
+ try
+ Some ((Hashtbl.find dom.map (T_element "-vr")) # pxp_node)
+ with
+ Not_found -> None
+ in
+ let piex =
+ try
+ Some ((Hashtbl.find dom.map (T_element "-pi")) # pxp_node)
+ with
+ Not_found -> None
+ in
+ Pxp_document.make_spec_from_mapping
+ ?super_root_exemplar:srex
+ ?default_pinstr_exemplar:piex
+ ~data_exemplar:(dex # pxp_node)
+ ~default_element_exemplar:(eex # pxp_node)
+ ~element_mapping:m
+ ()
+;;
+
+
+let markup_document w index doc =
+ let mdoc = new document w in
+ mdoc # init_xml_version (doc # xml_version);
+ mdoc # init_xml_standalone (doc # xml_standalone);
+ let r = doc # root # extension in
+ r # set_index index;
+ mdoc # init_root (r # markup_node);
+ List.iter
+ (fun piname ->
+ let l = doc # pinstr piname in
+ List.iter
+ (fun pi -> mdoc # add_pinstr pi)
+ l)
+ (doc # pinstr_names);
+ mdoc
+;;
+
+
+
+let parse_dtd_entity cfg src =
+ Pxp_yacc.parse_dtd_entity
+ (pxp_config cfg)
+ (pxp_source src)
+;;
+
+
+let parse_document_entity cfg src dom =
+ let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
+ markup_document
+ cfg.warner
+ index
+ (Pxp_yacc.parse_document_entity
+ ~id_index:index
+ (pxp_config cfg)
+ (pxp_source src)
+ (pxp_dom dom))
+;;
+
+
+let parse_content_entity cfg src dtd dom =
+ let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
+ let n =
+ (Pxp_yacc.parse_content_entity
+ ~id_index:index
+ (pxp_config cfg)
+ (pxp_source src)
+ dtd
+ (pxp_dom dom)) # extension in
+ n # set_index index;
+ n # markup_node
+;;
+
+
+let parse_wf_entity cfg src dom =
+ let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
+ (* Restriction: index is not filled! *)
+ markup_document
+ cfg.warner
+ index
+ (Pxp_yacc.parse_wfdocument_entity
+ (pxp_config cfg)
+ (pxp_source src)
+ (pxp_dom dom))
+;;
+
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:30 lpadovan
+ * Initial revision
+ *
+ * Revision 1.4 2000/08/18 20:19:16 gerd
+ * Updates in the emulation because of PXP changes.
+ *
+ * Revision 1.3 2000/07/14 21:35:35 gerd
+ * Updated because of the simplification of Pxp_types.collect_warnings.
+ *
+ * Revision 1.2 2000/07/08 17:40:50 gerd
+ * Updated the simulation.
+ *
+ * Revision 1.1 2000/05/29 23:43:51 gerd
+ * Initial compatibility revision.
+ *
+ *)
projects / helm.git / blobdiff