(* $Id: create_element.ml 662 2004-05-25 20:57:28Z gerd $ *)
(* This test checks whether create_element processes the attribute list
* correctly. The attributes are passed using the ~att_values argument, and
* not by the main argument list. The latter is already implicitly tested
* by the normal parser tests.
*)
open Pxp_types
open Pxp_yacc
open Pxp_document
let conf =
{ default_config with
encoding = `Enc_utf8;
}
;;
let dtd =
parse_dtd_entity
conf
(from_string
"<!NOTATION m PUBLIC 'text/m'>
<!NOTATION n PUBLIC 'text/n'>
<!ENTITY e PUBLIC 'e' '' NDATA m>
<!ENTITY f PUBLIC 'f' '' NDATA n>
<!ELEMENT x ANY>
<!ATTLIST x c_req CDATA #REQUIRED
c_def CDATA '42'
c_fix CDATA #FIXED 'Q'
c_imp CDATA #IMPLIED>
<!ELEMENT y ANY>
<!ATTLIST y c CDATA #IMPLIED
nm NMTOKEN #IMPLIED
nms NMTOKENS #IMPLIED
id ID #IMPLIED
enum (r|s|t) #IMPLIED
ent ENTITY #IMPLIED
ents ENTITIES #IMPLIED
nots NOTATION (m|n) #IMPLIED>
")
;;
let spec = default_spec;;
let sorted_atts e =
let atts = e # attributes in
List.sort (fun (a,_) (b,_) -> Pervasives.compare a b) atts
;;
let dotest name f creator =
print_string ("Test " ^ name ^ ": ");
flush stdout;
try
if f creator then
print_endline "OK"
else
print_endline "FAILED (returns false)"
with
ex ->
print_endline ("FAILED (exception " ^ Printexc.to_string ex ^ ")")
;;
(**********************************************************************)
(* 00x: several possibilities to create x *)
let test001 create =
let e = create
~att_values:["c_req", Value "rv"]
spec dtd "x" []
in
let atts = sorted_atts e in
atts = ["c_def", Value "42";
"c_fix", Value "Q";
"c_imp", Implied_value;
"c_req", Value "rv"]
;;
let test002 create =
let e = create
~att_values:["c_req", Value "rv"; "c_fix", Value "Q"]
spec dtd "x" []
in
let atts = sorted_atts e in
atts = ["c_def", Value "42";
"c_fix", Value "Q";
"c_imp", Implied_value;
"c_req", Value "rv"]
;;
let test003 create =
let e = create
~att_values:["c_req", Value "rv"; "c_imp", Implied_value]
spec dtd "x" []
in
let atts = sorted_atts e in
atts = ["c_def", Value "42";
"c_fix", Value "Q";
"c_imp", Implied_value;
"c_req", Value "rv"]
;;
let test004 create =
let e = create
~att_values:["c_req", Value "rv"; "c_def", Value "43"]
spec dtd "x" []
in
let atts = sorted_atts e in
atts = ["c_def", Value "43";
"c_fix", Value "Q";
"c_imp", Implied_value;
"c_req", Value "rv"]
;;
(**********************************************************************)
(* 01x: several error conditions when creating x *)
let test010 create =
(* Missing required att *)
try
let e = create
~att_values:[]
spec dtd "x" []
in
false
with
Validation_error("Required attribute `c_req' is missing")
| Validation_error("Attribute `c_req' has Implied_value, but is declared as #REQUIRED") ->
true
;;
let test011 create =
(* Bad fixed att *)
try
let e = create
~att_values:["c_req", Value "rv"; "c_fix", Value "bad" ]
spec dtd "x" []
in
false
with
Validation_error("Attribute `c_fix' is fixed, but has here a different value") ->
true
;;
let test012 create =
(* Implied_value does not count as required value *)
try
let e = create
~att_values:["c_req", Implied_value]
spec dtd "x" []
in
false
with
Validation_error("Attribute `c_req' has Implied_value, but is declared as #REQUIRED") ->
true
;;
let test013 create =
(* Bad fixed att (Implied_value) *)
try
let e = create
~att_values:["c_req", Value "rv"; "c_fix", Implied_value ]
spec dtd "x" []
in
false
with
Validation_error("Attribute `c_fix' has Implied_value, but is not declared as #IMPLIED") ->
true
;;
let test014 create =
(* Implied_value not possible when default specified *)
try
let e = create
~att_values:["c_req", Value "rv"; "c_def", Implied_value ]
spec dtd "x" []
in
false
with
Validation_error("Attribute `c_def' has Implied_value, but is not declared as #IMPLIED") ->
true
;;
let test015 create =
(* Attributes must only occur once *)
try
let e = create
~att_values:["c_req", Value "rv"; "c_req", Value "rv" ]
spec dtd "x" []
in
false
with
WF_error("Attribute `c_req' occurs twice in element `x'")
| WF_error("Attribute `c_req' occurs twice") ->
true
;;
let test016 create =
(* Attributes must only occur once *)
try
let e = create
~att_values:["c_req", Value "rv";
"c_imp", Implied_value; "c_imp", Value "imp" ]
spec dtd "x" []
in
false
with
WF_error("Attribute `c_imp' occurs twice in element `x'")
| WF_error("Attribute `c_imp' occurs twice") ->
true
;;
let test017 create =
(* Attributes must only occur once *)
try
let e = create
~att_values:["c_req", Value "rv";
"c_imp", Implied_value; "c_imp", Implied_value ]
spec dtd "x" []
in
false
with
WF_error("Attribute `c_imp' occurs twice in element `x'")
| WF_error("Attribute `c_imp' occurs twice") ->
true
;;
let test018 create =
(* Attributes must only occur once *)
try
let e = create
~att_values:["c_req", Value "rv";
"c_imp", Implied_value ]
spec dtd "x" [ "c_imp", "X" ]
in
false
with
WF_error("Attribute `c_imp' occurs twice in element `x'")
| WF_error("Attribute `c_imp' occurs twice") ->
true
;;
let test019 create =
(* Attributes must be declared *)
try
let e = create
~att_values:["c_req", Value "rv"; "foo", Value "y" ]
spec dtd "x" [ "c_imp", "X" ]
in
false
with
Validation_error("The following attributes are not declared: foo") ->
true
;;
(**********************************************************************)
(* 1xx: several possibilities to create y, and several error conditions *)
let test100 create =
let e = create
~att_values:[]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Implied_value;
"ents", Implied_value;
"enum", Implied_value;
"id", Implied_value;
"nm", Implied_value;
"nms", Implied_value;
"nots", Implied_value
]
;;
let test101 create =
(* CDATA pos *)
let e = create
~att_values:[ "c", Value "X" ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Value "X";
"ent", Implied_value;
"ents", Implied_value;
"enum", Implied_value;
"id", Implied_value;
"nm", Implied_value;
"nms", Implied_value;
"nots", Implied_value
]
;;
let test102 create =
(* CDATA neg *)
try
let e = create
~att_values:[ "c", Valuelist [ "X"; "Y" ] ]
spec dtd "y" []
in
false
with
Validation_error("A list value cannot be assigned to attribute `c'") ->
true
;;
let test103 create =
(* ENTITY pos *)
let e = create
~att_values:[ "ent", Value "e" ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Value "e";
"ents", Implied_value;
"enum", Implied_value;
"id", Implied_value;
"nm", Implied_value;
"nms", Implied_value;
"nots", Implied_value
]
;;
let test104 create =
(* ENTITY neg *)
try
let e = create
~att_values:[ "ent", Value "g" ]
spec dtd "y" []
in
false
with
WF_error("Reference to undeclared general entity `g'") ->
true
;;
let test105 create =
(* ENTITY neg *)
try
let e = create
~att_values:[ "ent", Valuelist [ "X"; "Y" ] ]
spec dtd "y" []
in
false
with
Validation_error("A list value cannot be assigned to attribute `ent'") ->
true
;;
let test106 create =
(* ENTITY neg *)
try
let e = create
~att_values:[ "ent", Value " e" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `ent' has leading or trailing whitespace") ->
true
;;
let test107 create =
(* ENTITIES pos *)
let e = create
~att_values:[ "ents", Valuelist [ "e"; "f" ] ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Implied_value;
"ents", Valuelist [ "e"; "f" ];
"enum", Implied_value;
"id", Implied_value;
"nm", Implied_value;
"nms", Implied_value;
"nots", Implied_value
]
;;
let test108 create =
(* ENTITIES neg *)
try
let e = create
~att_values:[ "ents", Valuelist [ "e"; "g" ] ]
spec dtd "y" []
in
false
with
WF_error("Reference to undeclared general entity `g'") ->
true
;;
let test109 create =
(* ENTITIES neg *)
try
let e = create
~att_values:[ "ents", Value "X" ]
spec dtd "y" []
in
false
with
Validation_error("A non-list value cannot be assigned to attribute `ents'") ->
true
;;
let test110 create =
(* ENTITIES neg *)
try
let e = create
~att_values:[ "ents", Valuelist [ "e"; "f " ] ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `ents' has leading or trailing whitespace") ->
true
;;
let test111 create =
(* enum pos *)
let e = create
~att_values:[ "enum", Value "s" ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Implied_value;
"ents", Implied_value;
"enum", Value "s";
"id", Implied_value;
"nm", Implied_value;
"nms", Implied_value;
"nots", Implied_value
]
;;
let test112 create =
(* enum neg *)
try
let e = create
~att_values:[ "enum", Value "q" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `enum' does not match one of the declared enumerator tokens") ->
true
;;
let test113 create =
(* enum neg *)
try
let e = create
~att_values:[ "enum", Value " t" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `enum' has leading or trailing whitespace") ->
true
;;
let test114 create =
(* enum neg *)
try
let e = create
~att_values:[ "enum", Valuelist [ "X"; "Y" ] ]
spec dtd "y" []
in
false
with
Validation_error("A list value cannot be assigned to attribute `enum'") ->
true
;;
let test115 create =
(* ID pos *)
let e = create
~att_values:[ "id", Value "five" ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Implied_value;
"ents", Implied_value;
"enum", Implied_value;
"id", Value "five";
"nm", Implied_value;
"nms", Implied_value;
"nots", Implied_value
]
;;
let test116 create =
(* ID neg *)
try
let e = create
~att_values:[ "id", Value " t" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `id' has leading or trailing whitespace") ->
true
;;
let test117 create =
(* ID neg *)
try
let e = create
~att_values:[ "id", Value "5" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `id' is lexically malformed") ->
true
;;
let test118 create =
(* ID neg *)
try
let e = create
~att_values:[ "id", Valuelist [ "X"; "Y" ] ]
spec dtd "y" []
in
false
with
Validation_error("A list value cannot be assigned to attribute `id'") ->
true
;;
let test119 create =
(* NMTOKEN pos *)
let e = create
~att_values:[ "nm", Value "5" ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Implied_value;
"ents", Implied_value;
"enum", Implied_value;
"id", Implied_value;
"nm", Value "5";
"nms", Implied_value;
"nots", Implied_value
]
;;
let test120 create =
(* NMTOKEN neg *)
try
let e = create
~att_values:[ "nm", Value " t" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `nm' has leading or trailing whitespace") ->
true
;;
let test121 create =
(* NMTOKEN neg *)
try
let e = create
~att_values:[ "nm", Value "+5" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `nm' is lexically malformed") ->
true
;;
let test122 create =
(* NMTOKEN neg *)
try
let e = create
~att_values:[ "nm", Valuelist [ "X"; "Y" ] ]
spec dtd "y" []
in
false
with
Validation_error("A list value cannot be assigned to attribute `nm'") ->
true
;;
let test123 create =
(* NMTOKENS pos *)
let e = create
~att_values:[ "nms", Valuelist [ "_six"; "5" ] ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Implied_value;
"ents", Implied_value;
"enum", Implied_value;
"id", Implied_value;
"nm", Implied_value;
"nms", Valuelist ["_six"; "5"];
"nots", Implied_value
]
;;
let test124 create =
(* NMTOKENS neg *)
try
let e = create
~att_values:[ "nms", Valuelist [ "x"; "t "] ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `nms' has leading or trailing whitespace") ->
true
;;
let test125 create =
(* NMTOKENS neg *)
try
let e = create
~att_values:[ "nms", Valuelist [ "5 6" ] ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `nms' is lexically malformed") ->
true
;;
let test126 create =
(* NMTOKENS neg *)
try
let e = create
~att_values:[ "nms", Value "X" ]
spec dtd "y" []
in
false
with
Validation_error("A non-list value cannot be assigned to attribute `nms'") ->
true
;;
let test127 create =
(* NOTATION pos *)
let e = create
~att_values:[ "nots", Value "m" ]
spec dtd "y" []
in
let atts = sorted_atts e in
atts = ["c", Implied_value;
"ent", Implied_value;
"ents", Implied_value;
"enum", Implied_value;
"id", Implied_value;
"nm", Implied_value;
"nms", Implied_value;
"nots", Value "m"
]
;;
let test128 create =
(* NOTATION neg *)
try
let e = create
~att_values:[ "nots", Value "q" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `nots' does not match one of the declared notation names") ->
true
;;
let test129 create =
(* NOTATION neg *)
try
let e = create
~att_values:[ "nots", Value " t" ]
spec dtd "y" []
in
false
with
Validation_error("Attribute `nots' has leading or trailing whitespace") ->
true
;;
let test130 create =
(* NOTATION neg *)
try
let e = create
~att_values:[ "nots", Valuelist [ "X"; "Y" ] ]
spec dtd "y" []
in
false
with
Validation_error("A list value cannot be assigned to attribute `nots'") ->
true
;;
(**********************************************************************)
let test_series create =
dotest "001" test001 create;
dotest "002" test002 create;
dotest "003" test003 create;
dotest "004" test004 create;
dotest "010" test010 create;
dotest "011" test011 create;
dotest "012" test012 create;
dotest "013" test013 create;
dotest "014" test014 create;
dotest "015" test015 create;
dotest "016" test016 create;
dotest "017" test017 create;
dotest "018" test018 create;
dotest "019" test019 create;
dotest "100" test100 create;
dotest "101" test101 create;
dotest "102" test102 create;
dotest "103" test103 create;
dotest "104" test104 create;
dotest "105" test105 create;
dotest "106" test106 create;
dotest "107" test107 create;
dotest "108" test108 create;
dotest "109" test109 create;
dotest "110" test110 create;
dotest "111" test111 create;
dotest "112" test112 create;
dotest "113" test113 create;
dotest "114" test114 create;
dotest "115" test115 create;
dotest "116" test116 create;
dotest "117" test117 create;
dotest "118" test118 create;
dotest "119" test119 create;
dotest "120" test120 create;
dotest "121" test121 create;
dotest "122" test122 create;
dotest "123" test123 create;
dotest "124" test124 create;
dotest "125" test125 create;
dotest "126" test126 create;
dotest "127" test127 create;
dotest "128" test128 create;
dotest "129" test129 create;
dotest "130" test130 create;
()
;;
print_endline "Series: create_element, early validation";
test_series
(fun ~att_values spec dtd name atts ->
create_element_node ~att_values spec dtd name atts);
print_endline "Series: create_element, deferred validation";
test_series
(fun ~att_values spec dtd name atts ->
let e =
try
create_element_node
~att_values
~valcheck:false
spec dtd name atts
with
| WF_error _ as e ->
(* Well-formedness errors will be raised here *)
raise e
| e ->
(* Validation errors must not happen here. So catch them
* and report them.
*)
failwith ("Early exception: " ^ Printexc.to_string e)
in
e # complement_attlist();
e # validate_attlist();
e
);
()
;;
