+++ /dev/null
-(* $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 ("</" ^ name ^ "\n>");
- | _ ->
- ()
- 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 ("<?xml version='1.0' encoding='" ^
- Netconversion.string_of_encoding enc ^
- "'?>\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.
- *
- *
- *)
projects / helm.git / blobdiff