Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
cduce
cduce
Commits
923baaa2
Commit
923baaa2
authored
Jul 10, 2007
by
Pietro Abate
Browse files
[r2005-02-22 16:14:40 by afrisch] Better implem for all-groups
Original author: afrisch Date: 2005-02-22 16:14:40+00:00
parent
6a26ef06
Changes
1
Hide whitespace changes
Inline
Side-by-side
schema/schema_validator.ml
View file @
923baaa2
...
...
@@ -29,15 +29,6 @@ let string_of_value value =
let
foo_qname
=
Ns
.
empty
,
Utf8
.
mk
""
let
ptbl_of_particles
particles
=
let
tbl
=
QTable
.
create
20
in
List
.
iter
(* fill table *)
(* ASSUMPTION: firsts are disjoing as per UPA Schema constraint *)
(
fun
p
->
List
.
iter
(
fun
tag
->
QTable
.
add
tbl
tag
p
)
(
first_of_particle
p
))
particles
;
tbl
(** Validation context *)
class
type
validation_context
=
object
...
...
@@ -254,6 +245,24 @@ let check_fixed ~context fixed value =
validation_error
~
context
(
sprintf
"Expected fixed value: %s; found %s"
(
string_of_value
fixed
)
(
string_of_value
value
))
let
next_pcdata
context
=
let
rec
aux
accu
=
match
context
#
peek
with
|
E_char_data
utf8_data
when
context
#
mixed
->
context
#
junk
;
aux
(
Value
.
concat
accu
(
string_utf8
utf8_data
))
|
E_char_data
utf8_data
->
validation_error
~
context
(
sprintf
"Unexpected char data in non-mixed content: %s"
(
Utf8
.
get_str
utf8_data
))
|
_
->
accu
in
aux
Value
.
nil
let
next_tag
context
=
match
context
#
peek
with
|
E_start_tag
qname
->
qname
|
_
->
raise
Not_found
let
validate_attribute_uses
context
attr_uses
=
let
tbl
=
QTable
.
create
11
in
...
...
@@ -391,54 +400,57 @@ and validate_term context term =
|
Model
model_group
->
validate_model_group
context
model_group
(** @return (Value.t * Utf8.t)
* 2nd value is the key for tbl that return the particle effectively used for
* validation *)
and
validate_choice
context
tbl
=
let
backlog
=
ref
Value
.
nil
in
let
concat
v
=
backlog
:=
Value
.
concat
!
backlog
v
in
let
rec
next_tag
()
=
match
context
#
peek
with
|
E_char_data
utf8_data
when
context
#
mixed
->
concat
(
string_utf8
utf8_data
);
context
#
junk
;
next_tag
()
|
E_char_data
utf8_data
(* when not context#mixed *)
->
validation_error
~
context
(
sprintf
"Unexpected char data in non-mixed content: %s"
(
Utf8
.
get_str
utf8_data
))
|
E_start_tag
qname
->
qname
|
ev
->
validation_error
~
context
(
sprintf
"Unexpected content: %s"
(
string_of_event
ev
))
in
let
qname
=
next_tag
()
in
and
validate_choice
context
particles
=
(* TODO: Handle case when one of the choices is nullable *)
let
tbl
=
QTable
.
create
20
in
List
.
iter
(
fun
p
->
List
.
iter
(
fun
tag
->
QTable
.
add
tbl
tag
p
)
(
first_of_particle
p
))
particles
;
let
txt
=
next_pcdata
context
in
try
let
qname
=
next_tag
context
in
let
particle
=
QTable
.
find
tbl
qname
in
(* BUG: should put the backlog back !!! *)
Value
.
concat
!
backlog
(
validate_particle
context
particle
)
,
qname
Value
.
concat
txt
(
validate_particle
context
particle
)
with
Not_found
->
validation_error
~
context
(
sprintf
"Unexpected element %s"
(
Ns
.
QName
.
to_string
qname
))
validation_error
~
context
(
sprintf
"Cannot choose branch of choice group"
)
and
validate_all_group
context
particles
=
let
tbl
=
QTable
.
create
20
in
let
slots
:
(
bool
*
Value
.
t
option
ref
)
list
=
List
.
map
(
fun
p
->
let
slot
=
ref
None
in
let
first
=
first_of_particle
p
in
List
.
iter
(
fun
tag
->
QTable
.
add
tbl
tag
(
p
,
slot
))
first
;
(
nullable
p
,
slot
)
)
particles
in
let
contents
=
ref
Value
.
nil
in
let
rec
aux
()
=
let
qname
=
next_tag
context
in
let
p
,
slot
=
QTable
.
find
tbl
qname
in
match
!
slot
with
|
Some
x
->
()
|
None
->
slot
:=
Some
(
validate_particle
context
p
);
aux
()
in
let
txt
=
next_pcdata
context
in
(
try
aux
()
with
Not_found
->
()
);
List
.
fold_left
(
fun
accu
(
nullable
,
slot
)
->
match
!
slot
with
|
Some
x
->
Value
.
concat
accu
x
|
None
when
nullable
->
accu
|
None
->
validation_error
~
context
"One particle of the all group is missing"
)
txt
slots
and
validate_model_group
context
model_group
=
match
model_group
with
|
All
particles
->
(* BUG: reorder ! *)
let
tbl
=
ptbl_of_particles
particles
in
let
contents
=
ref
Value
.
nil
in
let
rec
aux
()
=
if
qtable_is_empty
tbl
then
!
contents
else
begin
let
(
content
,
key
)
=
validate_choice
context
tbl
in
contents
:=
Value
.
concat
!
contents
content
;
QTable
.
remove
tbl
key
;
aux
()
end
in
aux
()
|
Choice
particles
->
fst
(
validate_choice
context
(
ptbl_of_particles
particles
))
|
All
particles
->
validate_all_group
context
particles
|
Choice
particles
->
validate_choice
context
particles
|
Sequence
particles
->
flatten
(
sequence
(
List
.
map
(
validate_particle
context
)
particles
))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment