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
3e3d3a2a
Commit
3e3d3a2a
authored
Oct 04, 2007
by
Pietro Abate
Browse files
- experimental support for cdata sections
parent
9a5ab37e
Changes
4
Hide whitespace changes
Inline
Side-by-side
runtime/print_xml.ml
View file @
3e3d3a2a
...
...
@@ -66,9 +66,13 @@ let false_literal = U.mk "false"
(* @raise exn_print_xml in case of failure. Rationale: schema printing is
* the last attempt to print a value, others have already failed *)
let
rec
schema_value
?
(
recurs
=
true
)
~
wds
v
=
match
v
with
|
Abstract
(
"float"
,
f
)
->
wds
(
U
.
mk
(
string_of_float
(
Obj
.
magic
f
:
float
)))
let
rec
schema_value
?
(
recurs
=
true
)
~
wds
~
wcs
v
=
match
v
with
|
Abstract
(
"float"
,
o
)
->
wds
(
U
.
mk
(
string_of_float
(
Obj
.
magic
o
:
float
)))
|
Abstract
(
"cdata"
,
o
)
->
wcs
(
U
.
mk
"<![CDATA["
);
wcs
(
U
.
mk
(
U
.
get_str
(
Obj
.
magic
o
:
U
.
t
)));
wcs
(
U
.
mk
"]]>"
)
|
Record
_
as
v
->
(
try
wds
(
Schema_builtin
.
string_of_time_type
(
Value
.
get_fields
v
))
...
...
@@ -76,18 +80,18 @@ let rec schema_value ?(recurs=true) ~wds v = match v with
|
Integer
i
->
wds
(
U
.
mk
(
Intervals
.
V
.
to_string
i
))
|
v
when
Value
.
equal
v
Value
.
vtrue
->
wds
true
_literal
|
v
when
Value
.
equal
v
Value
.
vfalse
->
wds
false
_literal
|
Pair
_
as
v
when
recurs
->
schema_values
~
wds
v
|
Pair
_
as
v
when
recurs
->
schema_values
~
wds
~
wcs
v
|
String_utf8
_
|
String_latin1
_
as
v
->
wds
(
fst
(
get_string_utf8
v
))
|
_
->
raise
exn_print_xml
and
schema_values
~
wds
v
=
and
schema_values
~
wds
~
wcs
v
=
match
v
with
|
Pair
(
hd
,
Atom
a
)
when
a
=
Sequence
.
nil_atom
->
schema_value
~
recurs
:
false
~
wds
hd
schema_value
~
recurs
:
false
~
wds
~
wcs
hd
|
Pair
(
hd
,
tl
)
->
schema_value
~
recurs
:
false
~
wds
hd
;
schema_value
~
recurs
:
false
~
wds
~
wcs
hd
;
wds
blank
;
schema_values
~
wds
tl
schema_values
~
wds
~
wcs
tl
|
_
->
raise
exn_print_xml
let
to_buf
~
utf8
buffer
ns_table
v
=
...
...
@@ -97,6 +101,7 @@ let to_buf ~utf8 buffer ns_table v =
let
wms
=
write_markup_string
~
to_enc
buffer
and
wds
s
=
write_data_string
~
to_enc
buffer
(
U
.
get_str
s
)
and
wcs
s
=
buffer
(
U
.
get_str
s
)
in
in
let
write_att
(
n
,
v
)
=
wms
(
" "
^
(
Ns
.
Printer
.
attr
printer
(
Label
.
value
n
))
^
"=
\"
"
);
wds
v
;
wms
"
\"
"
in
...
...
@@ -160,7 +165,7 @@ let to_buf ~utf8 buffer ns_table v =
end
else
begin
let
buf
=
Buffer
.
create
20
in
let
wds
s
=
Buffer
.
add_string
buf
(
U
.
get_str
s
)
in
schema_value
~
wds
v
;
schema_value
~
wds
~
wcs
:
wds
v
;
(
Label
.
from_int
n
,
U
.
mk
(
Buffer
.
contents
buf
))
end
)
attrs
in
...
...
@@ -177,7 +182,7 @@ let to_buf ~utf8 buffer ns_table v =
match
q
with
|
Pair
((
Xml
_
|
XmlNs
_
)
as
x
,
q
)
->
print_elt
[]
x
;
print_content
q
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
()
|
v
->
schema_value
~
wds
v
|
v
->
schema_value
~
wds
~
wcs
v
in
document_start
()
;
print_elt
(
Ns
.
Printer
.
prefixes
printer
)
v
...
...
runtime/value.ml
View file @
3e3d3a2a
...
...
@@ -284,6 +284,11 @@ let rec print ppf v =
Format
.
fprintf
ppf
"<concat:%a;%a>"
print
x
print
y
|
Abstract
(
"float"
,
o
)
->
Format
.
fprintf
ppf
"%f"
(
Obj
.
magic
o
:
float
)
|
Abstract
(
"cdata"
,
o
)
->
let
s
=
Utf8
.
get_str
(
Obj
.
magic
o
:
Utf8
.
t
)
in
Format
.
fprintf
ppf
"'%s'"
s
(* Format.fprintf ppf "%s" (Utf8.get_str (Obj.magic o :
* Encodings.Utf8.t)) *)
|
Abstract
(
s
,_
)
->
Format
.
fprintf
ppf
"<abstract=%s>"
s
|
Absent
->
...
...
@@ -417,8 +422,12 @@ let rec compare x y =
raise
(
CDuceExn
(
string_latin1
"comparing functional values"
))
|
Abstract
(
s1
,
v1
)
,
Abstract
(
s2
,
v2
)
->
let
c
=
Types
.
Abstract
.
T
.
compare
s1
s2
in
if
c
<>
0
then
c
else
Pervasives
.
compare
(
Obj
.
magic
v1
:
float
)
(
Obj
.
magic
v2
:
float
)
(* raise (CDuceExn (string_latin1 "comparing abstract values")) *)
else
begin
match
s1
with
|
"float"
->
Pervasives
.
compare
(
Obj
.
magic
v1
:
float
)
(
Obj
.
magic
v2
:
float
)
|
"cdata"
->
Pervasives
.
compare
(
Obj
.
magic
v1
:
Encodings
.
Utf8
.
t
)
(
Obj
.
magic
v2
:
Encodings
.
Utf8
.
t
)
|_
->
raise
(
CDuceExn
(
string_latin1
"comparing abstract values"
))
end
|
Absent
,_
|
_
,
Absent
->
Format
.
fprintf
Format
.
std_formatter
"ERR: Compare %a %a@."
print
x
print
y
;
...
...
@@ -713,6 +722,9 @@ let print_utf8 v =
let
float
n
=
Abstract
(
"float"
,
Obj
.
repr
n
)
let
cdata
n
=
Abstract
(
"cdata"
,
Obj
.
repr
n
)
let
cduce2ocaml_option
f
v
=
match
normalize
v
with
|
Pair
(
x
,
y
)
->
Some
(
f
x
)
...
...
runtime/value.mli
View file @
3e3d3a2a
...
...
@@ -83,6 +83,7 @@ val flatten : t -> t
val
append
:
t
->
t
->
t
val
float
:
float
->
t
val
cdata
:
string
->
t
val
get_string_latin1
:
t
->
string
val
get_string_utf8
:
t
->
U
.
t
*
t
...
...
types/builtin.ml
View file @
3e3d3a2a
...
...
@@ -116,6 +116,12 @@ let exn_namespaces = lazy (
Value
.
string_latin1
"namespaces"
))
)
let
exn_cdata_of
=
lazy
(
Value
.
CDuceExn
(
Value
.
Pair
(
Value
.
Atom
(
Atoms
.
V
.
mk_ascii
"Invalid_argument"
)
,
Value
.
string_latin1
"cdata_of"
))
)
let
eval_load_file
~
utf8
e
=
Cduce_loc
.
protect_op
"load_file"
;
...
...
@@ -439,3 +445,11 @@ register_fun "float_of" string float
let
(
s
,_
)
=
Value
.
get_string_utf8
v
in
try
Value
.
float
(
float_of_string
(
U
.
get_str
s
))
with
Failure
_
->
raise
(
Lazy
.
force
exn_float_of
));;
(* cdata *)
register_fun
"cdata_of"
string
string
(
fun
v
->
let
(
s
,_
)
=
Value
.
get_string_utf8
v
in
try
Value
.
cdata
(
U
.
get_str
s
)
with
Failure
_
->
raise
(
Lazy
.
force
exn_cdata_of
));;
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