--- /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_lexers
+open Pxp_entity
+open Pxp_aux
+open Pxp_dfa
+
+(**********************************************************************)
+
+class dtd the_warner init_encoding =
+ object (self)
+ val mutable root = (None : string option)
+ val mutable id = (None : dtd_id option)
+
+ val warner = (the_warner : collect_warnings)
+ val encoding = init_encoding
+ val lexerset = Pxp_lexers.get_lexer_set init_encoding
+
+ val elements = (Hashtbl.create 100 : (string,dtd_element) Hashtbl.t)
+ val gen_entities = (Hashtbl.create 100 : (string,entity * bool) Hashtbl.t)
+ val par_entities = (Hashtbl.create 100 : (string,entity) Hashtbl.t)
+ val notations = (Hashtbl.create 100 : (string,dtd_notation) Hashtbl.t)
+ val pinstr = (Hashtbl.create 100 : (string,proc_instruction) Hashtbl.t)
+ val mutable element_names = []
+ val mutable gen_entity_names = []
+ val mutable par_entity_names = []
+ val mutable notation_names = []
+ val mutable pinstr_names = []
+
+ val mutable allow_arbitrary = false
+ val mutable standalone_declaration = false
+
+ val mutable validated = false
+
+ initializer
+ let w = new drop_warnings in
+ self # add_gen_entity
+ (new internal_entity self "lt" w "<" false false false encoding)
+ false;
+ self # add_gen_entity
+ (new internal_entity self "gt" w ">" false false false encoding)
+ false;
+ self # add_gen_entity
+ (new internal_entity self "amp" w "&" false false false encoding)
+ false;
+ self # add_gen_entity
+ (new internal_entity self "apos" w "'" false false false encoding)
+ false;
+ self # add_gen_entity
+ (new internal_entity self "quot" w """ false false false encoding)
+ false;
+
+
+ method encoding = encoding
+
+ method warner = warner
+
+ method set_root r =
+ if root = None then
+ root <- Some r
+ else
+ assert false
+
+
+ method set_id j =
+ if id = None then
+ id <- Some j
+ else
+ assert false
+
+
+ method standalone_declaration = standalone_declaration
+
+ method set_standalone_declaration b =
+ standalone_declaration <- b
+
+ method allow_arbitrary =
+ allow_arbitrary <- true
+
+ method disallow_arbitrary =
+ allow_arbitrary <- false
+
+ method arbitrary_allowed = allow_arbitrary
+
+ method root = root
+ method id = id
+
+
+ method add_element el =
+ (* raises Not_found if 'el' has already been added *)
+ (* Note: 'el' is encoded in the same way as 'self'! *)
+ let name = el # name in
+ check_name warner name;
+ if Hashtbl.mem elements name then
+ raise Not_found;
+ Hashtbl.add elements name el;
+ element_names <- name :: element_names;
+ validated <- false
+
+
+ method add_gen_entity en extdecl =
+ (* The following is commented out; perhaps there should be an option
+ * to reactivate it on demand
+ *)
+ (* raises Validation_error if the predefines entities 'lt', 'gt', 'amp',
+ * 'quot', and 'apos' are redeclared with an improper value.
+ *)
+ if en # encoding <> encoding then
+ failwith "Pxp_dtd.dtd # add_gen_entity: Inconsistent encodings";
+ let name = en # name in
+ check_name warner name;
+ if Hashtbl.mem gen_entities name then begin
+ if List.mem name [ "lt"; "gt"; "amp"; "quot"; "apos" ] then begin
+ (* These are allowed to be declared several times *)
+ let (rt,_) = en # replacement_text in
+ let toks = tokens_of_content_string lexerset rt in
+ try
+ begin match toks with
+ [CRef 60] -> if name <> "lt" then raise Not_found
+ | [CharData ">"] -> if name <> "gt" then raise Not_found
+ | [CRef 62] -> if name <> "gt" then raise Not_found
+ | [CRef 38] -> if name <> "amp" then raise Not_found
+ | [CharData "'"] -> if name <> "apos" then raise Not_found
+ | [CRef 39] -> if name <> "apos" then raise Not_found
+ | [CharData "\""] -> if name <> "quot" then raise Not_found
+ | [CRef 34] -> if name <> "quot" then raise Not_found
+ | _ -> raise Not_found
+ end
+ with
+ Not_found ->
+ raise (Validation_error("Predefined entity `" ^ name ^
+ "' redeclared"))
+ end
+ else
+ warner # warn ("Entity `" ^ name ^ "' declared twice")
+ end
+ else begin
+ Hashtbl.add gen_entities name (en, extdecl);
+ gen_entity_names <- name :: gen_entity_names
+ end
+
+
+ method add_par_entity en =
+ if en # encoding <> encoding then
+ failwith "Pxp_dtd.dtd # add_par_entity: Inconsistent encodings";
+ let name = en # name in
+ check_name warner name;
+ if not (Hashtbl.mem par_entities name) then begin
+ Hashtbl.add par_entities name en;
+ par_entity_names <- name :: par_entity_names
+ end
+ else
+ warner # warn ("Entity `" ^ name ^ "' declared twice")
+
+
+ method add_notation no =
+ (* raises Validation_error if 'no' already added *)
+ if no # encoding <> encoding then
+ failwith "Pxp_dtd.dtd # add_notation: Inconsistent encodings";
+ let name = no # name in
+ check_name warner name;
+ if Hashtbl.mem notations name then
+ raise (Validation_error("Notation `" ^ name ^ "' declared twice"));
+ Hashtbl.add notations name no;
+ notation_names <- name :: notation_names
+
+
+ method add_pinstr pi =
+ if pi # encoding <> encoding then
+ failwith "Pxp_dtd.dtd # add_pinstr: Inconsistent encodings";
+ let name = pi # target in
+ check_name warner name;
+
+ if String.length name >= 4 && String.sub name 0 4 = "pxp:" then begin
+ match name with
+ "pxp:dtd" ->
+ let _, optname, atts = pi # parse_pxp_option in
+ begin match optname with
+ "optional-element-and-notation-declarations" ->
+ self # allow_arbitrary
+ | "optional-attribute-declarations" ->
+ let lexers = Pxp_lexers.get_lexer_set encoding in
+ let el_string =
+ try List.assoc "elements" atts
+ with Not_found ->
+ raise(Error("Missing `elements' attribute for pxp:dtd"))
+ in
+ let el = split_attribute_value lexers el_string in
+ List.iter
+ (fun e_name ->
+ let e =
+ try Hashtbl.find elements e_name
+ with
+ Not_found ->
+ raise(Error("Reference to unknown element `" ^
+ e_name ^ "'"))
+ in
+ e # allow_arbitrary
+ )
+ el
+ | _ ->
+ raise(Error("Unknown PXP option `" ^
+ optname ^ "'"))
+ end
+ | _ ->
+ raise(Error("The processing instruction target `" ^
+ name ^ "' is not defined by this PXP version"))
+ end
+ else begin
+ (*----------------------------------------------------------------------
+ * SUPPORT FOR DEPRECATED PI OPTIONS:
+ * - <?xml:allow_undeclared_elements_and_notations?>
+ * is now <?pxp:dtd optional-element-and-notation-declarations?>
+ * - <?xml:allow_undeclared_attributes <elementname>?>
+ * is now <?pxp:dtd optional-attribute-declarations
+ * elements='<elementname> ...'?>
+ * Please update your DTDs! Alternatively, you may uncommment the
+ * following piece of code.
+ *)
+(* if name = "xml:allow_undeclared_elements_and_notations" then *)
+(* self # allow_arbitrary; *)
+(* if name = "xml:allow_undeclared_attributes" then begin *)
+(* let v = pi # value in *)
+(* let e = *)
+(* try *)
+(* Hashtbl.find elements v *)
+(* with *)
+(* Not_found -> *)
+(* raise(Validation_error("Reference to undeclared element `"*)
+(* ^ v ^ "'")) *)
+(* in *)
+(* e # allow_arbitrary; *)
+(* end; *)
+ (*----------------------------------------------------------------------
+ *)
+ ()
+ end;
+ Hashtbl.add pinstr name pi;
+ pinstr_names <- name :: pinstr_names;
+
+
+ method element name =
+ (* returns the element 'name' or raises Validation_error if not found *)
+ try
+ Hashtbl.find elements name
+ with
+ Not_found ->
+ if allow_arbitrary then
+ raise Undeclared
+ else
+ raise(Validation_error("Reference to undeclared element `" ^ name ^ "'"))
+
+ method element_names =
+ (* returns the list of all names of element declarations *)
+ element_names
+
+
+ method gen_entity name =
+ (* returns the entity 'name' or raises WF_error if not found *)
+ try
+ Hashtbl.find gen_entities name
+ with
+ Not_found ->
+ raise(WF_error("Reference to undeclared general entity `" ^ name ^ "'"))
+
+
+ method gen_entity_names = gen_entity_names
+
+
+ method par_entity name =
+ (* returns the entity 'name' or raises WF_error if not found *)
+ try
+ Hashtbl.find par_entities name
+ with
+ Not_found ->
+ raise(WF_error("Reference to undeclared parameter entity `" ^ name ^ "'"))
+
+
+ method par_entity_names = par_entity_names
+
+
+ method notation name =
+ (* returns the notation 'name' or raises Validation_error if not found *)
+ try
+ Hashtbl.find notations name
+ with
+ Not_found ->
+ if allow_arbitrary then
+ raise Undeclared
+ else
+ raise(Validation_error("Reference to undeclared notation `" ^ name ^ "'"))
+
+
+ method notation_names = notation_names
+
+
+ method pinstr name =
+ (* returns the list of all processing instructions contained in the DTD
+ * with target 'name'
+ *)
+ Hashtbl.find_all pinstr name
+
+
+ method pinstr_names = pinstr_names
+
+ method write os enc doctype =
+ let wms =
+ write_markup_string ~from_enc:encoding ~to_enc:enc os in
+
+ let write_sysid s =
+ if String.contains s '"' then
+ wms ("'" ^ s ^ "'")
+ else
+ wms ("\"" ^ s ^ "\"");
+ in
+
+ if doctype then begin
+ wms "<!DOCTYPE ";
+ ( match root with
+ None -> failwith "#write: DTD without root";
+ | Some r -> wms r
+ );
+ wms " [\n";
+ end;
+
+ (* Notations: *)
+ List.iter
+ (fun name ->
+ let notation =
+ try Hashtbl.find notations name with Not_found -> assert false in
+ notation # write os enc)
+ (List.sort compare notation_names);
+
+ (* Unparsed entities: *)
+ List.iter
+ (fun name ->
+ let ent,_ =
+ try Hashtbl.find gen_entities name with Not_found -> assert false
+ in
+ if ent # is_ndata then begin
+ let xid = ent # ext_id in
+ let notation = ent # notation in
+ wms ("<!ENTITY " ^ name ^ " " );
+ ( match xid with
+ System s ->
+ wms "SYSTEM ";
+ write_sysid s;
+ | Public (p,s) ->
+ wms "PUBLIC ";
+ write_sysid p;
+ if (s <> "") then begin
+ wms " ";
+ write_sysid s;
+ end;
+ | Anonymous ->
+ failwith "#write: External ID Anonymous cannot be represented"
+ );
+ wms (" NDATA " ^ notation ^ ">\n");
+ end
+ )
+ (List.sort compare gen_entity_names);
+
+ (* Elements: *)
+ List.iter
+ (fun name ->
+ let element =
+ try Hashtbl.find elements name with Not_found -> assert false in
+ element # write os enc)
+ (List.sort compare element_names);
+
+ (* Processing instructions: *)
+ List.iter
+ (fun name ->
+ let pi =
+ try Hashtbl.find pinstr name with Not_found -> assert false in
+ pi # write os enc)
+ (List.sort compare pinstr_names);
+
+ if doctype then
+ wms "]>\n";
+
+ method write_compact_as_latin1 os doctype =
+ self # write os `Enc_iso88591 doctype
+
+
+
+ (************************************************************)
+ (* VALIDATION *)
+ (************************************************************)
+
+ method only_deterministic_models =
+ Hashtbl.iter
+ (fun n el ->
+ let cm = el # content_model in
+ match cm with
+ Regexp _ ->
+ if el # content_dfa = None then
+ raise(Validation_error("The content model of element `" ^
+ n ^ "' is not deterministic"))
+ | _ ->
+ ()
+ )
+ elements;
+
+
+ method validate =
+ if validated or allow_arbitrary then
+ ()
+ else begin
+ (* Validity constraint: Notations in NDATA entity declarations must
+ * be declared
+ *)
+ List.iter
+ (fun name ->
+ let ent,_ =
+ try Hashtbl.find gen_entities name with Not_found -> assert false
+ in
+ if ent # is_ndata then begin
+ let xid = ent # ext_id in
+ let notation = ent # notation in
+ try
+ ignore(self # notation notation)
+ (* Raises Validation_error if the constraint is violated *)
+ with
+ Undeclared -> ()
+ end
+ )
+ gen_entity_names;
+
+ (* Validate the elements: *)
+ Hashtbl.iter
+ (fun n el ->
+ el # validate)
+ elements;
+
+ (* Check the root element: *)
+ (* TODO: Check if this piece of code is executed at all! *)
+ begin match root with
+ None -> ()
+ | Some r ->
+ begin try
+ let _ = Hashtbl.find elements r in ()
+ with
+ Not_found ->
+ raise(Validation_error("The root element is not declared"))
+ end
+ end;
+ validated <- true;
+ end
+
+ method invalidate =
+ validated <- false
+
+ (************************************************************)
+
+ end
+
+
+(**********************************************************************)
+
+and dtd_element the_dtd the_name =
+ object (self)
+ val dtd = (the_dtd : dtd)
+ val name = the_name
+ val lexerset = Pxp_lexers.get_lexer_set (the_dtd # encoding)
+ val mutable content_model = Unspecified
+ val mutable content_model_validated = false
+ val mutable content_dfa = lazy None
+
+ val mutable externally_declared = false
+
+ val mutable attributes =
+ ([] : (string * ((att_type * att_default) * bool)) list)
+ val mutable attributes_validated = false
+
+ val mutable id_att_name = None
+ val mutable idref_att_names = []
+
+ val mutable allow_arbitrary = false
+
+ method name = name
+
+ method set_cm_and_extdecl m extdecl =
+ if content_model = Unspecified then begin
+ content_model <- m;
+ content_model_validated <- false;
+ content_dfa <- lazy (self # compute_content_dfa);
+ externally_declared <- extdecl;
+ dtd # invalidate
+ end
+ else
+ raise(Validation_error("Element `" ^ name ^ "' has already a content model"))
+
+ method content_model = content_model
+
+ method content_dfa = Lazy.force content_dfa
+
+ method private compute_content_dfa =
+ match content_model with
+ Regexp re ->
+ ( try Some (dfa_of_regexp_content_model re)
+ with Not_found -> None
+ )
+ | _ ->
+ None
+
+ method externally_declared = externally_declared
+
+ method encoding = dtd # encoding
+
+ method allow_arbitrary =
+ allow_arbitrary <- true
+
+ method disallow_arbitrary =
+ allow_arbitrary <- false
+
+ method arbitrary_allowed = allow_arbitrary
+
+ method add_attribute aname t d extdecl =
+ if aname <> "xml:lang" & aname <> "xml:space" then
+ check_name (dtd#warner) aname;
+ if List.mem_assoc aname attributes then
+ dtd # warner # warn ("More than one declaration for attribute `" ^
+ aname ^ "' of element type `" ^ name ^ "'")
+ else begin
+ begin match aname with
+ "xml:space" ->
+ begin match t with
+ A_enum l ->
+ let l' = Sort.list ( <= ) l in
+ if l' <> [ "default"; "preserve" ] then
+ raise(Validation_error("Declaration of attribute `xml:space' does not conform to XML specification"))
+ | _ ->
+ raise(Validation_error("Declaration of attribute `xml:space' does not conform to XML specification"))
+ end
+ | _ -> ()
+ end;
+ begin match t with
+ A_id ->
+ id_att_name <- Some aname;
+ | (A_idref | A_idrefs) ->
+ idref_att_names <- aname :: idref_att_names
+ | _ ->
+ ()
+ end;
+ attributes <- (aname, ((t,d),extdecl)) :: attributes;
+ attributes_validated <- false;
+ dtd # invalidate;
+ end
+
+ method attribute attname =
+ try
+ fst (List.assoc attname attributes)
+ with
+ Not_found ->
+ if allow_arbitrary then
+ raise Undeclared
+ else
+ raise(Validation_error("Attribute `" ^ attname ^ "' of element `"
+ ^ name ^ "' not declared"))
+
+ method attribute_violates_standalone_declaration attname v =
+ try
+ let (atype, adefault), extdecl = List.assoc attname attributes in
+ extdecl &&
+ ( match v with
+ None ->
+ adefault <> D_required && adefault <> D_implied
+ (* i.e. adefault matches D_default or D_fixed *)
+ | Some s ->
+ atype <> A_cdata &&
+ normalization_changes_value lexerset atype s
+ )
+ with
+ Not_found ->
+ if allow_arbitrary then
+ raise Undeclared
+ else
+ raise(Validation_error("Attribute `" ^ attname ^ "' of element `"
+ ^ name ^ "' not declared"))
+
+
+ method attribute_names =
+ List.map fst attributes
+
+ method names_of_required_attributes =
+ List.flatten
+ (List.map
+ (fun (n,((t,d),_)) ->
+ if d = D_required then
+ [n]
+ else
+ [])
+ attributes)
+
+ method id_attribute_name = id_att_name
+
+ method idref_attribute_names = idref_att_names
+
+
+ method write os enc =
+ let encoding = self # encoding in
+ let wms =
+ write_markup_string ~from_enc:encoding ~to_enc:enc os in
+
+ let rec write_contentspec cs =
+ match cs with
+ Unspecified ->
+ failwith "#write: Unspecified content model found"
+ | Empty ->
+ wms "EMPTY"
+ | Any ->
+ wms "ANY"
+ | Mixed ml ->
+ wms "(";
+ write_mixedspec_list ml;
+ wms ")*";
+ | Regexp re ->
+ write_children re false
+
+ and write_mixedspec_list ml =
+ match ml with
+ MPCDATA :: ml' ->
+ wms "#PCDATA";
+ if ml' <> [] then wms "|";
+ write_mixedspec_list ml';
+ | MChild s :: ml' ->
+ wms s;
+ if ml' <> [] then wms "|";
+ write_mixedspec_list ml';
+ | [] ->
+ ()
+
+ and write_children re cp =
+ match re with
+ Optional re' ->
+ let p = needs_parens re' in
+ if p then wms "(";
+ write_children re' cp;
+ if p then wms ")";
+ wms "?";
+ | Repeated re' ->
+ let p = needs_parens re' in
+ if p then wms "(";
+ write_children re' cp;
+ if p then wms ")";
+ wms "*";
+ | Repeated1 re' ->
+ let p = needs_parens re' in
+ if p then wms "(";
+ write_children re' cp;
+ if p then wms ")";
+ wms "+";
+ | Alt re' ->
+ wms "(";
+ ( match re' with
+ re1' :: rer' ->
+ write_children re1' true;
+ List.iter
+ (fun ren' ->
+ wms "|";
+ write_children ren' true;
+ )
+ rer';
+ | [] ->
+ failwith "#write: Illegal content model"
+ );
+ wms ")";
+ | Seq re' ->
+ wms "(";
+ ( match re' with
+ re1' :: rer' ->
+ write_children re1' true;
+ List.iter
+ (fun ren' ->
+ wms ",";
+ write_children ren' true;
+ )
+ rer';
+ | [] ->
+ failwith "#write: Illegal content model"
+ );
+ wms ")";
+ | Child ch ->
+ if not cp then wms "(";
+ wms ch;
+ if not cp then wms ")";
+
+ and needs_parens re =
+ match re with
+ (Optional _ | Repeated _ | Repeated1 _ ) -> true
+ | _ -> false
+ in
+
+ wms ("<!ELEMENT " ^ name ^ " ");
+ write_contentspec content_model;
+ wms ">\n";
+
+ wms ("<!ATTLIST " ^ name);
+ List.iter
+ (fun (n,((t,d),_)) ->
+ wms ("\n " ^ n);
+ ( match t with
+ A_cdata -> wms " CDATA";
+ | A_id -> wms " ID";
+ | A_idref -> wms " IDREF";
+ | A_idrefs -> wms " IDREFS";
+ | A_entity -> wms " ENTITY";
+ | A_entities -> wms " ENTITIES";
+ | A_nmtoken -> wms " NMTOKEN";
+ | A_nmtokens -> wms " NMTOKENS";
+ | A_notation nl ->
+ wms " NOTATION (";
+ ( match nl with
+ nl1:: nl' ->
+ wms nl1;
+ List.iter
+ (fun n ->
+ wms ("|" ^ n);
+ )
+ nl'
+ | [] ->
+ failwith "#write: Illegal content model";
+ );
+ wms ")";
+ | A_enum el ->
+ wms " (";
+ ( match el with
+ el1:: el' ->
+ wms el1;
+ List.iter
+ (fun e ->
+ wms ("|" ^ e);
+ )
+ el'
+ | [] ->
+ failwith "#write: Illegal content model";
+ );
+ wms ")";
+ );
+ ( match d with
+ D_required -> wms " #REQUIRED"
+ | D_implied -> wms " #IMPLIED"
+ | D_default s ->
+ wms " \"";
+ write_data_string ~from_enc:encoding ~to_enc:enc os s;
+ wms "\"";
+ | D_fixed s ->
+ wms " FIXED \"";
+ write_data_string ~from_enc:encoding ~to_enc:enc os s;
+ wms "\"";
+ );
+ )
+ attributes;
+
+ wms ">\n";
+
+ method write_compact_as_latin1 os =
+ self # write os `Enc_iso88591
+
+ (************************************************************)
+ (* VALIDATION *)
+ (************************************************************)
+
+ method validate =
+ self # validate_attributes();
+ self # validate_content_model()
+
+ method private validate_attributes() =
+ if attributes_validated then
+ ()
+ else begin
+ (* Validity Constraint: One ID per Element Type *)
+ let n = count (fun (n,((t,d),_)) -> t = A_id) attributes in
+ if n > 1 then
+ raise(Validation_error("More than one ID attribute for element `" ^ name ^ "'"));
+ (* Validity Constraint: ID Attribute Default *)
+ if List.exists
+ (fun (n,((t,d),_)) ->
+ t = A_id & (d <> D_required & d <> D_implied))
+ attributes
+ then
+ raise(Validation_error("ID attribute must be #IMPLIED or #REQUIRED; element `" ^ name ^ "'"));
+ (* Validity Constraint: One Notation per Element Type *)
+ let n = count (fun (n,((t,d),_)) ->
+ match t with A_notation _ -> true | _ -> false)
+ attributes in
+ if n > 1 then
+ raise(Validation_error("More than one NOTATION attribute for element `" ^ name ^ "'"));
+ (* Validity Constraint: Notation Attributes [second part] *)
+ List.iter
+ (fun (n,((t,d),_)) ->
+ match t with
+ A_notation l ->
+ List.iter
+ (fun nname ->
+ let _ = dtd # notation nname in ())
+ l
+ | _ -> ())
+ attributes;
+ (* Validity Constraint: Attribute Default Legal *)
+ List.iter
+ (fun (n,((t,d),_)) ->
+
+ let check v =
+ let lexical_error() =
+ lazy (raise(Validation_error("Default value for attribute `" ^ n ^ "' is lexically malformed"))) in
+ check_attribute_value_lexically lexerset (lexical_error()) t v;
+ begin match t with
+ (A_entity|A_entities) ->
+ List.iter
+ (fun nd ->
+ let en, extdecl = dtd # gen_entity nd in
+ if not (en # is_ndata) then
+ raise(Validation_error("Attribute default value must be the name of an NDATA entity; attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
+(* if dtd # standalone_declaration && extdecl then
+ raise(Validation_error("Attribute default value violates the standalone declaration; attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
+-- This is checked anyway when the attribute value is normalized
+*)
+ )
+ (split_attribute_value lexerset v)
+ | A_notation nl ->
+ if not (List.mem v nl) then
+ raise(Validation_error("Illegal default value for attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
+ | A_enum nl ->
+ if not (List.mem v nl) then
+ raise(Validation_error("Illegal default value for attribute `" ^ n ^ "' in declaration for element `" ^ name ^ "'"));
+ | _ -> ()
+ end
+ in
+
+ match d with
+ D_required -> ()
+ | D_implied -> ()
+ | D_default v -> check v
+ | D_fixed v -> check v
+ )
+ attributes;
+
+ (* Ok: This element declaration is valid *)
+ attributes_validated <- true;
+
+ end
+
+ method private validate_content_model () =
+ (* checks:
+ * - Validity Constraint: No Duplicate Types
+ * It is not an error if there is a child in the declaration for which
+ * no element declaration is provided.
+ *)
+ match content_model with
+ Unspecified ->
+ dtd # warner # warn ("Element type `" ^ name ^ "' mentioned but not declared");
+ ()
+ | Empty -> ()
+ | Any -> ()
+ | Mixed (pcdata :: l) ->
+ (* MPCDATA is always the first element by construction *)
+ assert (pcdata = MPCDATA);
+ if check_dups l then
+ raise (Validation_error("Double children in declaration for element `" ^ name ^ "'"))
+ | Regexp _ -> ()
+ | _ -> assert false
+
+
+
+ (************************************************************)
+
+ end
+
+and dtd_notation the_name the_xid init_encoding =
+object (self)
+ val name = the_name
+ val xid = (the_xid : ext_id)
+ val encoding = (init_encoding : Pxp_types.rep_encoding)
+ method name = name
+ method ext_id = xid
+ method encoding = encoding
+
+ method write os enc =
+ let wms =
+ write_markup_string ~from_enc:encoding ~to_enc:enc os in
+
+ let write_sysid s =
+ if String.contains s '"' then
+ wms ("'" ^ s ^ "'")
+ else
+ wms ("\"" ^ s ^ "\"");
+ in
+
+ wms ("<!NOTATION " ^ name ^ " ");
+ ( match xid with
+ System s ->
+ wms "SYSTEM ";
+ write_sysid s;
+ | Public (p,s) ->
+ wms "PUBLIC ";
+ write_sysid p;
+ if (s <> "") then begin
+ wms " ";
+ write_sysid s;
+ end;
+ | Anonymous ->
+ failwith "#write: External ID Anonymous cannot be represented"
+ );
+ wms ">\n";
+
+ method write_compact_as_latin1 os =
+ self # write os `Enc_iso88591
+
+ end
+
+and proc_instruction the_target the_value init_encoding =
+object (self)
+ val target = the_target
+ val value = (the_value : string)
+ val encoding = (init_encoding : Pxp_types.rep_encoding)
+
+ initializer
+ match target with
+ ("xml"|"xmL"|"xMl"|"xML"|"Xml"|"XmL"|"XMl"|"XML") ->
+ (* This is an error, not a warning, because I do not have a
+ * "warner" object by hand.
+ *)
+ raise(WF_error("Reserved processing instruction"))
+ | _ -> ()
+
+ method target = target
+ method value = value
+ method encoding = encoding
+
+ method write os enc =
+ let wms =
+ write_markup_string ~from_enc:encoding ~to_enc:enc os in
+
+ wms "<?";
+ wms target;
+ wms " ";
+ wms value;
+ wms "?>";
+
+ method write_compact_as_latin1 os =
+ self # write os `Enc_iso88591
+
+ method parse_pxp_option =
+ let lexers = get_lexer_set encoding in
+ try
+ let toks = tokens_of_xml_pi lexers value in (* may raise WF_error *)
+ begin match toks with
+ (Pro_name option_name) :: toks' ->
+ let atts = decode_xml_pi toks' in (* may raise WF_error *)
+ (target, option_name, atts)
+ | _ ->
+ raise(Error("Bad PXP processing instruction"))
+ end
+ with
+ WF_error _ ->
+ raise(Error("Bad PXP processing instruction"))
+
+ end
+;;
+
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:29 lpadovan
+ * Initial revision
+ *
+ * Revision 1.10 2000/08/18 21:18:45 gerd
+ * Updated wrong comments for methods par_entity and gen_entity.
+ * These can raise WF_error and not Validation_error, and this is the
+ * correct behaviour.
+ *
+ * Revision 1.9 2000/07/25 00:30:01 gerd
+ * Added support for pxp:dtd PI options.
+ *
+ * Revision 1.8 2000/07/23 02:16:34 gerd
+ * Support for DFAs.
+ *
+ * Revision 1.7 2000/07/16 17:50:01 gerd
+ * Fixes in 'write'
+ *
+ * Revision 1.6 2000/07/16 16:34:41 gerd
+ * New method 'write', the successor of 'write_compact_as_latin1'.
+ *
+ * Revision 1.5 2000/07/14 13:56:48 gerd
+ * Added methods id_attribute_name and idref_attribute_names.
+ *
+ * Revision 1.4 2000/07/09 00:13:37 gerd
+ * Added methods gen_entity_names, par_entity_names.
+ *
+ * Revision 1.3 2000/07/04 22:10:55 gerd
+ * Update: collect_warnings -> drop_warnings.
+ * Update: Case ext_id = Anonymous.
+ *
+ * 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.
+ *
+ * ======================================================================
+ *
+ * Revision 1.18 2000/05/28 17:24:55 gerd
+ * Bugfixes.
+ *
+ * Revision 1.17 2000/05/27 19:21:25 gerd
+ * Implemented the changes of rev. 1.10 of markup_dtd.mli.
+ *
+ * Revision 1.16 2000/05/20 20:31:40 gerd
+ * Big change: Added support for various encodings of the
+ * internal representation.
+ *
+ * Revision 1.15 2000/05/14 21:50:07 gerd
+ * Updated: change in internal_entity.
+ *
+ * Revision 1.14 2000/05/06 23:08:46 gerd
+ * It is possible to allow undeclared attributes.
+ *
+ * Revision 1.13 2000/05/01 20:42:46 gerd
+ * New method write_compact_as_latin1.
+ *
+ * Revision 1.12 2000/05/01 15:16:57 gerd
+ * The errors "undeclared parameter/general entities" are
+ * well-formedness errors, not validation errors.
+ *
+ * Revision 1.11 2000/03/11 22:58:15 gerd
+ * Updated to support Markup_codewriter.
+ *
+ * Revision 1.10 2000/01/20 20:53:47 gerd
+ * Changed such that it runs with Markup_entity's new interface.
+ *
+ * Revision 1.9 1999/11/09 22:15:41 gerd
+ * Added method "arbitrary_allowed".
+ *
+ * Revision 1.8 1999/09/01 22:52:22 gerd
+ * If 'allow_arbitrary' is in effect, no validation happens anymore.
+ *
+ * Revision 1.7 1999/09/01 16:21:24 gerd
+ * Added several warnings.
+ * The attribute type of "xml:space" is now strictly checked.
+ *
+ * Revision 1.6 1999/08/15 20:34:21 gerd
+ * Improved error messages.
+ * Bugfix: It is no longer allowed to create processing instructions
+ * with target "xml".
+ *
+ * Revision 1.5 1999/08/15 02:20:16 gerd
+ * New feature: a DTD can allow arbitrary elements.
+ *
+ * Revision 1.4 1999/08/15 00:21:39 gerd
+ * Comments have been updated.
+ *
+ * Revision 1.3 1999/08/14 22:12:52 gerd
+ * Several functions have now a "warner" as argument which is
+ * an object with a "warn" method. This is used to warn about characters
+ * that cannot be represented in the Latin 1 alphabet.
+ * Bugfix: if two general entities with the same name are definied,
+ * the first counts, not the second.
+ *
+ * Revision 1.2 1999/08/11 14:56:35 gerd
+ * Declaration of the predfined entities {lt,gt,amp,quot,apos}
+ * is no longer forbidden; but the original definition cannot be overriddden.
+ * TODO: If these entities are redeclared with problematic values,
+ * the user should be warned.
+ *
+ * Revision 1.1 1999/08/10 00:35:51 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff