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
ec44708c
Commit
ec44708c
authored
Oct 05, 2007
by
Pietro Abate
Browse files
[r2005-02-22 17:57:04 by afrisch] Empty log message
Original author: afrisch Date: 2005-02-22 17:57:04+00:00
parent
ea770528
Changes
2
Hide whitespace changes
Inline
Side-by-side
schema/schema_builtin.ml
View file @
ec44708c
...
...
@@ -134,9 +134,11 @@ let parse_sign s =
Value
.
vfalse
let
validate_integer
s
=
try
Value
.
Integer
(
Intervals
.
V
.
mk
(
Utf8
.
get_str
s
))
with
Failure
_
->
simple_type_error
"integer"
let
s
=
Utf8
.
get_str
s
in
if
(
String
.
length
s
=
0
)
then
simple_type_error
"integer"
else
try
Value
.
Integer
(
Intervals
.
V
.
mk
s
)
with
Failure
_
->
simple_type_error
"integer"
let
strip_decimal_RE
=
Pcre
.
regexp
"
\\
..*$"
...
...
@@ -188,10 +190,12 @@ let validate_token_list s =
Value
.
sequence
(
List
.
map
validate_token
(
split_xml_S
s
))
let
validate_interval
interval
type_name
s
=
let
integer
=
try
Intervals
.
V
.
mk
(
Utf8
.
get_str
s
)
with
Failure
_
->
simple_type_error
type_name
let
integer
=
let
s
=
Utf8
.
get_str
s
in
if
(
String
.
length
s
=
0
)
then
simple_type_error
"integer"
else
try
Intervals
.
V
.
mk
s
with
Failure
_
->
simple_type_error
"integer"
in
if
Intervals
.
contains
integer
interval
then
Value
.
Integer
integer
...
...
schema/schema_validator.ml
View file @
ec44708c
...
...
@@ -138,9 +138,7 @@ let rec tries funs arg =
match
funs
with
|
[]
->
raise
Not_found
|
f
::
tl
->
try
print_endline
"try"
;
flush
stdout
;
f
arg
try
f
arg
with
XSI_validation_error
_
->
tries
tl
arg
...
...
@@ -246,11 +244,10 @@ let rec validate_simple_type def s =
match
def
with
|
Primitive
name
|
Derived
(
Some
name
,
_
,
_
,
_
)
when
Schema_builtin
.
is_builtin
name
->
(
try
Schema_builtin
.
validate_builtin
name
s
with
Schema_builtin
.
Schema_builtin_error
name
->
error
(
sprintf
"%s isn't a valid %s"
(
Utf8
.
to_string
s
)
name
))
(
try
Schema_builtin
.
validate_builtin
name
s
with
Schema_builtin
.
Schema_builtin_error
name
->
error
(
sprintf
"%s isn't a valid %s"
(
Utf8
.
to_string
s
)
name
))
|
Primitive
_
->
assert
false
|
Derived
(
_
,
Atomic
primitive
,
facets
,
base
)
->
let
literal
=
normalize_white_space
(
fst
facets
.
whiteSpace
)
s
in
...
...
@@ -265,11 +262,8 @@ let rec validate_simple_type def s =
Schema_facets
.
facets_valid
facets
value
;
value
|
Derived
(
_
,
Union
members
,
facets
,
base
)
->
print_endline
(
"union:"
^
(
Utf8
.
to_string
s
));
flush
stdout
;
let
value
=
tries
(
List
.
map
validate_simple_type_ref
members
)
s
in
print_endline
"after union"
;
flush
stdout
;
Schema_facets
.
facets_valid
facets
value
;
print_endline
"ok"
;
flush
stdout
;
value
|
Derived
(
_
,
Restrict
,
_
,_
)
as
st
->
(* TODO: compute the restriction statically ... *)
...
...
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