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
253d89fd
Commit
253d89fd
authored
Oct 17, 2011
by
Jérôme Maloberti
Browse files
Add load_xml_subst and print_xml_subst for namespaces substitution.
parent
c5e3c464
Changes
6
Hide whitespace changes
Inline
Side-by-side
misc/ns.ml
View file @
253d89fd
...
...
@@ -31,6 +31,7 @@ let xml_ns = Uri.mk (U.mk xml_ns_str)
let
xsd_ns
=
Uri
.
mk
(
U
.
mk
"http://www.w3.org/2001/XMLSchema"
)
let
xsi_ns
=
Uri
.
mk
(
U
.
mk
"http://www.w3.org/2001/XMLSchema-instance"
)
module
H
=
Hashtbl
.
Make
(
Uri
)
...
...
@@ -67,7 +68,6 @@ module Printer = struct
type
slot
=
Hint
of
U
.
t
list
|
Set
of
U
.
t
module
H
=
Hashtbl
.
Make
(
Uri
)
type
printer
=
{
ns_to_prefix
:
slot
ref
H
.
t
;
...
...
@@ -282,6 +282,26 @@ let process_start_tag table tag attrs =
aux
table
((
x
,
U
.
mk
v
)
::
attrs
)
rest
in
aux
table
[]
attrs
let
process_start_tag_subst
table
tag
attrs
subst_hash
=
let
real_ns
ns
=
if
H
.
mem
subst_hash
ns
then
H
.
find
subst_hash
ns
else
ns
in
let
rec
aux
(
table
:
table
)
(
attrs
:
((
string
*
U
.
t
)
*
U
.
t
)
list
)
=
function
|
[]
->
(
table
,
map_tag
table
(
U
.
mk
tag
)
,
List
.
rev_map
(
att
table
)
attrs
)
|
(
"xmlns"
,
uri
)
::
rest
->
let
table
=
add_prefix
empty_str
(
real_ns
(
Uri
.
mk
(
U
.
mk
uri
)))
table
in
aux
table
attrs
rest
|
(
n
,
v
)
::
rest
->
match
split_qname
(
U
.
mk
n
)
with
|
(
"xmlns"
,
pr
)
->
let
table
=
add_prefix
pr
(
real_ns
(
Uri
.
mk
(
U
.
mk
v
)))
table
in
aux
table
attrs
rest
|
x
->
aux
table
((
x
,
U
.
mk
v
)
::
attrs
)
rest
in
aux
table
[]
attrs
...
...
misc/ns.mli
View file @
253d89fd
...
...
@@ -56,6 +56,10 @@ val process_start_tag:
table
->
string
->
(
string
*
string
)
list
->
table
*
QName
.
t
*
(
Label
.
t
*
Utf8
.
t
)
list
val
process_start_tag_subst
:
table
->
string
->
(
string
*
string
)
list
->
Uri
.
t
Hashtbl
.
Make
(
Uri
)
.
t
->
table
*
QName
.
t
*
(
Label
.
t
*
Utf8
.
t
)
list
val
map_tag
:
table
->
Utf8
.
t
->
QName
.
t
val
map_attr
:
table
->
Utf8
.
t
->
QName
.
t
val
map_prefix
:
table
->
Utf8
.
t
->
Uri
.
t
...
...
runtime/load_xml.ml
View file @
253d89fd
...
...
@@ -5,6 +5,8 @@ open Ident
open
Encodings
let
keep_ns
=
ref
true
module
H
=
Hashtbl
.
Make
(
Ns
.
Uri
)
let
subst_ns
=
H
.
create
10
type
buf
=
{
mutable
buffer
:
string
;
...
...
@@ -73,7 +75,8 @@ let start_element_handler name att =
stack
:=
String
(
String
.
sub
txt
.
buffer
0
txt
.
pos
,
!
stack
);
txt
.
pos
<-
0
;
let
(
table
,
name
,
att
)
=
Ns
.
process_start_tag
!
ns_table
name
att
in
let
(
table
,
name
,
att
)
=
Ns
.
process_start_tag_subst
!
ns_table
name
att
subst_ns
in
stack
:=
Start
(
table
,
Atoms
.
V
.
mk
name
,
att
,!
ns_table
,
!
stack
);
ns_table
:=
table
...
...
@@ -92,6 +95,22 @@ let xml_parser = ref (fun s -> failwith "No XML parser available")
let
load_xml
?
(
ns
=
false
)
s
=
try
H
.
clear
subst_ns
;
keep_ns
:=
ns
;
!
xml_parser
s
;
match
!
stack
with
|
Element
(
x
,
Empty
)
->
stack
:=
Empty
;
x
|
_
->
Value
.
failwith'
"No XML stream to parse"
with
e
->
stack
:=
Empty
;
txt
.
pos
<-
0
;
match
e
with
|
Ns
.
UnknownPrefix
n
->
Value
.
failwith'
(
"Unknown namespace prefix: "
^
(
U
.
get_str
n
))
|
e
->
raise
e
let
load_xml_subst
?
(
ns
=
false
)
s
subst
=
H
.
clear
subst_ns
;
List
.
iter
(
fun
(
k
,
v
)
->
H
.
replace
subst_ns
k
v
)
subst
;
try
keep_ns
:=
ns
;
!
xml_parser
s
;
...
...
runtime/load_xml.mli
View file @
253d89fd
val
load_xml
:
?
ns
:
bool
->
string
->
Value
.
t
val
load_xml_subst
:
?
ns
:
bool
->
string
->
(
Ns
.
Uri
.
t
*
Ns
.
Uri
.
t
)
list
->
Value
.
t
val
load_html
:
string
->
Value
.
t
...
...
runtime/print_xml.ml
View file @
253d89fd
...
...
@@ -55,6 +55,7 @@ let write_data_string ~to_enc buf s =
open
Value
open
Ident
module
U
=
Encodings
.
Utf8
module
H
=
Hashtbl
.
Make
(
Ns
.
Uri
)
let
exn_print_xml
=
CDuceExn
(
Pair
(
Atom
(
Atoms
.
V
.
mk_ascii
"Invalid_argument"
)
,
...
...
@@ -94,7 +95,7 @@ and schema_values ~wds ~wcs v =
schema_values
~
wds
~
wcs
tl
|
_
->
raise
exn_print_xml
let
to_buf
~
utf8
buffer
ns_table
v
=
let
to_buf
~
utf8
buffer
ns_table
v
subst
=
let
to_enc
=
if
utf8
then
`Enc_utf8
else
`Enc_iso88591
in
let
printer
=
Ns
.
Printer
.
printer
ns_table
in
...
...
@@ -183,15 +184,29 @@ let to_buf ~utf8 buffer ns_table v =
|
Atom
a
when
a
=
Sequence
.
nil_atom
->
()
|
v
->
schema_value
~
wds
~
wcs
v
in
let
uri_subst
prefixes
replace
=
let
h
=
H
.
create
10
in
List
.
iter
(
fun
(
k
,
v
)
->
H
.
replace
h
k
v
)
replace
;
List
.
map
(
fun
(
pr
,
ns
)
->
if
H
.
mem
h
ns
then
(
pr
,
H
.
find
h
ns
)
else
(
pr
,
ns
))
prefixes
in
document_start
()
;
print_elt
(
Ns
.
Printer
.
prefixes
printer
)
v
match
subst
with
[]
->
print_elt
(
Ns
.
Printer
.
prefixes
printer
)
v
|
_
->
print_elt
(
uri_subst
(
Ns
.
Printer
.
prefixes
printer
)
subst
)
v
let
print_xml
~
utf8
ns_table
s
=
let
buf
=
Buffer
.
create
32
in
to_buf
~
utf8
(
Buffer
.
add_string
buf
)
ns_table
s
;
to_buf
~
utf8
(
Buffer
.
add_string
buf
)
ns_table
s
[]
;
let
s
=
Buffer
.
contents
buf
in
if
utf8
then
string_utf8
(
U
.
mk
s
)
else
string_latin1
s
let
print_xml_subst
~
utf8
ns_table
s
subst
=
let
buf
=
Buffer
.
create
32
in
to_buf
~
utf8
(
Buffer
.
add_string
buf
)
ns_table
s
subst
;
let
s
=
Buffer
.
contents
buf
in
if
utf8
then
string_utf8
(
U
.
mk
s
)
else
string_latin1
s
let
dump_xml
~
utf8
ns_table
s
=
to_buf
~
utf8
print_string
ns_table
s
;
to_buf
~
utf8
print_string
ns_table
s
[]
;
Value
.
nil
runtime/print_xml.mli
View file @
253d89fd
val
print_xml
:
utf8
:
bool
->
Ns
.
table
->
Value
.
t
->
Value
.
t
val
dump_xml
:
utf8
:
bool
->
Ns
.
table
->
Value
.
t
->
Value
.
t
val
print_xml_subst
:
utf8
:
bool
->
Ns
.
table
->
Value
.
t
->
(
Ns
.
Uri
.
t
*
Ns
.
Uri
.
t
)
list
->
Value
.
t
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