X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2FDEVEL%2Fpxp%2Fpxp%2Fpxp_document.ml;fp=helm%2FDEVEL%2Fpxp%2Fpxp%2Fpxp_document.ml;h=0000000000000000000000000000000000000000;hp=1f1d4cf684f4ae13fae57f180dfb790176a2996d;hb=869549224eef6278a48c16ae27dd786376082b38;hpb=89262281b6e83bd2321150f81f1a0583645eb0c8 diff --git a/helm/DEVEL/pxp/pxp/pxp_document.ml b/helm/DEVEL/pxp/pxp/pxp_document.ml deleted file mode 100644 index 1f1d4cf68..000000000 --- a/helm/DEVEL/pxp/pxp/pxp_document.ml +++ /dev/null @@ -1,1985 +0,0 @@ -(* $Id$ - * ---------------------------------------------------------------------- - * PXP: The polymorphic XML parser for Objective Caml. - * Copyright by Gerd Stolpmann. See LICENSE for details. - *) - -open Pxp_types -open Pxp_lexer_types -open Pxp_dtd -open Pxp_aux -open Pxp_dfa - - -exception Skip - -type node_type = - T_element of string - | T_data - | T_super_root - | T_pinstr of string - | T_comment - | T_none - | T_attribute of string - | T_namespace of string -;; - - -class type ['node] extension = - object ('self) - method clone : 'self - method node : 'node - method set_node : 'node -> unit - end -;; - - -class type [ 'ext ] node = - object ('self) - constraint 'ext = 'ext node #extension - method extension : 'ext - method delete : unit - method parent : 'ext node - method root : 'ext node - method orphaned_clone : 'self - method orphaned_flat_clone : 'self - method add_node : ?force:bool -> 'ext node -> unit - method add_pinstr : proc_instruction -> unit - method pinstr : string -> proc_instruction list - method pinstr_names : string list - method node_position : int - method node_path : int list - method sub_nodes : 'ext node list - method iter_nodes : ('ext node -> unit) -> unit - method iter_nodes_sibl : - ('ext node option -> 'ext node -> 'ext node option -> unit) -> unit - method nth_node : int -> 'ext node - method previous_node : 'ext node - method next_node : 'ext node - method set_nodes : 'ext node list -> unit - method data : string - method node_type : node_type - method position : (string * int * int) - method attribute : string -> att_value - method attribute_names : string list - method attribute_type : string -> att_type - method attributes : (string * Pxp_types.att_value) list - method required_string_attribute : string -> string - method required_list_attribute : string -> string list - method optional_string_attribute : string -> string option - method optional_list_attribute : string -> string list - method id_attribute_name : string - method id_attribute_value : string - method idref_attribute_names : string list - method quick_set_attributes : (string * Pxp_types.att_value) list -> unit - method attributes_as_nodes : 'ext node list - method set_comment : string option -> unit - method comment : string option - method dtd : dtd - method encoding : rep_encoding - method create_element : - ?position:(string * int * int) -> - dtd -> node_type -> (string * string) list -> 'ext node - method create_data : dtd -> string -> 'ext node - method local_validate : ?use_dfa:bool -> unit -> unit - method keep_always_whitespace_mode : unit - method write : output_stream -> encoding -> unit - method write_compact_as_latin1 : output_stream -> unit - method internal_adopt : 'ext node option -> int -> unit - method internal_set_pos : int -> unit - method internal_delete : 'ext node -> unit - method internal_init : (string * int * int) -> - dtd -> string -> (string * string) list -> unit - method internal_init_other : (string * int * int) -> - dtd -> node_type -> unit - end -;; - -type 'ext spec_table = - { mapping : (string, 'ext node) Hashtbl.t; - data_node : 'ext node; - default_element : 'ext node; - super_root_node : 'ext node option; - pinstr_mapping : (string, 'ext node) Hashtbl.t; - default_pinstr_node : 'ext node option; - comment_node : 'ext node option; - } -;; - -type 'ext spec = - Spec_table of 'ext spec_table -;; - - -let make_spec_from_mapping - ?super_root_exemplar - ?comment_exemplar - ?default_pinstr_exemplar - ?pinstr_mapping - ~data_exemplar ~default_element_exemplar ~element_mapping () = - Spec_table - { mapping = element_mapping; - data_node = data_exemplar; - default_element = default_element_exemplar; - super_root_node = super_root_exemplar; - comment_node = comment_exemplar; - default_pinstr_node = default_pinstr_exemplar; - pinstr_mapping = - (match pinstr_mapping with - None -> Hashtbl.create 1 - | Some m -> m - ) - } -;; - - -let make_spec_from_alist - ?super_root_exemplar - ?comment_exemplar - ?default_pinstr_exemplar - ?(pinstr_alist = []) - ~data_exemplar ~default_element_exemplar ~element_alist () = - let m = List.length pinstr_alist in - let pinstr_mapping = Hashtbl.create m in - List.iter - (fun (name,ex) -> Hashtbl.add pinstr_mapping name ex) - pinstr_alist; - let n = List.length element_alist in - let element_mapping = Hashtbl.create m in - List.iter - (fun (name,ex) -> Hashtbl.add element_mapping name ex) - element_alist; - make_spec_from_mapping - ?super_root_exemplar: super_root_exemplar - ?comment_exemplar: comment_exemplar - ?default_pinstr_exemplar: default_pinstr_exemplar - ~pinstr_mapping: pinstr_mapping - ~data_exemplar: data_exemplar - ~default_element_exemplar: default_element_exemplar - ~element_mapping: element_mapping - () -;; - -(**********************************************************************) - -exception Found;; - -let validate_content ?(use_dfa=None) model (el : 'a node) = - (* checks that the nodes of 'el' matches the DTD. Returns 'true' - * on success and 'false' on failure. - *) - - let rec is_empty cl = - (* Whether the node list counts as empty or not. *) - match cl with - [] -> true - | n :: cl' -> - ( match n # node_type with - | T_element _ -> false - | _ -> is_empty cl' (* ignore other nodes *) - ) - in - - let rec run_regexp cl ml = - (* Validates regexp content models ml against instances cl. This - * function works for deterministic and non-determninistic models. - * The implementation uses backtracking and may sometimes be slow. - * - * cl: the list of children that will have to be matched - * ml: the list of regexps that will have to match (to be read as - * sequence) - * returns () meaning that no match has been found, or raises Found. - *) - match ml with - [] -> - if cl = [] then raise Found; (* Frequent case *) - if is_empty cl then raise Found; (* General condition *) - | Seq seq :: ml' -> - assert (seq <> []); (* necessary to ensure termination *) - run_regexp cl (seq @ ml') - | Alt alts :: ml' -> - let rec find alts = - match alts with - [] -> () - | alt :: alts' -> - run_regexp cl (alt :: ml'); - find alts' - in - assert (alts <> []); (* Alt [] matches nothing *) - find alts - | Repeated re :: ml' -> - let rec norm re = (* to avoid infinite loops *) - match re with - Repeated subre -> norm subre (* necessary *) - | Optional subre -> norm subre (* necessary *) - | Repeated1 subre -> norm subre (* an optimization *) - | _ -> re - in - let re' = norm re in - run_regexp cl (re' :: Repeated re' :: ml'); - run_regexp cl ml' - | Repeated1 re :: ml' -> - run_regexp cl (re :: Repeated re :: ml') - | Optional re :: ml' -> - run_regexp cl (re :: ml'); - run_regexp cl ml'; - | Child chld :: ml' -> - match cl with - [] -> - () - | sub_el :: cl' -> - begin match sub_el # node_type with - T_data -> (* Ignore data *) - run_regexp cl' ml - (* Note: It can happen that we find a data node here - * if the 'keep_always_whitespace' mode is turned on. - *) - | T_element nt -> - if nt = chld then run_regexp cl' ml' - | _ -> (* Ignore this element *) - run_regexp cl' ml - end - in - - let run_dfa cl dfa = - (* Validates regexp content models ml against instances cl. This - * function works ONLY for deterministic models. - * The implementation executes the automaton. - *) - let current_vertex = ref dfa.dfa_start in - let rec next_step cl = - match cl with - el :: cl' -> - begin match el # node_type with - T_data -> (* Ignore data *) - next_step cl' - (* Note: It can happen that we find a data node here - * if the 'keep_always_whitespace' mode is turned on. - *) - | T_element nt -> - begin try - current_vertex := Graph.follow_edge !current_vertex nt; - next_step cl' - with - Not_found -> false - end - | _ -> (* Ignore this node *) - next_step cl' - end - | [] -> - VertexSet.mem !current_vertex dfa.dfa_stops - in - next_step cl - in - - match model with - Unspecified -> true - | Any -> true - | Empty -> - let cl = el # sub_nodes in - is_empty cl - | Mixed (MPCDATA :: mix) -> - let mix' = List.map (function - MPCDATA -> assert false - | MChild x -> x) - mix in - begin try - el # iter_nodes - (fun sub_el -> - let nt = sub_el # node_type in - match nt with - | T_element name -> - if not (List.mem name mix') then raise Not_found; - | _ -> () - ); - true - with - Not_found -> - false - end - | Regexp re -> - let cl = el # sub_nodes in - begin match use_dfa with - None -> - (* General backtracking implementation: *) - begin try - run_regexp cl [re]; - false - with - Found -> true - end - | Some dfa -> - run_dfa cl dfa - end - - | _ -> assert false -;; - -(**********************************************************************) - - -class virtual ['ext] node_impl an_ext = - object (self) - constraint 'ext = 'ext node #extension - - val mutable parent = (None : 'ext node option) - val mutable node_position = -1 - val mutable dtd = (None : dtd option) - val mutable extension = an_ext - - initializer - extension # set_node (self : 'ext #node :> 'ext node) - - - method extension = (extension : 'ext) - - method delete = - match parent with - None -> () - | Some p -> p # internal_delete (self : 'ext #node :> 'ext node) - - method parent = - match parent with - None -> raise Not_found - | Some p -> p - - method root = - match parent with - None -> (self : 'ext #node :> 'ext node) - | Some p -> p # root - - method node_position = - if node_position >= 0 then node_position else - raise Not_found - - method node_path = - let rec collect n path = - try - let p = n # node_position in - collect (n # parent) (p :: path) - with - Not_found -> - (* n is the root *) - path - in - collect (self : 'ext #node :> 'ext node) [] - - method previous_node = - self # parent # nth_node (self # node_position - 1) - - method next_node = - self # parent # nth_node (self # node_position + 1) - - method orphaned_clone = - let x = extension # clone in - let n = - {< parent = None; - node_position = -1; - extension = x; - >} in - x # set_node (n : 'ext #node :> 'ext node); - n - - method orphaned_flat_clone = - let x = extension # clone in - let n = - {< parent = None; - node_position = -1; - extension = x; - >} in - x # set_node (n : 'ext #node :> 'ext node); - n - - method dtd = - match dtd with - None -> failwith "Pxp_document.node_impl#dtd: No DTD available" - | Some d -> d - - method encoding = - match dtd with - None -> failwith "Pxp_document.node_impl#encoding: No DTD available" - | Some d -> d # encoding - - method internal_adopt (new_parent : 'ext node option) pos = - begin match parent with - None -> () - | Some p -> - if new_parent <> None then - failwith "Pxp_document.node_impl#internal_adopt: Tried to add a bound element" - end; - parent <- new_parent; - node_position <- pos - - method internal_set_pos pos = - node_position <- pos - - method virtual add_node : ?force:bool -> 'ext node -> unit - method virtual add_pinstr : proc_instruction -> unit - method virtual sub_nodes : 'ext node list - method virtual pinstr : string -> proc_instruction list - method virtual pinstr_names : string list - method virtual iter_nodes : ('ext node -> unit) -> unit - method virtual iter_nodes_sibl : ('ext node option -> 'ext node -> 'ext node option -> unit) -> unit - method virtual nth_node : int -> 'ext node - method virtual set_nodes : 'ext node list -> unit - method virtual data : string - method virtual node_type : node_type - method virtual position : (string * int * int) - method virtual attribute : string -> att_value - method virtual attribute_names : string list - method virtual attribute_type : string -> att_type - method virtual attributes : (string * Pxp_types.att_value) list - method virtual required_string_attribute : string -> string - method virtual required_list_attribute : string -> string list - method virtual optional_string_attribute : string -> string option - method virtual optional_list_attribute : string -> string list - method virtual quick_set_attributes : (string * Pxp_types.att_value) list -> unit - method virtual attributes_as_nodes : 'ext node list - method virtual set_comment : string option -> unit - method virtual comment : string option - method virtual create_element : - ?position:(string * int * int) -> - dtd -> node_type -> (string * string) list -> 'ext node - method virtual create_data : dtd -> string -> 'ext node - method virtual keep_always_whitespace_mode : unit - method virtual write : output_stream -> encoding -> unit - method virtual write_compact_as_latin1 : output_stream -> unit - method virtual local_validate : ?use_dfa:bool -> unit -> unit - method virtual internal_delete : 'ext node -> unit - method virtual internal_init : (string * int * int) -> - dtd -> string -> (string * string) list -> unit - method virtual internal_init_other : (string * int * int) -> - dtd -> node_type -> unit - end -;; - - -(**********************************************************************) - -let no_position = ("?", 0, 0) ;; - - -class ['ext] data_impl an_ext : ['ext] node = - object (self) - inherit ['ext] node_impl an_ext - val mutable content = ("" : string) - - method position = no_position - - method add_node ?(force=false) _ = - failwith "method 'add_node' not applicable to data node" - method add_pinstr _ = - failwith "method 'add_pinstr' not applicable to data node" - method pinstr _ = [] - method pinstr_names = [] - method sub_nodes = [] - method iter_nodes _ = () - method iter_nodes_sibl _ = () - method nth_node _ = raise Not_found - method set_nodes _ = - failwith "method 'set_nodes' not applicable to data node" - method data = content - method node_type = T_data - method attribute _ = raise Not_found - method attribute_names = [] - method attribute_type _ = raise Not_found - method attributes = [] - method required_string_attribute _ = - failwith "Markup.document, method required_string_attribute: not found" - method required_list_attribute _ = - failwith "Markup.document, method required_list_attribute: not found" - method optional_string_attribute _ = None - method optional_list_attribute _ = [] - method id_attribute_name = raise Not_found - method id_attribute_value = raise Not_found - method idref_attribute_names = [] - method quick_set_attributes _ = - failwith "method 'quick_set_attributes' not applicable to data node" - method attributes_as_nodes = [] - method comment = None - method set_comment c = - match c with - None -> () - | Some _ -> failwith "method 'set_comment' not applicable to data node" - method create_element ?position _ _ _ = - failwith "method 'create_element' not applicable to data node" - method create_data new_dtd new_str = - let x = extension # clone in - let n = - ( {< parent = None; - extension = x; - dtd = Some new_dtd; - content = new_str; - >} - : 'ext #node :> 'ext node) in - x # set_node n; - n - method local_validate ?use_dfa () = () - method keep_always_whitespace_mode = () - - - method write os enc = - let encoding = self # encoding in - write_data_string ~from_enc:encoding ~to_enc:enc os content - - - method write_compact_as_latin1 os = - self # write os `Enc_iso88591 - - method internal_delete _ = - assert false - method internal_init _ _ _ _ = - assert false - method internal_init_other _ _ _ = - assert false - end -;; - - -(**********************************************************************) - -class ['ext] attribute_impl ~element ~name value dtd = - (object (self) - val mutable parent = (None : 'ext node option) - val mutable dtd = dtd - val mutable element_name = element - val mutable att_name = name - val mutable att_value = value - - method parent = - match parent with - None -> raise Not_found - | Some p -> p - - method root = - match parent with - None -> (self : 'ext #node :> 'ext node) - | Some p -> p # root - - method internal_adopt new_parent _ = - parent <- new_parent - - method orphaned_clone = - {< parent = None >} - - method orphaned_flat_clone = - {< parent = None >} - - method dtd = dtd - - method encoding = dtd # encoding - - method node_type = T_attribute att_name - - method attribute n = - if n = att_name then att_value else raise Not_found - - method attribute_names = [ att_name ] - - method attribute_type n = - let eltype = dtd # element element_name in - ( try - let atype, adefault = eltype # attribute n in - atype - with - Undeclared -> - A_cdata - ) - - method attributes = [ att_name, att_value ] - - method required_string_attribute n = - if n = att_name then - match att_value with - Value s -> s - | Valuelist l -> String.concat " " l - | Implied_value -> raise Not_found - else - failwith "Pxp_document.attribute_impl#required_string_attribute: not found" - - - method required_list_attribute n = - if n = att_name then - match att_value with - Value s -> [ s ] - | Valuelist l -> l - | Implied_value -> raise Not_found - else - failwith "Pxp_document.attribute_impl#required_list_attribute: not found" - - method optional_string_attribute n = - if n = att_name then - match att_value with - Value s -> Some s - | Valuelist l -> Some(String.concat " " l) - | Implied_value -> None - else - None - - method optional_list_attribute n = - if n = att_name then - match att_value with - Value s -> [ s ] - | Valuelist l -> l - | Implied_value -> [] - else - [] - - (* Senseless methods: *) - - method sub_nodes = [] - method pinstr _ = [] - method pinstr_names = [] - method iter_nodes _ = () - method iter_nodes_sibl _ = () - method nth_node _ = raise Not_found - method data = "" - method position = ("?",0,0) - method comment = None - method local_validate ?use_dfa () = () - - (* Non-applicable methods: *) - - method extension = - failwith "Pxp_document.attribute_impl#extension: not applicable" - method delete = - failwith "Pxp_document.attribute_impl#delete: not applicable" - method node_position = - failwith "Pxp_document.attribute_impl#node_position: not applicable" - method node_path = - failwith "Pxp_document.attribute_impl#node_path: not applicable" - method previous_node = - failwith "Pxp_document.attribute_impl#previous_node: not applicable" - method next_node = - failwith "Pxp_document.attribute_impl#next_node: not applicable" - method internal_set_pos _ = - failwith "Pxp_document.attribute_impl#internal_set_pos: not applicable" - method internal_delete _ = - failwith "Pxp_document.attribute_impl#internal_delete: not applicable" - method internal_init _ _ _ _ = - failwith "Pxp_document.attribute_impl#internal_init: not applicable" - method internal_init_other _ _ _ = - failwith "Pxp_document.attribute_impl#internal_init_other: not applicable" - method add_node ?force _ = - failwith "Pxp_document.attribute_impl#add_node: not applicable" - method add_pinstr _ = - failwith "Pxp_document.attribute_impl#add_pinstr: not applicable" - method set_nodes _ = - failwith "Pxp_document.attribute_impl#set_nodes: not applicable" - method quick_set_attributes _ = - failwith "Pxp_document.attribute_impl#quick_set_attributes: not applicable" - method attributes_as_nodes = - failwith "Pxp_document.attribute_impl#dattributes_as_nodes: not applicable" - method set_comment c = - if c <> None then - failwith "Pxp_document.attribute_impl#set_comment: not applicable" - method create_element ?position _ _ _ = - failwith "Pxp_document.attribute_impl#create_element: not applicable" - method create_data _ _ = - failwith "Pxp_document.attribute_impl#create_data: not applicable" - method keep_always_whitespace_mode = - failwith "Pxp_document.attribute_impl#keep_always_whitespace_mode: not applicable" - method write _ _ = - failwith "Pxp_document.attribute_impl#write: not applicable" - method write_compact_as_latin1 _ = - failwith "Pxp_document.attribute_impl#write_compact_as_latin1: not applicable" - method id_attribute_name = - failwith "Pxp_document.attribute_impl#id_attribute_name: not applicable" - method id_attribute_value = - failwith "Pxp_document.attribute_impl#id_attribute_value: not applicable" - method idref_attribute_names = - failwith "Pxp_document.attribute_impl#idref_attribute_names: not applicable" - end - : ['ext] node) -;; - -(**********************************************************************) - -class ['ext] element_impl an_ext : ['ext] node = - object (self:'self) - inherit ['ext] node_impl an_ext as super - - val mutable content_model = Any - val mutable content_dfa = lazy None - val mutable ext_decl = false - val mutable ntype = T_none - val mutable id_att_name = None - val mutable idref_att_names = [] - val mutable rev_nodes = ([] : 'c list) - val mutable nodes = (None : 'c list option) - val mutable array = (None : 'c array option) - val mutable size = 0 - val mutable attributes = [] - val mutable att_nodes = [] - val mutable comment = None - val pinstr = lazy (Hashtbl.create 10 : (string,proc_instruction) Hashtbl.t) - val mutable keep_always_whitespace = false - - val mutable position = no_position - - method comment = comment - - method set_comment c = - if ntype = T_comment then - comment <- c - else - failwith "set_comment: not applicable to node types other than T_comment" - - method attributes = attributes - - method position = position - - method private error_name = - match ntype with - T_element n -> "Element `" ^ n ^ "'" - | T_super_root -> "Super root" - | T_pinstr n -> "Wrapper element for processing instruction `" ^ n ^ - "'" - | T_comment -> "Wrapper element for comment" - | T_none -> "NO element" - | T_attribute _ -> assert false - | T_namespace _ -> assert false - | T_data -> assert false - - method add_node ?(force = false) n = - let only_whitespace s = - (* Checks that the string "s" contains only whitespace. On failure, - * Validation_error is raised. - *) - let l = String.length s in - if l < 100 then begin - for i=0 to l - 1 do (* for loop is faster for small 'l' *) - match s.[i] with - ('\009'|'\010'|'\013'|'\032') -> () - | _ -> - raise(Validation_error(self # error_name ^ - " must not have character contents")); - done - end - else begin - let lexbuf = Lexing.from_string s in - let lexerset = Pxp_lexers.get_lexer_set (self # dtd # encoding) in - let t = lexerset.scan_name_string lexbuf in - if t <> Ignore or - (lexerset.scan_name_string lexbuf <> Eof) - then - raise(Validation_error(self # error_name ^ - " must not have character contents")); - () - end - in - (* general DTD check: *) - begin match dtd with - None -> () - | Some d -> if n # dtd != d then - failwith "Pxp_document.element_impl # add_node: the sub node has a different DTD"; - end; - (* specific checks: *) - try - begin match n # node_type with - T_data -> - begin match content_model with - Any -> () - | Unspecified -> () - | Empty -> - if not force then begin - if n # data <> "" then - raise(Validation_error(self # error_name ^ - " must be empty")); - raise Skip - end - | Mixed _ -> () - | Regexp _ -> - if not force then begin - only_whitespace (n # data); - (* TODO: following check faster *) - if n # dtd # standalone_declaration && - n # data <> "" - then begin - (* The standalone declaration is violated if the - * element declaration is contained in an external - * entity. - *) - if ext_decl then - raise - (Validation_error - (self # error_name ^ - " violates standalone declaration" ^ - " because extra white space separates" ^ - " the sub elements")); - end; - if not keep_always_whitespace then raise Skip - end - end - | _ -> - () - end; - (* all OK, so add this node: *) - n # internal_adopt (Some (self : 'ext #node :> 'ext node)) size; - rev_nodes <- n :: rev_nodes; - nodes <- None; - array <- None; - size <- size + 1 - with Skip -> - () - - method add_pinstr pi = - begin match dtd with - None -> () - | Some d -> - if pi # encoding <> d # encoding then - failwith "Pxp_document.element_impl # add_pinstr: Inconsistent encodings"; - end; - let name = pi # target in - Hashtbl.add (Lazy.force pinstr) name pi - - method pinstr name = - Hashtbl.find_all (Lazy.force pinstr) name - - method pinstr_names = - let l = ref [] in - Hashtbl.iter - (fun n _ -> l := n :: !l) - (Lazy.force pinstr); - !l - - method sub_nodes = - match nodes with - None -> - let cl = List.rev rev_nodes in - nodes <- Some cl; - cl - | Some cl -> - cl - - method iter_nodes f = - let cl = self # sub_nodes in - List.iter f cl - - method iter_nodes_sibl f = - let cl = self # sub_nodes in - let rec next last_node l = - match l with - [] -> () - | [x] -> - f last_node x None - | x :: y :: l' -> - f last_node x (Some y); - next (Some x) l' - in - next None cl - - method nth_node p = - if p < 0 or p >= size then raise Not_found; - if array = None then - array <- Some (Array.of_list (self # sub_nodes)); - match array with - None -> assert false - | Some a -> - a.(p) - - method set_nodes nl = - let old_size = size in - List.iter - (fun n -> n # internal_adopt None (-1)) - rev_nodes; - begin try - size <- 0; - List.iter - (fun n -> n # internal_adopt - (Some (self : 'ext #node :> 'ext node)) - size; - size <- size + 1) - nl - with - e -> - (* revert action as much as possible *) - List.iter - (fun n -> n # internal_adopt None (-1)) - rev_nodes; - size <- old_size; - let pos = ref (size-1) in - List.iter - (fun n -> n # internal_adopt - (Some (self : 'ext #node :> 'ext node)) - !pos; - decr pos - ) - rev_nodes; - (* [TODO] Note: there may be bad members in nl *) - raise e - end; - rev_nodes <- List.rev nl; - array <- None; - nodes <- None - - - method orphaned_clone : 'self = - let sub_clones = - List.map - (fun m -> - m # orphaned_clone) - rev_nodes - in - - let x = extension # clone in - let n = - {< parent = None; - node_position = -1; - extension = x; - rev_nodes = sub_clones; - nodes = None; - array = None; - >} in - - let pos = ref (size - 1) in - List.iter - (fun m -> m # internal_adopt - (Some (n : 'ext #node :> 'ext node)) - !pos; - decr pos - ) - sub_clones; - - x # set_node (n : 'ext #node :> 'ext node); - n - - method orphaned_flat_clone : 'self = - let x = extension # clone in - let n = - {< parent = None; - node_position = -1; - extension = x; - rev_nodes = []; - nodes = None; - size = 0; - array = None; - >} in - - x # set_node (n : 'ext #node :> 'ext node); - n - - - method internal_delete n = - rev_nodes <- List.filter (fun n' -> n' != n) rev_nodes; - size <- size - 1; - let p = ref (size-1) in - List.iter - (fun n' -> n' # internal_set_pos !p; decr p) - rev_nodes; - nodes <- None; - n # internal_adopt None (-1); - - - method data = - let cl = self # sub_nodes in - String.concat "" (List.map (fun n -> n # data) cl) - - method node_type = ntype - - - method attribute n = - List.assoc n attributes - - method attribute_names = - List.map fst attributes - - method attribute_type n = - match ntype with - T_element name -> - let d = - match dtd with - None -> assert false - | Some d -> d in - let eltype = d # element name in - ( try - let atype, adefault = eltype # attribute n in - atype - with - Undeclared -> - A_cdata - ) - | _ -> - failwith "attribute_type: not available for non-element nodes" - - - method required_string_attribute n = - try - match List.assoc n attributes with - Value s -> s - | Valuelist l -> String.concat " " l - | Implied_value -> raise Not_found - with - Not_found -> - failwith "Pxp_document, method required_string_attribute: not found" - - method optional_string_attribute n = - try - match List.assoc n attributes with - Value s -> Some s - | Valuelist l -> Some (String.concat " " l) - | Implied_value -> None - with - Not_found -> - None - - method required_list_attribute n = - try - match List.assoc n attributes with - Value s -> [ s ] - | Valuelist l -> l - | Implied_value -> raise Not_found - with - Not_found -> - failwith "Markup.document, method required_list_attribute: not found" - - method optional_list_attribute n = - try - match List.assoc n attributes with - Value s -> [ s ] - | Valuelist l -> l - | Implied_value -> [] - with - Not_found -> - [] - - method id_attribute_name = - match id_att_name with - None -> raise Not_found - | Some name -> name - - method id_attribute_value = - match id_att_name with - None -> raise Not_found - | Some name -> - begin match List.assoc name attributes (* may raise Not_found *) - with - Value s -> s - | _ -> raise Not_found - end - - - method idref_attribute_names = idref_att_names - - - method quick_set_attributes atts = - match ntype with - T_element _ -> - attributes <- atts; - att_nodes <- [] - | _ -> - failwith "quick_set_attributes: not applicable for non-element node" - - - method attributes_as_nodes = - match att_nodes with - [] when attributes = [] -> - [] - | [] -> - let dtd = self # dtd in - let element_name = - match ntype with - T_element n -> n - | _ -> - assert false in - let l = - List.map - (fun (n,v) -> - new attribute_impl - ~element:element_name - ~name:n - v - dtd) - attributes in - att_nodes <- l; - l - | _ -> - att_nodes - - - method create_element - ?(position = no_position) new_dtd new_type new_attlist = - let x = extension # clone in - let obj = ( {< parent = None; - extension = x; - pinstr = lazy (Hashtbl.create 10) - >} - : 'ext #node :> 'ext node - ) in - x # set_node obj; - match new_type with - T_data -> - failwith "create_element: Cannot create T_data node" - | T_element name -> - obj # internal_init position new_dtd name new_attlist; - obj - | (T_comment | T_pinstr _ | T_super_root | T_none) -> - obj # internal_init_other position new_dtd new_type; - obj - | _ -> - failwith "create_element: Cannot create such node" - - - method internal_init_other new_pos new_dtd new_ntype = - (* resets the contents of the object *) - parent <- None; - rev_nodes <- []; - nodes <- None; - ntype <- new_ntype; - position <- new_pos; - content_model <- Any; - content_dfa <- lazy None; - attributes <- []; - att_nodes <- []; - dtd <- Some new_dtd; - ext_decl <- false; - id_att_name <- None; - idref_att_names <- []; - comment <- None; - - - method internal_init new_pos new_dtd new_name new_attlist = - (* ONLY FOR T_Element NODES!!! *) - (* resets the contents of the object *) - parent <- None; - rev_nodes <- []; - nodes <- None; - ntype <- T_element new_name; - position <- new_pos; - comment <- None; - att_nodes <- []; - - let lexerset = Pxp_lexers.get_lexer_set (new_dtd # encoding) in - let sadecl = new_dtd # standalone_declaration in - - (* First validate the element name and the attributes: *) - (* Well-Formedness Constraint: Unique Att Spec *) - let rec check_uniqueness al = - match al with - [] -> () - | (n, av) :: al' -> - if List.mem_assoc n al' then - raise (WF_error("Attribute `" ^ n ^ "' occurs twice in element `" ^ new_name ^ "'")); - check_uniqueness al' - in - check_uniqueness new_attlist; - (* Validity Constraint: Element Valid [element has been declared] *) - try - let eltype = new_dtd # element new_name in - content_model <- eltype # content_model; - content_dfa <- lazy(eltype # content_dfa); - ext_decl <- eltype # externally_declared; - id_att_name <- eltype # id_attribute_name; - idref_att_names <- eltype # idref_attribute_names; - (* Validity Constraint: Attribute Value Type *) - (* Validity Constraint: Fixed Attribute Default *) - (* Validity Constraint: Standalone Document Declaration (partly) *) - let undeclared_attlist = ref [] in - let new_attlist' = - List.map - (fun (n,v) -> - try - (* Get type, default, and the normalized attribute - * value 'av': - *) - let atype, adefault = eltype # attribute n in - let av = value_of_attribute lexerset new_dtd n atype v in - (* If necessary, check whether normalization violates - * the standalone declaration. - *) - if sadecl && - eltype # - attribute_violates_standalone_declaration n (Some v) - then - raise - (Validation_error - ("Attribute `" ^ n ^ "' of element type `" ^ - new_name ^ "' violates standalone declaration")); - (* If the default is "fixed", check that. *) - begin match adefault with - (D_required | D_implied) -> () - | D_default _ -> () - | D_fixed u -> - let uv = value_of_attribute - lexerset new_dtd "[default]" atype u in - if av <> uv then - raise - (Validation_error - ("Attribute `" ^ n ^ - "' is fixed, but has here a different value")); - end; - n,av - with - Undeclared -> - (* raised by method "# attribute" *) - undeclared_attlist := - (n, value_of_attribute lexerset new_dtd n A_cdata v) :: - !undeclared_attlist; - n, Implied_value (* does not matter *) - ) - new_attlist in - (* Validity Constraint: Required Attribute *) - (* Validity Constraint: Standalone Document Declaration (partly) *) - (* Add attributes with default values *) - let new_attlist'' = - List.map - (fun n -> - try - n, List.assoc n new_attlist' - with - Not_found -> - (* Check standalone declaration: *) - if sadecl && - eltype # - attribute_violates_standalone_declaration - n None then - raise - (Validation_error - ("Attribute `" ^ n ^ "' of element type `" ^ - new_name ^ "' violates standalone declaration")); - (* add default value or Implied *) - let atype, adefault = eltype # attribute n in - match adefault with - D_required -> - raise(Validation_error("Required attribute `" ^ n ^ "' is missing")) - | D_implied -> - n, Implied_value - | D_default v -> - n, value_of_attribute lexerset new_dtd n atype v - | D_fixed v -> - n, value_of_attribute lexerset new_dtd n atype v - ) - (eltype # attribute_names) - in - dtd <- Some new_dtd; - attributes <- new_attlist'' @ !undeclared_attlist; - with - Undeclared -> - (* The DTD allows arbitrary attributes/contents for this - * element - *) - dtd <- Some new_dtd; - attributes <- List.map (fun (n,v) -> n, Value v) new_attlist; - content_model <- Any; - content_dfa <- lazy None; - - method local_validate ?(use_dfa=false) () = - (* validates that the content of this element matches the model *) - let dfa = if use_dfa then Lazy.force content_dfa else None in - if not (validate_content - ~use_dfa:dfa - content_model - (self : 'ext #node :> 'ext node)) then - raise(Validation_error(self # error_name ^ - " does not match its content model")) - - - method create_data _ _ = - failwith "method 'create_data' not applicable to element node" - - method keep_always_whitespace_mode = - keep_always_whitespace <- true - - method write os enc = - let encoding = self # encoding in - let wms = - write_markup_string ~from_enc:encoding ~to_enc:enc os in - - begin match ntype with - T_element name -> - wms ("<" ^ name); - List.iter - (fun (aname, avalue) -> - match avalue with - Implied_value -> () - | Value v -> - wms ("\n" ^ aname ^ "=\""); - write_data_string ~from_enc:encoding ~to_enc:enc os v; - wms "\""; - | Valuelist l -> - let v = String.concat " " l in - wms ("\n" ^ aname ^ "=\""); - write_data_string ~from_enc:encoding ~to_enc:enc os v; - wms "\""; - ) - attributes; - wms "\n>"; - | _ -> - () - end; - - Hashtbl.iter - (fun n pi -> - pi # write os enc - ) - (Lazy.force pinstr); - List.iter - (fun n -> n # write os enc) - (self # sub_nodes); - - begin match ntype with - T_element name -> - wms (""); - | _ -> - () - end - - (* TODO: How to write comments? The comment string may contain - * illegal characters or "--". - *) - - - method write_compact_as_latin1 os = - self # write os `Enc_iso88591 - - end -;; - - -let spec_table_find_exemplar tab eltype = - try - Hashtbl.find tab.mapping eltype - with - Not_found -> tab.default_element -;; - - -let create_data_node spec dtd str = - match spec with - Spec_table tab -> - let exemplar = tab.data_node in - exemplar # create_data dtd str -;; - - -let create_element_node ?position spec dtd eltype atts = - match spec with - Spec_table tab -> - let exemplar = spec_table_find_exemplar tab eltype in - exemplar # create_element ?position:position dtd (T_element eltype) atts -;; - - -let create_super_root_node ?position spec dtd = - match spec with - Spec_table tab -> - ( match tab.super_root_node with - None -> - failwith "Pxp_document.create_super_root_node: No exemplar" - | Some x -> - x # create_element ?position:position dtd T_super_root [] - ) -;; - -let create_no_node ?position spec dtd = - match spec with - Spec_table tab -> - let x = tab.default_element in - x # create_element ?position:position dtd T_none [] -;; - - -let create_comment_node ?position spec dtd text = - match spec with - Spec_table tab -> - ( match tab.comment_node with - None -> - failwith "Pxp_document.create_comment_node: No exemplar" - | Some x -> - let e = x # create_element ?position:position dtd T_comment [] - in - e # set_comment (Some text); - e - ) -;; - - -let create_pinstr_node ?position spec dtd pi = - let target = pi # target in - let exemplar = - match spec with - Spec_table tab -> - ( try - Hashtbl.find tab.pinstr_mapping target - with - Not_found -> - ( match tab.default_pinstr_node with - None -> - failwith - "Pxp_document.create_pinstr_node: No exemplar" - | Some x -> x - ) - ) - in - let el = - exemplar # create_element ?position:position dtd (T_pinstr target) [] in - el # add_pinstr pi; - el -;; - - -let find ?(deeply=false) f base = - let rec search_flat children = - match children with - [] -> raise Not_found - | n :: children' -> - if f n then n else search_flat children' - in - let rec search_deep children = - match children with - [] -> raise Not_found - | n :: children' -> - if f n then - n - else - try search_deep (n # sub_nodes) - with Not_found -> search_deep children' - in - (if deeply then search_deep else search_flat) - (base # sub_nodes) -;; - - -let find_all ?(deeply=false) f base = - let rec search_flat children = - match children with - [] -> [] - | n :: children' -> - if f n then n :: search_flat children' else search_flat children' - in - let rec search_deep children = - match children with - [] -> [] - | n :: children' -> - let rest = - search_deep (n # sub_nodes) @ search_deep children' in - if f n then - n :: rest - else - rest - in - (if deeply then search_deep else search_flat) - (base # sub_nodes) -;; - - -let find_element ?deeply eltype base = - find - ?deeply:deeply - (fun n -> - match n # node_type with - T_element name -> name = eltype - | _ -> false) - base -;; - - -let find_all_elements ?deeply eltype base = - find_all - ?deeply:deeply - (fun n -> - match n # node_type with - T_element name -> name = eltype - | _ -> false) - base -;; - - -exception Skip;; - -let map_tree ~pre ?(post=(fun x -> x)) base = - let rec map_rec n = - (try - let n' = pre n in - if n' # node_type <> T_data then begin - let children = n # sub_nodes in - let children' = map_children children in - n' # set_nodes children'; - end; - post n' - with - Skip -> raise Not_found - ) - and map_children l = - match l with - [] -> [] - | child :: l' -> - (try - let child' = map_rec child in - child' :: map_children l' - with - Not_found -> - map_children l' - ) - in - map_rec base -;; - - -let map_tree_sibl ~pre ?(post=(fun _ x _ -> x)) base = - let rec map_rec l n r = - (try - let n' = pre l n r in - if n' # node_type <> T_data then begin - let children = n # sub_nodes in - let children' = map_children None children in - let children'' = postprocess_children None children' in - n' # set_nodes children''; - end; - n' - with - Skip -> raise Not_found - ) - and map_children predecessor l = - (match l with - [] -> [] - | child :: l' -> - let successor = - match l' with - [] -> None - | x :: _ -> Some x in - (try - let child' = map_rec predecessor child successor in - child' :: map_children (Some child) l' - with - Not_found -> - map_children (Some child) l' - ) - ) - and postprocess_children predecessor l = - (match l with - [] -> [] - | child :: l' -> - let successor = - match l' with - [] -> None - | x :: _ -> Some x in - (try - let child' = post predecessor child successor in - child' :: postprocess_children (Some child) l' - with - Skip -> - postprocess_children (Some child) l' - ) - ) - in - let base' = map_rec None base None in - try post None base' None with Skip -> raise Not_found -;; - - -let iter_tree ?(pre=(fun x -> ())) ?(post=(fun x -> ())) base = - let rec iter_rec n = - (try - pre n; - let children = n # sub_nodes in - iter_children children; - post n - with - Skip -> raise Not_found - ) - and iter_children l = - match l with - [] -> [] - | child :: l' -> - (try - iter_rec child; - iter_children l' - with - Not_found -> - iter_children l' - ) - in - iter_rec base -;; - - -let iter_tree_sibl ?(pre=(fun _ _ _ -> ())) ?(post=(fun _ _ _ -> ())) base = - let rec iter_rec l n r = - (try - pre l n r; - let children = n # sub_nodes in - iter_children None children; - post l n r - with - Skip -> raise Not_found - ) - and iter_children predecessor l = - (match l with - [] -> [] - | child :: l' -> - let successor = - match l' with - [] -> None - | x :: _ -> Some x in - (try - iter_rec predecessor child successor; - iter_children (Some child) l' - with - Not_found -> - iter_children (Some child) l' - ) - ) - in - iter_rec None base None -;; - - -let compare a b = - let rec cmp p1 p2 = - match p1, p2 with - [], [] -> 0 - | [], _ -> -1 - | _, [] -> 1 - | x::p1', y::p2' -> if x = y then cmp p1' p2' else x - y - in - - let a_path = a # node_path in - let b_path = b # node_path in - - cmp a_path b_path -;; - - -type 'ext ord_index = ('ext node, int) Hashtbl.t;; - -let create_ord_index base = - let n = ref 0 in - iter_tree ~pre:(fun _ -> incr n) base; - let idx = Hashtbl.create !n in - let k = ref 0 in - iter_tree ~pre:(fun node -> Hashtbl.add idx node !k; incr k) base; - idx -;; - - -let ord_number idx node = - Hashtbl.find idx node -;; - -let ord_compare idx a b = - let ord_a = Hashtbl.find idx a in - let ord_b = Hashtbl.find idx b in - ord_a - ord_b -;; - -class ['ext] document the_warner = - object (self) - val mutable xml_version = "1.0" - val mutable dtd = (None : dtd option) - val mutable root = (None : 'ext node option) - - val pinstr = lazy (Hashtbl.create 10 : (string,proc_instruction) Hashtbl.t) - val warner = (the_warner : collect_warnings) - - method init_xml_version s = - if s <> "1.0" then - warner # warn ("XML version '" ^ s ^ "' not supported"); - xml_version <- s - - method init_root r = - let dtd_r = r # dtd in - match r # node_type with - - (**************** CASE: We have a super root element ***************) - - | T_super_root -> - if not (dtd_r # arbitrary_allowed) then begin - match dtd_r # root with - Some declared_root_element_name -> - let real_root_element = - try - List.find - (fun r' -> - match r' # node_type with - | T_element _ -> true - | _ -> false) - (r # sub_nodes) - with - Not_found -> - failwith "Pxp_document.document#init_root: Super root does not contain root element" - (* TODO: Check also that there is at most one - * element in the super root node - *) - - in - let real_root_element_name = - match real_root_element # node_type with - T_element name -> name - | _ -> assert false - in - if real_root_element_name <> declared_root_element_name then - raise - (Validation_error ("The root element is `" ^ - real_root_element_name ^ - "' but is declared as `" ^ - declared_root_element_name)) - | None -> () - end; - (* All is okay, so store dtd and root node: *) - dtd <- Some dtd_r; - root <- Some r - - (**************** CASE: No super root element **********************) - - | T_element root_element_name -> - if not (dtd_r # arbitrary_allowed) then begin - match dtd_r # root with - Some declared_root_element_name -> - if root_element_name <> declared_root_element_name then - raise - (Validation_error ("The root element is `" ^ - root_element_name ^ - "' but is declared as `" ^ - declared_root_element_name)) - | None -> - (* This may happen if you initialize your DTD yourself. - * The value 'None' means that the method 'set_root' was - * never called for the DTD; we interpret it here as: - * The root element does not matter. - *) - () - end; - (* All is okay, so store dtd and root node: *) - dtd <- Some dtd_r; - root <- Some r - - | _ -> - failwith "Pxp_document.document#init_root: the root node must be an element or super-root" - - method xml_version = xml_version - - method xml_standalone = - match dtd with - None -> false - | Some d -> d # standalone_declaration - - method dtd = - match dtd with - None -> failwith "Pxp_document.document#dtd: Document has no DTD" - | Some d -> d - - method encoding = - match dtd with - None -> failwith "Pxp_document.document#encoding: Document has no DTD" - | Some d -> d # encoding - - method root = - match root with - None -> failwith "Pxp_document.document#root: Document has no root element" - | Some r -> r - - method add_pinstr pi = - begin match dtd with - None -> () - | Some d -> - if pi # encoding <> d # encoding then - failwith "Pxp_document.document # add_pinstr: Inconsistent encodings"; - end; - let name = pi # target in - Hashtbl.add (Lazy.force pinstr) name pi - - method pinstr name = - Hashtbl.find_all (Lazy.force pinstr) name - - method pinstr_names = - let l = ref [] in - Hashtbl.iter - (fun n _ -> l := n :: !l) - (Lazy.force pinstr); - !l - - method write os enc = - let encoding = self # encoding in - let wms = - write_markup_string ~from_enc:encoding ~to_enc:enc os in - - let r = self # root in - wms ("\n"); - ( match self # dtd # root with - None -> - self # dtd # write os enc false - | Some _ -> - self # dtd # write os enc true - ); - Hashtbl.iter - (fun n pi -> - pi # write os enc - ) - (Lazy.force pinstr); - r # write os enc; - wms "\n"; - - method write_compact_as_latin1 os = - self # write os `Enc_iso88591 - - end -;; - - -(* ====================================================================== - * History: - * - * $Log$ - * Revision 1.1 2000/11/17 09:57:29 lpadovan - * Initial revision - * - * Revision 1.14 2000/08/30 15:47:52 gerd - * Implementation of pxp_document.mli rev 1.10. - * - * Revision 1.13 2000/08/26 23:29:10 gerd - * Implementations for the changed in rev 1.9 of pxp_document.mli. - * - * Revision 1.12 2000/08/18 20:14:00 gerd - * New node_types: T_super_root, T_pinstr, T_comment, (T_attribute), - * (T_none), (T_namespace). - * - * Revision 1.11 2000/08/14 22:24:55 gerd - * Moved the module Pxp_encoding to the netstring package under - * the new name Netconversion. - * - * Revision 1.10 2000/07/23 02:16:34 gerd - * Support for DFAs. - * - * Revision 1.9 2000/07/16 19:37:09 gerd - * Simplification. - * - * Revision 1.8 2000/07/16 17:50:01 gerd - * Fixes in 'write' - * - * Revision 1.7 2000/07/16 16:34:41 gerd - * New method 'write', the successor of 'write_compact_as_latin1'. - * - * Revision 1.6 2000/07/14 13:56:11 gerd - * Added methods id_attribute_name, id_attribute_value, - * idref_attribute_names. - * - * Revision 1.5 2000/07/09 17:51:14 gerd - * Element nodes can store positions. - * - * Revision 1.4 2000/07/08 23:04:06 gerd - * [Merging 0.2.10:] Bugfix: allow_undeclared_attribute - * - * Revision 1.3 2000/07/04 22:10:06 gerd - * Implemented rev 1.3 of pxp_document.mli in a straight- - * forward fashion. - * - * Revision 1.2 2000/06/14 22:19:06 gerd - * Added checks such that it is impossible to mix encodings. - * - * 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_document.ml: - * - * Revision 1.19 2000/05/27 19:14:42 gerd - * value_of_attribute: this function has been moved to - * markup_aux.ml. - * - * Added the following checks whether there is a violation - * against the standalone declaration: - * - Externally declared elements with regexp content model - * must not contain extra white space - * - The effect of normalization of externally declared attributes - * must not depend on the type of the attributes - * - Declared default values of externally declared attributes - * must not have an effect on the value of the attributes. - * - * Removed the method init_xml_standalone. It is now stored in - * the DTD whether there is a standalone declaration. - * - * Revision 1.18 2000/05/20 20:31:40 gerd - * Big change: Added support for various encodings of the - * internal representation. - * - * Revision 1.17 2000/05/06 23:12:20 gerd - * Allow undeclared attributes. - * - * Revision 1.16 2000/05/01 20:42:28 gerd - * New method write_compact_as_latin1. - * - * Revision 1.15 2000/04/30 18:15:22 gerd - * In function validate_content: Special handling of the pseudo - * nodes "-pi" and "-vr". - * Method init_root, class document: Recognizes whether the - * root is virtual or real. The check on the root element name is different - * in each case. - * New method keep_always_whitespace_mode: Turns a special mode - * on in which ignorable whitespace is included into the document. - * - * Revision 1.14 2000/03/11 22:58:15 gerd - * Updated to support Markup_codewriter. - * - * Revision 1.13 2000/01/27 21:51:56 gerd - * Added method 'attributes'. - * - * Revision 1.12 2000/01/27 21:19:34 gerd - * Added methods. - * Bugfix: 'orphaned_clone' performs now really a clone. - * - * Revision 1.11 2000/01/20 21:57:58 gerd - * Bugfix: method set_nodes does no longer add the new subnodes - * in the reverse order. - * - * Revision 1.10 1999/12/17 21:35:37 gerd - * Bugfix: If the name of the root element is not specified in - * the DTD, the document does not check whether the root element is a - * specific element. - * - * Revision 1.9 1999/11/09 22:22:01 gerd - * The "document" classes now checks that the root element is the - * same as the declared root element. Thanks to Claudio Sacerdoti Coen - * for his bug report. - * - * Revision 1.8 1999/09/01 22:51:40 gerd - * Added methods to store processing instructions. - * - * Revision 1.7 1999/09/01 16:19:18 gerd - * Added some warnings. - * If an element type has the content model EMPTY, it is now strictly - * checked that the element instance is really empty. Especially, white space - * is NOT allowed in such instances. - * - * Revision 1.6 1999/08/19 21:58:59 gerd - * Added method "reset_finder". This is not very convincing, but - * currently the simplest way to update the ID hash table. - * - * Revision 1.5 1999/08/19 01:08:15 gerd - * Added method "find" that searches node by ID in the whole - * tree. - * Bugfix: After the extension has been cloned, the "set_node" method - * is invoked telling the clone to which node it is associated. - * - * Revision 1.4 1999/08/15 13:52:52 gerd - * Bugfix: WF_error "Attribute x occurs twice in element [unnamed]" - * no longer possible; instead of "[unnamed]" the actual name is printed. - * Improved some of the error messages. - * - * Revision 1.3 1999/08/15 02:19:01 gerd - * If the DTD allows arbitrary elements, unknown elements are not - * rejected. - * - * Revision 1.2 1999/08/11 14:54:23 gerd - * Optimizations: The hashtable for the 'pinstr' variable is only - * created on demand. -- The 'only_whitespace' function uses a simple "for" - * loop is the string is small and a lexer if the string is big. - * - * Revision 1.1 1999/08/10 00:35:50 gerd - * Initial revision. - * - * - *)