├── doc
    ├── api.odocl
    └── dev.odocl
├── .merlin
├── .ocp-indent
├── CHANGES.md
├── src
    ├── dicomm.mllib
    ├── dicomm_time.ml
    ├── dicomm_time.mli
    ├── dicomm_bytes.mli
    ├── dicomm_bytes.ml
    └── dicomm.ml
├── .gitignore
├── _tags
├── pkg
    ├── pkg.ml
    └── META
├── TODO.md
├── opam
├── LICENSE.md
├── test
    ├── test.ml
    └── dicomtrip.ml
└── README.md


/doc/api.odocl:
--------------------------------------------------------------------------------
1 | Dicomm
2 | 


--------------------------------------------------------------------------------
/.merlin:
--------------------------------------------------------------------------------
1 | PKG bytes
2 | S src
3 | S test
4 | B _build/**


--------------------------------------------------------------------------------
/.ocp-indent:
--------------------------------------------------------------------------------
1 | strict_with=always,match_clause=4,strict_else=never


--------------------------------------------------------------------------------
/doc/dev.odocl:
--------------------------------------------------------------------------------
1 | Dicomm
2 | Dicomm_bytes
3 | Dicomm_data
4 | Dicomm_time


--------------------------------------------------------------------------------
/CHANGES.md:
--------------------------------------------------------------------------------
1 | v0.0.0 YYYY-MM-DD Location
2 | --------------------------
3 | 


--------------------------------------------------------------------------------
/src/dicomm.mllib:
--------------------------------------------------------------------------------
1 | Dicomm_data
2 | Dicomm_bytes
3 | Dicomm_time
4 | Dicomm


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | _build
2 | tmp
3 | *~
4 | \.\#*
5 | \#*#
6 | *.install
7 | *.byte
8 | *.native


--------------------------------------------------------------------------------
/_tags:
--------------------------------------------------------------------------------
1 | true : bin_annot, safe_string, package(bytes)
2 | 
3 | <src> : include
4 | <test> : include
5 | 
6 | <test/dicomtrip.{byte,native}> : use_unix, use_bigarray
7 | 


--------------------------------------------------------------------------------
/pkg/pkg.ml:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env ocaml
 2 | #use "topfind"
 3 | #require "topkg"
 4 | open Topkg
 5 | 
 6 | let () =
 7 |   Pkg.describe "dicomm" @@ fun c ->
 8 |   Ok [ Pkg.mllib "src/dicomm.mllib";
 9 |        Pkg.bin "test/dicomtrip"; ]
10 | 


--------------------------------------------------------------------------------
/pkg/META:
--------------------------------------------------------------------------------
1 | version = "%%VERSION%%"
2 | description = "Non-blocking streaming DICOM data element decoder for OCaml"
3 | requires = "bytes"
4 | archive(byte) = "dicomm.cma"
5 | archive(native) = "dicomm.cmxa"
6 | plugin(byte) = "dicomm.cma"
7 | plugin(native) = "dicomm.cmxs"
8 | 


--------------------------------------------------------------------------------
/TODO.md:
--------------------------------------------------------------------------------
 1 | * Sort out the encoding business and map everything to UTF-8 
 2 | * Decode OB, OW with undefined size. 
 3 | * Parse `TM `DT `DA
 4 | * Unpadding of `UN or `OB ?
 5 | * Add a ~raw attribute, when false we should automatically handles pixel 
 6 |   data normalization, i.e. handles bits allocated, bits_stored and high bit,
 7 |   and mapping planar bitmaps to non planar ones.
 8 | * Doc, examples
 9 | * Check that tags are in order, report if they are not and continue.
10 | * On regular `End check that d.stack is empty.
11 | * Encoder
12 | 


--------------------------------------------------------------------------------
/opam:
--------------------------------------------------------------------------------
 1 | opam-version: "1.2"
 2 | maintainer: "Daniel Bünzli <daniel.buenzl i@erratique.ch>"
 3 | authors: ["Daniel Bünzli <daniel.buenzl i@erratique.ch>"]
 4 | homepage: "http://erratique.ch/software/dicomm"
 5 | doc: "http://erratique.ch/software/dicomm/doc/Dicomm"
 6 | dev-repo: "http://erratique.ch/repos/dicomm.git"
 7 | bug-reports: "https://github.com/dbuenzli/dicomm/issues"
 8 | tags: [ "decoder" "dicom" "image" "graphics" "org:erratique" ]
 9 | license: "ISC"
10 | depends: [
11 |   "ocamlfind" {build}
12 |   "ocamlbuild" {build}
13 |   "topkg" {build}
14 | ]
15 | available: [ocaml-version >= "4.01.0"]
16 | build: [[
17 |   "ocaml" "pkg/pkg.ml" "build"
18 |           "--pinned" "%{pinned}%"
19 | ]]


--------------------------------------------------------------------------------
/LICENSE.md:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2014 Daniel C. Bünzli
 2 | 
 3 | Permission to use, copy, modify, and/or distribute this software for any
 4 | purpose with or without fee is hereby granted, provided that the above
 5 | copyright notice and this permission notice appear in all copies.
 6 | 
 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
14 | 


--------------------------------------------------------------------------------
/test/test.ml:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
 3 |    Distributed under the ISC license, see terms at the end of the file.
 4 |    %%NAME%% %%VERSION%%
 5 |   ---------------------------------------------------------------------------*)
 6 | 
 7 | 
 8 | 
 9 | 
10 | let () = ()
11 | 
12 | (*---------------------------------------------------------------------------
13 |    Copyright (c) 2014 Daniel C. Bünzli
14 | 
15 |    Permission to use, copy, modify, and/or distribute this software for any
16 |    purpose with or without fee is hereby granted, provided that the above
17 |    copyright notice and this permission notice appear in all copies.
18 | 
19 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
20 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
21 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
22 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
23 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
24 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
25 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
26 |   ---------------------------------------------------------------------------*)
27 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | Dicomm — Non-blocking streaming DICOM data element decoder for OCaml
 2 | -------------------------------------------------------------------------------
 3 | Release %%VERSION%%
 4 | 
 5 | Dicomm is a non-blocking streaming decoder for [DICOM][1] data elements.
 6 | 
 7 | Dicomm depends on bigarrays and is distributed under the ISC license.
 8 | 
 9 | [1]: http://medical.nema.org/standard.html
10 | 
11 | Home page: http://erratique.ch/software/dicomm  
12 | Contact: Daniel Bünzli `<daniel.buenzl i@erratique.ch>`
13 | 
14 | ## Installation
15 | 
16 | Dicomm can be installed with `opam`:
17 | 
18 |     opam install dicomm
19 | 
20 | If you don't use `opam` consult the [`opam`](opam) file for build
21 | instructions and a complete specification of the dependencies. 
22 | 
23 | ## Documentation 
24 | 
25 | The documentation and API reference is automatically generated 
26 | by `ocamldoc` from `dicomm.mli`. It can be consulted [online][2] and
27 | there is a generated version in the `doc` directory of the
28 | distribution. 
29 | 
30 | [2]: http://erratique.ch/software/dicomm/doc/Dicomm
31 | 
32 | ## Sample programs 
33 | 
34 | Sample programs are located in the `test` directory of the
35 | distribution. They can be built with:
36 | 
37 |     ocamlbuild tests.otarget 
38 |     
39 | The resulting binaries are in `_build/test`:
40 | 
41 | - `test.byte` tests the library, nothing should fail.
42 | - `dicomtrip.native`, among other things, reads a DICOM file and
43 |   prints a human readable representation on `stdout`. Invoke with
44 |   `-help` for more information.
45 | 


--------------------------------------------------------------------------------
/src/dicomm_time.ml:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
 3 |    Distributed under the ISC license, see terms at the end of the file.
 4 |    %%NAME%% %%VERSION%%
 5 |   ---------------------------------------------------------------------------*)
 6 | 
 7 | type t = [ `Daytime of float | `Stamp of float * float option ]
 8 | 
 9 | let stamp_of_da s i len = failwith "TODO"
10 | (*
11 |   try
12 |     let s = Bytes.bytes d.i in
13 |     let i = Bytes.start d.i in
14 |     let sub s len = int_of_string (String.sub s (i + s) len) in
15 |     let yyyy, mm, dd =
16 |       if len = 10 then (sub 0 4), (sub 5 2), (sub 8 2) else
17 |       if len = 8 then (sub 0 4), (sub 4 2), (sub 6 2) else
18 |       failwith ""
19 |     in
20 |     if
21 |   with Failure _ -> None
22 | *)
23 | 
24 | 
25 | let stamp_of_dt s j len = failwith "TODO"
26 |   (* N.B. context sensitive if no TZ, see doc about VR in the standard. *)
27 | 
28 | let daytime_of_tm s j len = failwith "TODO"
29 | let pp ppf t = failwith "TODO"
30 | 
31 | (*---------------------------------------------------------------------------
32 |    Copyright (c) 2014 Daniel C. Bünzli
33 | 
34 |    Permission to use, copy, modify, and/or distribute this software for any
35 |    purpose with or without fee is hereby granted, provided that the above
36 |    copyright notice and this permission notice appear in all copies.
37 | 
38 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
39 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
40 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
41 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
42 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
43 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
44 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
45 |   ---------------------------------------------------------------------------*)
46 | 


--------------------------------------------------------------------------------
/src/dicomm_time.mli:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
 3 |    Distributed under the ISC license, see terms at the end of the file.
 4 |    %%NAME%% %%VERSION%%
 5 |   ---------------------------------------------------------------------------*)
 6 | 
 7 | (** Time stamps.
 8 | 
 9 |    {b Warning.} This is a private module do not use directly. *)
10 | 
11 | type t = [ `Daytime of float | `Stamp of float * float option ]
12 | (** The type for representing times. *)
13 | 
14 | val stamp_of_da : string -> int -> int -> [`Ok of t | `Error ]
15 | (** [stamp_of_date s start len] is a unix time [`Stamp] parsed from
16 |     the substring of length [len] starting at [start] in [s].
17 | 
18 |     Parses ["YYYYMMDD"] or ["YYYYxMMyDD"] where [x,y] are arbitrary
19 |     separators. *)
20 | 
21 | val stamp_of_dt : string -> int -> int -> [ `Ok of t | `Error ]
22 | (** [stamp_of_dt s start len] is a unix time [`Stamp] parsed from
23 |     the substring of length [len] starting at [start] in [s].
24 | 
25 |     Parses ["YYYYMMDD"] or ["YYYYxMMyDD"] where [x,y] are arbitrary
26 |     separators. *)
27 | 
28 | val daytime_of_tm : int -> int -> int -> [`Ok of t | `Error ]
29 | (** [daytime_of_tm s start len] is a `Daytime parsed from the
30 |     substring of length [len] starting at [start] in [s].
31 | 
32 |     Parses prefixes of ["HHMMSS.FFFFFF"] or ["HHxMMySS.FFFFFF"] where
33 |     [x,y] are arbitrary separators. *)
34 | 
35 | val pp : Format.formatter -> t -> unit
36 | (** [pp ppf t] prints an unspecified representation of [t] on [ppf]. *)
37 | 
38 | (*---------------------------------------------------------------------------
39 |    Copyright (c) 2014 Daniel C. Bünzli
40 | 
41 |    Permission to use, copy, modify, and/or distribute this software for any
42 |    purpose with or without fee is hereby granted, provided that the above
43 |    copyright notice and this permission notice appear in all copies.
44 | 
45 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
46 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
47 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
48 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
49 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
50 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
51 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
52 |   ---------------------------------------------------------------------------*)
53 | 


--------------------------------------------------------------------------------
/src/dicomm_bytes.mli:
--------------------------------------------------------------------------------
 1 | (*---------------------------------------------------------------------------
 2 |    Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
 3 |    Distributed under the ISC license, see terms at the end of the file.
 4 |    %%NAME%% %%VERSION%%
 5 |   ---------------------------------------------------------------------------*)
 6 | 
 7 | (** Non-blocking, best effort zero-copy, byte stream.
 8 | 
 9 |    {b Warning.} This is a private module do not use directly.
10 | 
11 |    The client asks for [n] bytes with [Bytes.get]. [n] bytes can be
12 |    read from [Bytes.start] in [Bytes.bytes] whenever either
13 |    [Bytes.get] returned [`Ok] or if it returned [`Await] after calls
14 |    to [Bytes.await] eventually returned [`Ok]. If any of these calls
15 |    return [`End] then only [Bytes.len] bytes (< [n]) are available. If
16 |    you are interested in the string, using [Bytes.copy] is preferable
17 |    to extracting the substring from [Bytes.bytes] *)
18 | 
19 | (** {1 Byte stream} *)
20 | 
21 | type src = [ `Channel of Pervasives.in_channel | `Manual | `String of string ]
22 | (** The type for byte sources. *)
23 | 
24 | type t
25 | (** The type for byte streams. *)
26 | 
27 | val create : [< src] -> t
28 | (** [create src] is a new byte stream taking its bytes from [src]. *)
29 | 
30 | val source : t -> Bytes.t -> int -> int -> unit
31 | (** [source bs s j l] provides [bs] with [l] bytes to read, starting
32 |     at [j] in [s]. For [`Manual] sources only. *)
33 | 
34 | val skip : t -> int -> [ `Await | `End | `Ok ]
35 | (** [skip bs len] skips [len] bytes. *)
36 | 
37 | val get : t -> int -> [ `Await | `End | `Ok ]
38 | (** [get bs len] reads [len] bytes. *)
39 | 
40 | val await : t -> [ `Await | `End | `Ok ]
41 | (** [await bs] awaits more bytes to fullfill {!get} or {!skip} request. *)
42 | 
43 | val bytes : t -> Bytes.t
44 | (** [bytes bs] holds the last (but not only) requested bytes. *)
45 | 
46 | val start : t -> int
47 | (** [start bs] is the start index to read in [bytes d]. *)
48 | 
49 | val len : t -> int
50 | (** [len bs] is the number of bytes to read in [bytes bs] *)
51 | 
52 | val copy : t -> string
53 | (** [copy bs] is a copy for the last requested bytes. *)
54 | 
55 | val count : t -> int
56 | (** [count bs] is the total number of bytes read so far. *)
57 | 
58 | val src : t -> src
59 | (** [src bs] is [bs]'s source. *)
60 | 
61 | (** {1 DICOM specific} *)
62 | 
63 | val copy_unpad_bytes : t -> string
64 | (** [copy_unpad_bytes bs] is like {!copy} but removes an eventual
65 |     trailing '\x00' byte. *)
66 | 
67 | val copy_unpad_string : t -> string
68 | (** [copy_unpad bs] is like {!copy} but removes an eventual
69 |     trailing '\x20' or '\x00' (DICOM mandates '\x20' for
70 |     strings but some images are padded with '\x00' in the wild). *)
71 | 
72 | val copy_many_unpad_string : t -> string list
73 | (** [copy_many_unpad bs c] is like {!copy_unpad} but split the resulting
74 |     string at '\\' chars. *)
75 | 
76 | (*---------------------------------------------------------------------------
77 |    Copyright (c) 2014 Daniel C. Bünzli
78 | 
79 |    Permission to use, copy, modify, and/or distribute this software for any
80 |    purpose with or without fee is hereby granted, provided that the above
81 |    copyright notice and this permission notice appear in all copies.
82 | 
83 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
84 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
85 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
86 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
87 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
88 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
89 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
90 |   ---------------------------------------------------------------------------*)
91 | 


--------------------------------------------------------------------------------
/src/dicomm_bytes.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | 
  8 | let io_buffer_size = 65536                          (* IO_BUFFER_SIZE 4.0.0 *)
  9 | 
 10 | let invalid_bounds j l =
 11 |   invalid_arg (Printf.sprintf "invalid bounds (index %d, length %d)" j l)
 12 | 
 13 | type src = [ `Channel of Pervasives.in_channel | `Manual | `String of string ]
 14 | 
 15 |   (* We try to use as much as possible the string provided in the
 16 |     input chunk [i] provided by [source]. If the number of requested
 17 |     bytes overlaps two input chunks we go through the buffer [buf]. *)
 18 | 
 19 | type t =
 20 |   { src : src;
 21 |     mutable i : Bytes.t;                    (* Current input chunk. *)
 22 |     mutable i_pos : int;            (* Next input position to read. *)
 23 |     mutable i_max : int;               (* Maximal position to read. *)
 24 |     mutable buf : Buffer.t; (* Buffer for gets overlapping two [i]. *)
 25 |     mutable bytes : Bytes.t;   (* Reference on string to read from. *)
 26 |     mutable bytes_is_i : bool;         (* [true] if [bytes] is [i]. *)
 27 |     mutable start : int;                  (* Position to read from. *)
 28 |     mutable req : int;           (* Last number of bytes requested. *)
 29 |     mutable need : int;            (* Number of bytes still needed. *)
 30 |     mutable count : int;      (* total number of bytes read so far. *)
 31 |     mutable skip : bool;               (* [true] if skipping bytes. *) }
 32 | 
 33 | let create src =
 34 |   let i, i_pos, i_max = match src with
 35 |   | `Manual -> Bytes.empty, 1, 0                  (* implies i_rem d = 0. *)
 36 |   | `Channel _ -> Bytes.create io_buffer_size, 1, 0              (* idem. *)
 37 |   | `String s -> Bytes.unsafe_of_string s, 0, String.length s - 1
 38 |   in
 39 |   { src = (src :> src);
 40 |     i; i_pos; i_max;
 41 |     buf = Buffer.create (io_buffer_size * 2);
 42 |     bytes = i; start = 0; bytes_is_i = true;
 43 |     req = 0; need = 0; count = 0; skip = false; }
 44 | 
 45 | let i_rem d = d.i_max - d.i_pos + 1    (* remaining byte to read in [d.i]. *)
 46 | let eoi d =
 47 |   d.i <- Bytes.empty; d.i_pos <- max_int; d.i_max <- 0 (* set eoi in [d]. *)
 48 | 
 49 | let source d s j l =
 50 |   if (j < 0 || l < 0 || j + l > Bytes.length s) then invalid_bounds j l else
 51 |   if (l = 0) then eoi d else
 52 |   (d.i <- s; d.i_pos <- j; d.i_max <- j + l - 1)
 53 | 
 54 | let rec await d =
 55 |   let rem = i_rem d in
 56 |   if rem < 0 then `End else
 57 |   if d.need <= rem then begin
 58 |     if d.skip then begin
 59 |       d.i_pos <- d.i_pos + d.need;
 60 |       d.count <- d.count + d.req;
 61 |       d.need <- 0;
 62 |       d.skip <- false;
 63 |     end else begin
 64 |       if Buffer.length d.buf = 0 then begin
 65 |         d.bytes <- d.i;
 66 |         d.bytes_is_i <- true;
 67 |         d.start <- d.i_pos;
 68 |         d.i_pos <- d.i_pos + d.need;
 69 |         d.count <- d.count + d.req;
 70 |         d.need <- 0;
 71 |       end else begin
 72 |         Buffer.add_substring d.buf (Bytes.unsafe_to_string d.i) d.i_pos d.need;
 73 |           d.bytes <- Bytes.unsafe_of_string (Buffer.contents d.buf);
 74 |         Buffer.clear d.buf;
 75 |         d.bytes_is_i <- false;
 76 |         d.start <- 0;
 77 |         d.i_pos <- d.i_pos + d.need;
 78 |         d.count <- d.count + d.req;
 79 |         d.need <- 0;
 80 |       end
 81 |     end;
 82 |     `Ok
 83 |     end else begin
 84 |     if d.skip then d.need <- d.need - rem else
 85 |     begin
 86 |       d.need <- d.need - rem;
 87 |       Buffer.add_substring d.buf (Bytes.unsafe_to_string d.i) d.i_pos rem
 88 |     end;
 89 |     `Await
 90 |   end
 91 | 
 92 | let rec refill d = match d.src with             (* get new input in [d.i]. *)
 93 | | `Manual -> `Await
 94 | | `String _ -> `End
 95 | | `Channel ic ->
 96 |     let rc = input ic d.i 0 (Bytes.length d.i) in
 97 |     source d d.i 0 rc;
 98 |     match await d with
 99 |     | `Await -> refill d
100 |     | `End | `Ok as v -> v
101 | 
102 | let skip d n =
103 |   let rem = i_rem d in
104 |   if rem < 0 then `End else
105 |   if n <= rem then begin                          (* non-overlapping skip. *)
106 |     d.req <- n;
107 |     d.need <- 0;
108 |     d.i_pos <- d.i_pos + n;
109 |     d.count <- d.count + n;
110 |       `Ok
111 |   end else begin                                      (* overlapping skip. *)
112 |     d.req <- n;
113 |     d.need <- n - rem;
114 |     d.skip <- true;
115 |     refill d
116 |   end
117 | 
118 | let get d n =
119 |   let rem = i_rem d in
120 |   if rem < 0 then `End else
121 |   if n <= rem then begin                           (* non-overlapping get. *)
122 |     d.req <- n;
123 |     d.need <- 0;
124 |     d.bytes <- d.i;
125 |     d.bytes_is_i <- true;
126 |     d.start <- d.i_pos;
127 |     d.i_pos <- d.i_pos + n;
128 |     d.count <- d.count + n;
129 |     `Ok
130 |   end else begin                                       (* overlapping get. *)
131 |     d.req <- n;
132 |     d.need <- n - rem;
133 |     Buffer.add_substring d.buf (Bytes.unsafe_to_string d.i) d.i_pos rem;
134 |     refill d
135 |   end
136 | 
137 | let bytes d = d.bytes
138 | let start d = d.start
139 | let len d = d.req - d.need
140 | let copy d =
141 |   if d.bytes_is_i then Bytes.sub_string d.bytes d.start (len d) else
142 |   (Bytes.unsafe_to_string d.bytes)
143 | 
144 | let count d = d.count
145 | let src d = d.src
146 | 
147 | (* DICOM specific *)
148 | 
149 | let copy_unpad_bytes d =
150 |   let len = len d in
151 |   if len = 0 then "" else
152 |   let max = d.start + len - 1 in
153 |   let len' = if Bytes.get d.bytes max = '\x00' then len - 1 else len in
154 |   if d.bytes_is_i then Bytes.sub_string d.bytes d.start len' else
155 |   if len <> len' then Bytes.sub_string d.bytes 0 len' (* FIXME: avoid cp *) else
156 |   Bytes.unsafe_to_string d.bytes
157 | 
158 | let copy_unpad_string d =
159 |   let len = len d in
160 |   if len = 0 then "" else
161 |   let max = d.start + len - 1 in
162 |   let pad = Bytes.get d.bytes max in
163 |   let len' = if pad = '\x00' || pad = '\x20' then len - 1 else len in
164 |   if d.bytes_is_i then Bytes.sub_string d.bytes d.start len' else
165 |   if len <> len' then Bytes.sub_string d.bytes 0 len' else (* FIXME: avoid cp *)
166 |   Bytes.unsafe_to_string d.bytes
167 | 
168 | let copy_many_unpad_string d =
169 |   let len = len d in
170 |   if len = 0 then [] else
171 |   let max = d.start + len - 1 in
172 |   let pad = Bytes.get d.bytes max in
173 |   let len = if pad = '\x00' || pad = '\x20' then len - 1 else len in
174 |   let max = d.start + len - 1 in
175 |   let acc = ref [] in
176 |   let loc = ref max in
177 |   try
178 |     while true do
179 |       let sep = Bytes.rindex_from d.bytes !loc '\\' in
180 |       if sep < d.start then raise Not_found;
181 |       acc := Bytes.sub_string d.bytes (sep + 1) (!loc - sep) :: !acc;
182 |       loc := sep - 1
183 |     done;
184 |     assert false
185 |   with Not_found ->
186 |     Bytes.sub_string d.bytes d.start (!loc - d.start + 1) :: !acc
187 | 
188 | (*---------------------------------------------------------------------------
189 |    Copyright (c) 2014 Daniel C. Bünzli
190 | 
191 |    Permission to use, copy, modify, and/or distribute this software for any
192 |    purpose with or without fee is hereby granted, provided that the above
193 |    copyright notice and this permission notice appear in all copies.
194 | 
195 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
196 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
197 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
198 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
199 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
200 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
201 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
202 |   ---------------------------------------------------------------------------*)
203 | 


--------------------------------------------------------------------------------
/test/dicomtrip.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | let str = Format.sprintf
  8 | let pp = Format.fprintf
  9 | let rec pp_list ?(pp_sep = Format.pp_print_cut) pp_v ppf = function
 10 | | [] -> ()
 11 | | v :: vs ->
 12 |     pp_v ppf v; if vs <> [] then (pp_sep ppf (); pp_list ~pp_sep pp_v ppf vs)
 13 | 
 14 | let exec = Filename.basename Sys.executable_name
 15 | let log msg = Format.eprintf ("%s: " ^^ msg ^^ "@?") exec
 16 | let log_error inf e =
 17 |   Format.eprintf "@[<2>%s:%s:@ %a@]@." exec inf Dicomm.pp_error e
 18 | 
 19 | let pp_pos ppf d =
 20 |   let f, l = Dicomm.decoded_range d in
 21 |   pp ppf "0x%04X-0x%04X" f l
 22 | 
 23 | (* IO tools *)
 24 | 
 25 | let io_buffer_size = 65536                          (* IO_BUFFER_SIZE 4.0.0 *)
 26 | let unix_buffer_size = 65536                      (* UNIX_BUFFER_SIZE 4.0.0 *)
 27 | 
 28 | let rec unix_read fd s j l = try Unix.read fd s j l with
 29 | | Unix.Unix_error (Unix.EINTR, _, _) -> unix_read fd s j l
 30 | 
 31 | let string_of_channel use_unix ic =
 32 |   let b = Buffer.create unix_buffer_size in
 33 |   let input, s =
 34 |     if use_unix
 35 |     then unix_read (Unix.descr_of_in_channel ic), Bytes.create unix_buffer_size
 36 |     else input ic, Bytes.create io_buffer_size
 37 |   in
 38 |   let rec loop b input s =
 39 |     let rc = input s 0 (Bytes.length s) in
 40 |     if rc = 0
 41 |     then (if ic <> stdin then close_in ic; Buffer.contents b) else
 42 |     (Buffer.add_substring b (Bytes.unsafe_to_string s) 0 rc; loop b input s)
 43 |   in
 44 |   loop b input s
 45 | 
 46 | let src_for inf sin use_unix =
 47 |   try
 48 |     let ic = if inf = "-" then stdin else open_in inf in
 49 |     if sin then `String (string_of_channel use_unix ic) else `Channel ic
 50 |   with Sys_error e -> log "%s\n" e; exit 1
 51 | 
 52 | let close_src src =
 53 |   try match src with `Channel ic when ic <> stdin -> close_in ic | _ -> () with
 54 |   | Sys_error e -> log "%s\n" e; exit 1
 55 | 
 56 | let src_for_unix inf =
 57 |   try if inf = "-" then Unix.stdin else Unix.(openfile inf [O_RDONLY] 0) with
 58 |   | Unix.Unix_error (e, _, v) -> log "%s: %s\n" (Unix.error_message e) v; exit 1
 59 | 
 60 | let close_src_unix fd = try if fd <> Unix.stdin then Unix.close fd with
 61 | | Unix.Unix_error (e, _, v) -> log "%s: %s\n" (Unix.error_message e) v; exit 1
 62 | 
 63 | (* Decode only. *)
 64 | 
 65 | let decode_ inf src =
 66 |   let error = log_error inf in
 67 |   let rec loop d = match Dicomm.decode d with `Await -> assert false
 68 |   | `Lexeme _ -> loop d
 69 |   | `End -> ()
 70 |   | `Error e -> error e; loop d
 71 |   in
 72 |   loop (Dicomm.decoder ~syntax:`File src);
 73 |   close_src src
 74 | 
 75 | let decode_unix inf usize fd =
 76 |   let error = log_error inf in
 77 |   let rec loop fd s d = match Dicomm.decode d with
 78 |   | `Lexeme _ -> loop fd s d
 79 |   | `End -> ()
 80 |   | `Error e -> error e; loop fd s d
 81 |   | `Await ->
 82 |       let rc = unix_read fd s 0 (Bytes.length s) in
 83 |       Dicomm.Manual.src d s 0 rc; loop fd s d
 84 |   in
 85 |   loop fd (Bytes.create usize) (Dicomm.decoder ~syntax:`File `Manual);
 86 |   close_src_unix fd
 87 | 
 88 | let decode sin use_unix usize inf =
 89 |   if sin || not use_unix then decode_ inf (src_for inf sin use_unix) else
 90 |   decode_unix inf usize (src_for_unix inf)
 91 | 
 92 | (* Dump *)
 93 | 
 94 | let pp_decode inf d ppf v =
 95 |   pp ppf "%s:%a%a@." inf pp_pos d Dicomm.pp_decode v
 96 | 
 97 | let dump_ inf src =
 98 |   let rec loop inf d = match Dicomm.decode d with `Await -> assert false
 99 |   | v ->
100 |       (pp_decode inf d) Format.std_formatter v;
101 |       if v <> `End then loop inf d
102 |   in
103 |   loop inf (Dicomm.decoder ~syntax:`File src);
104 |   close_src src
105 | 
106 | let dump_unix inf usize fd =
107 |   let rec loop fd s d = match Dicomm.decode d with
108 |   | `Await ->
109 |       let rc = unix_read fd s 0 (Bytes.length s) in
110 |       Dicomm.Manual.src d s 0 rc; loop fd s d
111 |   | v -> (pp_decode inf d) Format.std_formatter v; if v <> `End then loop fd s d
112 |   in
113 |   loop fd (Bytes.create usize) (Dicomm.decoder ~syntax:`File `Manual);
114 |   close_src_unix fd
115 | 
116 | let dump sin use_unix usize inf =
117 |   if sin || not use_unix then dump_ inf (src_for inf sin use_unix) else
118 |   dump_unix inf usize (src_for_unix inf)
119 | 
120 | (* Print. *)
121 | 
122 | let pp_tag_name ppf tag = match Dicomm.Tag.name tag with
123 | | None when (Dicomm.Tag.group tag mod 2 <> 0) -> pp ppf "private"
124 | | None -> pp ppf "unknown"
125 | | Some name -> pp ppf "%s" name
126 | 
127 | let pp_uid ppf uid = match Dicomm.Uid.name uid with
128 | | None -> pp ppf "%s" uid
129 | | Some n -> pp ppf "%s@ (%s)" n uid
130 | 
131 | let pp_value ?limit vr ppf v = match vr with
132 | | `UI ->
133 |     begin match v with
134 |     | `String (`One uid) -> pp_uid ppf uid
135 |     | `String (`Many uids) ->
136 |         let pp_sep ppf () = pp ppf ",@ " in
137 |         pp_list ~pp_sep pp_uid ppf uids
138 |     | _ -> assert false
139 |     end
140 | | _ -> Dicomm.pp_value ?limit ppf v
141 | 
142 | let pp_lexeme ?limit ppf = function
143 | | `E (tag, vr, v) ->
144 |     pp ppf "%a %a @[%a : %a@]@,"
145 |       Dicomm.Tag.pp tag Dicomm.pp_vr vr pp_tag_name tag (pp_value ?limit vr) v
146 | | `Ss tag ->
147 |     pp ppf "%a SQ @[<v>%a:@," Dicomm.Tag.pp tag pp_tag_name tag
148 | | `I -> pp ppf "Item@,"
149 | | `Se _ -> pp ppf "@]@,"
150 | 
151 | let print_ ?limit inf src =
152 |   let ppf = Format.std_formatter in
153 |   let rec loop inf d = match Dicomm.decode d with
154 |   | `Await -> assert false
155 |   | `Lexeme l -> pp ppf  "%a" (pp_lexeme ?limit) l; loop inf d
156 |   | `End -> ()
157 |   | `Error e ->
158 |       pp Format.err_formatter "%s:%a: @[%a@]@."
159 |         inf pp_pos d Dicomm.pp_error e; loop inf d
160 |   in
161 |   pp ppf "@[<v>";
162 |   loop inf (Dicomm.decoder ~syntax:`File src);
163 |   pp ppf "@]@.";
164 |   close_src src
165 | 
166 | let print_unix ?limit inf usize fd =
167 |   let ppf = Format.std_formatter in
168 |   let rec loop fd s d = match Dicomm.decode d with
169 |   | `Await ->
170 |       let rc = unix_read fd s 0 (Bytes.length s) in
171 |       Dicomm.Manual.src d s 0 rc; loop fd s d
172 |   | `Lexeme l -> pp ppf  "%a" (pp_lexeme ?limit) l; loop fd s d
173 |   | `End -> ()
174 |   | `Error e ->
175 |       pp Format.err_formatter "%s:%a: @[%a@]@." inf pp_pos d Dicomm.pp_error e;
176 |       loop fd s d
177 |   in
178 |   pp ppf "@[<v>";
179 |   loop fd (Bytes.create usize) (Dicomm.decoder ~syntax:`File `Manual);
180 |   pp ppf "@]@.";
181 |   close_src_unix fd
182 | 
183 | let print limit sin use_unix usize inf =
184 |   if sin || not use_unix
185 |   then print_ ?limit inf (src_for inf sin use_unix)
186 |   else print_unix ?limit inf usize (src_for_unix inf)
187 | 
188 | (* dicomtrip *)
189 | 
190 | let main () =
191 |   let usage = Printf.sprintf
192 |       "Usage: %s [OPTION]... [DICOMFILE]...\n\
193 |        Print human readable DICOM file information on stdout.\n\
194 |        Options:" exec
195 |   in
196 |   let cmd = ref `Print in
197 |   let set_cmd v () = cmd := v in
198 |   let files = ref [] in
199 |   let add_file f = files := f :: !files in
200 |   let sin = ref false in
201 |   let use_unix = ref false in
202 |   let usize = ref unix_buffer_size in
203 |   let limit = ref (Some 128) in
204 |   let nat s r v = if v > 0 then r := v else log "%s must be > 0, ignored\n" s in
205 |   let options = [
206 |     "-print", Arg.Unit (set_cmd `Print),
207 |     " Elements in human readable form.";
208 |     "-dec", Arg.Unit (set_cmd `Decode),
209 |     " Decode only";
210 |     "-limit", Arg.Int (fun i -> limit := Some i),
211 |     "<int> max number of array elements to print (defaults to 128).";
212 |     "-unlimited", Arg.Unit (fun () -> limit := None),
213 |     " always print all the elements of arrays.";
214 |     "-dump", Arg.Unit (set_cmd `Dump),
215 |     " Dump decodes and their position, one per line";
216 |     "-sin", Arg.Set sin,
217 |     " Input as string and decode the string";
218 |     "-unix", Arg.Set use_unix,
219 |     " Use Unix IO";
220 |     "-usize", Arg.Int (nat "-usize" usize),
221 |     "<int> Unix IO buffer sizes in bytes"; ]
222 |   in
223 |   Arg.parse (Arg.align options) add_file usage;
224 |   let files = match !files with [] -> [ "-" ] | f -> List.rev f in
225 |   let cmd = match !cmd with
226 |   | `Print -> print !limit !sin !use_unix !usize
227 |   | `Dump -> dump !sin !use_unix !usize
228 |   | `Decode -> decode !sin !use_unix !usize
229 |   in
230 |   List.iter cmd files
231 | 
232 | let () = main ()
233 | 
234 | (*---------------------------------------------------------------------------
235 |    Copyright (c) 2014 Daniel C. Bünzli
236 | 
237 |    Permission to use, copy, modify, and/or distribute this software for any
238 |    purpose with or without fee is hereby granted, provided that the above
239 |    copyright notice and this permission notice appear in all copies.
240 | 
241 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
242 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
243 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
244 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
245 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
246 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
247 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
248 |   ---------------------------------------------------------------------------*)
249 | 


--------------------------------------------------------------------------------
/src/dicomm.ml:
--------------------------------------------------------------------------------
  1 | (*---------------------------------------------------------------------------
  2 |    Copyright (c) 2014 Daniel C. Bünzli. All rights reserved.
  3 |    Distributed under the ISC license, see terms at the end of the file.
  4 |    %%NAME%% %%VERSION%%
  5 |   ---------------------------------------------------------------------------*)
  6 | 
  7 | let pp = Format.fprintf
  8 | let rec pp_list ?(pp_sep = Format.pp_print_cut) pp_v ppf = function
  9 | | [] -> ()
 10 | | v :: vs ->
 11 |     pp_v ppf v; if vs <> [] then (pp_sep ppf (); pp_list ~pp_sep pp_v ppf vs)
 12 | 
 13 | let rec pp_bigarray ?limit ?(pp_sep = Format.pp_print_cut) pp_v ppf ba =
 14 |   let max = Bigarray.Array1.dim ba - 1 in
 15 |   let max = match limit with None -> max | Some l -> min l max in
 16 |   if max < 0 then () else
 17 |   begin
 18 |     pp_v ppf ba.{0};
 19 |     for i = 1 to max do pp_sep ppf (); pp_v ppf ba.{i} done;
 20 |     if max <> Bigarray.Array1.dim ba - 1 then pp ppf "%a..." pp_sep ();
 21 |   end
 22 | 
 23 | (* Unsafe string byte manipulations. If you don't believe the author's
 24 |    invariants, replacing with safe versions makes everything safe in
 25 |    the module. He won't be upset. *)
 26 | 
 27 | let unsafe_char s j = Bytes.unsafe_get s j
 28 | let unsafe_byte s j = Char.code (Bytes.unsafe_get s j)
 29 | 
 30 | (* Data model *)
 31 | 
 32 | type syntax = [ `File | `LE_explicit | `BE_explicit | `LE_implicit ]
 33 | 
 34 | type vr =
 35 |   [ `AE | `AS | `AT | `CS | `DA | `DS | `DT | `FL | `FD | `IS | `LO | `LT
 36 |   | `OB | `OF | `OW | `PN | `SH | `SL | `SQ | `SS | `ST | `TM | `UI | `UL
 37 |   | `UN | `US | `UT ]
 38 | 
 39 | let vr_to_string = function
 40 | | `AE -> "AE" | `AS -> "AS" | `AT -> "AT" | `CS -> "CS" | `DA -> "DA"
 41 | | `DS -> "DS" | `DT -> "DT" | `FL -> "FL" | `FD -> "FD" | `IS -> "IS"
 42 | | `LO -> "LO" | `LT -> "LT" | `OB -> "OB" | `OF -> "OF" | `OW -> "OW"
 43 | | `PN -> "PN" | `SH -> "SH" | `SL -> "SL" | `SQ -> "SQ" | `SS -> "SS"
 44 | | `ST -> "ST" | `TM -> "TM" | `UI -> "UI" | `UL -> "UL" | `UN -> "UN"
 45 | | `US -> "US" | `UT -> "UT"
 46 | 
 47 | let pp_vr ppf vr = pp ppf "%s" (vr_to_string vr)
 48 | 
 49 | let int_to_vr =
 50 |   let module Int = struct
 51 |     type t = int
 52 |     let compare : int -> int -> int = Pervasives.compare
 53 |   end
 54 |   in
 55 |   let module Imap = Map.Make (Int) in
 56 |   let vr_to_int s = ((Char.code s.[0]) lsl 8) lor (Char.code s.[1]) in
 57 |   let add_vr acc (s, v) = Imap.add (vr_to_int s) v acc in
 58 |   let int_to_vr = List.fold_left add_vr Imap.empty
 59 |       [ "AE", `AE; "AS", `AS; "AT", `AT; "CS", `CS; "DA", `DA; "DS", `DS;
 60 |         "DT", `DT; "FL", `FL; "FD", `FD; "IS", `IS; "LO", `LO; "LT", `LT;
 61 |         "OB", `OB; "OF", `OF; "OW", `OW; "PN", `PN; "SH", `SH; "SL", `SL;
 62 |         "SQ", `SQ; "SS", `SS; "ST", `ST; "TM", `TM; "UI", `UI; "UL", `UL;
 63 |         "UN", `UN; "US", `US; "UT", `UT; ]
 64 |   in
 65 |   fun i -> try Some (Imap.find i int_to_vr) with Not_found -> None
 66 | 
 67 | module Tag = struct
 68 |   module Tmap = Map.Make (Int32)
 69 |   module Tset = Set.Make (Int32)
 70 |   type t = int32
 71 | 
 72 |   let group t = Int32.(to_int (shift_right_logical t 16))
 73 |   let element t = Int32.(to_int (logand t 0x0000FFFFl))
 74 |   let of_group_element g e = Int32.(logor (shift_left (of_int g) 16) (of_int e))
 75 | 
 76 |   let dict =
 77 |     let add acc (t, v) = Tmap.add t v acc in
 78 |     List.fold_left add Tmap.empty Dicomm_data.elements
 79 | 
 80 |   let mask_to_reprs =    (* maps masks to equivalence class representatives. *)
 81 |     let to_list m = Tmap.fold (fun k v acc -> (k, v) :: acc) m [] in
 82 |     let add_mask acc (repr, mask) =
 83 |       let reprs = try Tmap.find mask acc with Not_found -> Tset.empty in
 84 |       Tmap.add mask (Tset.add repr reprs) acc
 85 |     in
 86 |     to_list (List.fold_left add_mask Tmap.empty Dicomm_data.element_ranges)
 87 | 
 88 |   let lookup t nth =
 89 |     try Some (nth (Tmap.find t dict))
 90 |     with Not_found ->
 91 |       let rec find_repr = function
 92 |       | (mask, reprs) :: rest ->
 93 |           let repr = Int32.logand t mask in
 94 |           if Tset.mem repr reprs then Some repr else find_repr rest
 95 |       | [] -> None
 96 |       in
 97 |       match find_repr mask_to_reprs with
 98 |       | None -> None
 99 |       | Some repr ->
100 |           try Some (nth (Tmap.find repr dict))
101 |           with Not_found -> assert false
102 | 
103 |   let name t = lookup t (fun (n, _, _, _, _) -> n)
104 |   let keyword t = lookup t (fun (_, k, _, _, _) -> k)
105 |   let vr t = match lookup t (fun (_, _, vr, _, _) -> vr) with
106 |   | None -> if element t = 0x0000 then Some `UL (* group length *) else None
107 |   | Some _ as r -> r
108 | 
109 |   let vm t = lookup t (fun (_, _, _, vm, _) -> vm)
110 |   let retired t = lookup t (fun (_, _, _, _, r) -> r)
111 |   let equal = ( = )
112 |   let compare = Pervasives.compare
113 |   let pp ppf t = pp ppf "@[(%04X,%04X)@]" (group t) (element t)
114 | 
115 |   let item = 0xFFFE_E000l
116 |   let item_delim = 0xFFFE_E00Dl
117 |   let seq_delim = 0xFFFE_E0DDl
118 | 
119 |   include Dicomm_data.Tag_constants
120 | end
121 | 
122 | type tag = Tag.t
123 | 
124 | module Uid = struct
125 |   type t = string
126 | 
127 |   let name =
128 |     let module Smap = Map.Make (String) in
129 |     let add acc (k, v) = Smap.add k v acc in
130 |     let names = List.fold_left add Smap.empty Dicomm_data.uid_names in
131 |     fun uid -> try Some (Smap.find uid names) with Not_found -> None
132 | 
133 |   let to_syntax = function
134 |   | "1.2.840.10008.1.2" -> `LE_implicit
135 |   | "1.2.840.10008.1.2.1" -> `LE_explicit
136 |   | "1.2.840.10008.1.2.2" -> `BE_explicit
137 |   | _ -> `LE_explicit
138 | end
139 | 
140 | type time = Dicomm_time.t
141 | let pp_time = Dicomm_time.pp
142 | 
143 | type ('a, 'b) bigarray = ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
144 | type value =
145 |   [ `String of [ `One of string | `Many of string list ]
146 |   | `UInt8 of (int, Bigarray.int8_unsigned_elt) bigarray
147 |   | `Float32 of (float, Bigarray.float32_elt) bigarray
148 |   | `Float64 of (float, Bigarray.float64_elt) bigarray
149 |   | `Int16 of (int, Bigarray.int16_signed_elt) bigarray
150 |   | `UInt16 of (int, Bigarray.int16_unsigned_elt) bigarray
151 |   | `Int32 of (int32, Bigarray.int32_elt) bigarray
152 |   | `UInt32 of (int32, Bigarray.int32_elt) bigarray
153 |   | `Tag of [ `One of Tag.t | `Many of Tag.t list ]
154 |   | `Time of [ `One of time | `Many of time list ]]
155 | 
156 | let pp_value ?limit ppf v =
157 |   let pp_sep ppf () = pp ppf ",@ " in
158 |   let pp_list pp_v = pp_list ~pp_sep pp_v in
159 |   let pp_ba pp_v = pp_bigarray ?limit ~pp_sep pp_v in
160 |   match v with
161 |   | `String (`One s) ->
162 |       pp ppf "%s" s
163 |   | `String (`Many l) ->
164 |       pp ppf "@[%a@]" (pp_list Format.pp_print_string) l
165 |   | `UInt8 ba ->
166 |       let pp_char ppf v = pp ppf "%s" (Char.escaped (Char.chr v)) in
167 |       (pp_bigarray ?limit ~pp_sep:(fun ppf () -> ()) pp_char) ppf ba
168 |   | `Int16 ba ->
169 |       (pp_ba (fun ppf v -> pp ppf "%d" v)) ppf ba
170 |   | `UInt16 ba ->
171 |       (pp_ba (fun ppf v -> pp ppf "%d" v)) ppf ba
172 |   | `Int32 ba ->
173 |       (pp_ba (fun ppf v -> pp ppf "%ld" v)) ppf ba
174 |   | `UInt32 ba ->
175 |       (pp_ba (fun ppf v -> pp ppf "%lu" v)) ppf ba
176 |   | `Float32 ba ->
177 |       (pp_ba (fun ppf v -> pp ppf "%g" v)) ppf ba
178 |   | `Float64 ba ->
179 |       (pp_ba (fun ppf v -> pp ppf "%g" v)) ppf ba
180 |   | `Tag (`One t) ->
181 |       pp ppf "%a" Tag.pp t
182 |   | `Tag (`Many l) ->
183 |       pp ppf "@[%a@]" (pp_list Tag.pp) l
184 |   | `Time (`One dt) ->
185 |       pp ppf "%a" pp_time dt
186 |   | `Time (`Many l) ->
187 |       pp ppf "@[%a@]" (pp_list pp_time) l
188 | 
189 | type element = Tag.t * vr * value
190 | 
191 | let pp_element ppf (tag, vr, v) =
192 |   let limit = None in
193 |   pp ppf "@[%a %a @[%a@]@]" Tag.pp tag pp_vr vr (pp_value ?limit) v
194 | 
195 | type lexeme = [ `E of element | `Ss of Tag.t | `Se of Tag.t | `I ]
196 | 
197 | let pp_lexeme ppf = function
198 | | `E e -> pp ppf "@[`E %a@]" pp_element e
199 | | `Ss tag -> pp ppf "@[`Ss %a@]" Tag.pp tag
200 | | `I -> pp ppf "@[`I@]"
201 | | `Se tag -> pp ppf "@[`Se %a@]" Tag.pp tag
202 | 
203 | module Bytes = Dicomm_bytes
204 | 
205 | (* Decode *)
206 | 
207 | type error = [
208 |   | `Eoi of [
209 |       | `File_preamble | `File_dicom_prefix | `Tag_or_eoi
210 |       | `Reserved of Tag.t | `Vr of Tag.t | `Value_length of Tag.t
211 |       | `Value of Tag.t | `Tag ]
212 |   | `Value_length_overflow of Tag.t
213 |   | `Value_length_undefined of Tag.t
214 |   | `Value_length_mismatch of Tag.t * int * int
215 |   | `Unknown_vr of Tag.t * string
216 |   | `Parse_int of Tag.t * string
217 |   | `Parse_float of Tag.t * string
218 |   | `Parse_time of Tag.t * string
219 |   | `Parse_file_dicom_prefix
220 |   | `File_syntax_unspecified
221 |   | `File_syntax_vr_not_uid of vr ]
222 | 
223 | let pp_error ppf = function
224 | | `Eoi e ->
225 |     pp ppf "@[end of input but@ expected@ ";
226 |     begin match e with
227 |     | `File_preamble -> pp ppf "128@ bytes@ file@ preamble"
228 |     | `File_dicom_prefix -> pp ppf "file@ `DICM'@ prefix"
229 |     | `Vr tag -> pp ppf "value@ representation@ for@ %a" Tag.pp tag
230 |     | `Reserved tag -> pp ppf "reserved@ bytes@ for@ %a" Tag.pp tag
231 |     | `Value_length tag -> pp ppf "value length@ for@ %a" Tag.pp tag
232 |     | `Value tag -> pp ppf "value@ for %a" Tag.pp tag
233 |     | `Tag_or_eoi -> pp ppf "tag@ or@ end@ of@ input"
234 |     | `Tag -> pp ppf "tag"
235 |     end;
236 |     pp ppf "@]"
237 | | `Value_length_overflow tag ->
238 |     pp ppf "@[value@ length@ overflow@ for@ %a@]" Tag.pp tag
239 | | `Value_length_undefined tag ->
240 |     pp ppf "@[value@ length@ undefined@ for@ %a@]" Tag.pp tag
241 | | `Value_length_mismatch (tag, len, csize) ->
242 |     pp ppf "@[value@ length@ %d@ not@ a@ multiple@ of@ %d@ for@ %a@]"
243 |       len csize Tag.pp tag
244 | | `Unknown_vr (tag, vr) ->
245 |     pp ppf "@[unknown@ VR %S for@ %a@]" vr Tag.pp tag
246 | | `Parse_int (tag, is) ->
247 |     pp ppf "@[could@ not@ parse@ integer@ string@ (%S)@ for@ %a@]" is Tag.pp tag
248 | | `Parse_float (tag, fs) ->
249 |     pp ppf "@[could@ not@ parse@ decimal@ string@ (%S)@ for@ %a@]" fs Tag.pp tag
250 | | `Parse_file_dicom_prefix ->
251 |     pp ppf "@[could@ not@ parse@ file@ `DICM'@ prefix@]"
252 | | `Parse_time(tag, ts) ->
253 |     pp ppf "@[could@ not@ parse@ time@ (%S)@ for @ %a@]" ts Tag.pp tag
254 | | `File_syntax_unspecified ->
255 |     pp ppf "@[unspecified file transfer syntax@]"
256 | | `File_syntax_vr_not_uid vr ->
257 |     pp ppf "@[file transfer syntax VR not an UID (%s) @]" (vr_to_string vr)
258 | 
259 | let err_eoi_file_preamble = `Error (`Eoi `File_preamble)
260 | let err_eoi_file_prefix = `Error (`Eoi `File_dicom_prefix)
261 | let err_eoi_vr tag = `Error (`Eoi (`Vr tag))
262 | let err_eoi_reserved tag = `Error (`Eoi (`Reserved tag))
263 | let err_eoi_value_length tag = `Error (`Eoi (`Value_length tag))
264 | let err_eoi_value tag = `Error (`Eoi (`Value tag))
265 | let err_eoi_tag_or_eoi = `Error (`Eoi `Tag_or_eoi)
266 | let err_eoi_tag = `Error (`Eoi `Tag)
267 | let err_unknown_tag_vr tag = `Error (`Unknown_tag_vr tag)
268 | let err_unknown_vr tag vr = `Error (`Unknown_vr (tag, vr))
269 | let err_val_len_overflow tag = `Error (`Value_length_overflow tag)
270 | let err_val_len_undefined tag = `Error (`Value_length_undefined tag)
271 | let err_val_len_mismatch tag len csize =
272 |   `Error (`Value_length_mismatch (tag, len, csize))
273 | 
274 | let err_parse_int tag is = `Error (`Parse_int (tag, is))
275 | let err_parse_float tag ds = `Error (`Parse_float (tag, ds))
276 | let err_parse_time tag ts = `Error (`Parse_time (tag, ts))
277 | let err_parse_file_prefix = `Error (`Parse_file_dicom_prefix)
278 | let err_file_syntax_unspecified = `Error (`File_syntax_unspecified)
279 | let err_file_syntax_vr_not_uid vr = `Error (`File_syntax_vr_not_uid vr)
280 | 
281 | type decode = [ `Await | `End | `Error of error | `Lexeme of lexeme ]
282 | 
283 | let pp_decode ppf = function
284 | | `Lexeme l -> pp ppf "@[`Lexeme @[(%a)@]@]" pp_lexeme l
285 | | `Await -> pp ppf "`Await"
286 | | `End -> pp ppf "`End"
287 | | `Error e -> pp ppf "@[`Error @[(%a)@]@]" pp_error e
288 | 
289 | type src = Dicomm_bytes.src
290 | type decoder =
291 |   { vr : Tag.t -> vr;                    (* Determine VR for unknown tags. *)
292 |     mutable i : Bytes.t;                      (* Non-blocking byte stream. *)
293 |     mutable syntax : syntax;                            (* Decoded syntax. *)
294 |     mutable signed_pixels : bool; (* [true] if pixels are signed according
295 |                                      to tag 0028,0103 *)
296 |     mutable spos : int;                      (* last saved start position. *)
297 |     mutable stack : (Tag.t * int) list;    (* Stack of open tag sequences. *)
298 |     mutable k : decoder -> decode                 (* decoder continuation. *) }
299 | 
300 | let save_pos d = d.spos <- Bytes.count d.i
301 | 
302 | let update_decoder_state d tag v = (* remembers a few things about the data. *)
303 |   match tag with
304 |   | 0x00280103l (* Pixel representation *) ->
305 |       begin match v with
306 |       | `UInt16 a when Bigarray.Array1.dim a >= 1 ->
307 |           d.signed_pixels <- (a.{0} = 1)
308 |       | _ -> ()
309 |       end
310 |   | _ -> ()
311 | 
312 | (* Getting and skipping bytes. *)
313 | 
314 | let never d = assert false
315 | 
316 | let ret (v : [< decode]) k d = d.k <- k; v
317 | let ret_eoi d = (save_pos d; `End)
318 | let ret_element tag vr v k d =
319 |   update_decoder_state d tag v;
320 |   ret (`Lexeme (`E (tag, vr, v))) k d
321 | 
322 | let await ~err k d =
323 |   let rec loop ~err k d = match Bytes.await d.i with
324 |   | `Ok -> k d
325 |   | `Await -> ret `Await (loop ~err k) d
326 |   | `End -> ret err ret_eoi d
327 |   in
328 |   ret `Await (loop ~err k) d
329 | 
330 | let skip n ~err k d = match Bytes.skip d.i n with
331 | | `Ok -> k d
332 | | `Await -> await ~err k d
333 | | `End -> ret err ret_eoi d
334 | 
335 | let large_skip hi lo ~err k d =
336 |   let rec loop hi lo ~err k d =
337 |     if hi = 0 then skip lo ~err k d else
338 |     skip 65535 ~err (loop (hi - 1) lo ~err k) d
339 |   in
340 |   (save_pos d; loop hi lo ~err k d)
341 | 
342 | let skip n ~err k d = save_pos d; skip n ~err k d
343 | let get n ~err k d =
344 |   save_pos d;
345 |   match Bytes.get d.i n with
346 |   | `Ok -> k d
347 |   | `Await -> await ~err k d
348 |   | `End -> ret err ret_eoi d
349 | 
350 | let try_get n ~err k d =                         (* exactly [n] bytes or eoi *)
351 |   save_pos d;
352 |   match Bytes.get d.i n with
353 |   | `Ok -> k `Ok d
354 |   | `Await ->
355 |       let rec loop k d = match Bytes.await d.i with
356 |       | `Ok -> k `Ok d
357 |       | `Await -> ret `Await (loop k) d
358 |       | `End -> if Bytes.len d.i <> 0 then ret err ret_eoi d else k `End d
359 |       in
360 |       ret `Await (loop k) d
361 |   | `End -> if Bytes.len d.i <> 0 then ret err ret_eoi d else k `End d
362 | 
363 | (* Parsing bytes *)
364 | 
365 | let p_file_prefix d =
366 |   let s = Bytes.bytes d.i in
367 |   let i = Bytes.start d.i in
368 |   unsafe_char s i       = 'D' &&
369 |   unsafe_char s (i + 1) = 'I' &&
370 |   unsafe_char s (i + 2) = 'C' &&
371 |   unsafe_char s (i + 3) = 'M'
372 | 
373 | let p_tag b1 b0 d i =
374 |   let s = Bytes.bytes d.i in
375 |   let i = Bytes.start d.i + (i * 4) in
376 |   let g0 = unsafe_byte s (i + b0) in
377 |   let g1 = unsafe_byte s (i + b1) in
378 |   let g = (g1 lsl 8) lor g0 in
379 |   let i = i + 2 in
380 |   let e0 = unsafe_byte s (i + b0) in
381 |   let e1 = unsafe_byte s (i + b1) in
382 |   let e = (e1 lsl 8) lor e0 in
383 |   Int32.(logor (shift_left (of_int g) 16) (of_int e))
384 | 
385 | let p_tag_be d i = p_tag 0 1 d i
386 | let p_tag_le d i = p_tag 1 0 d i
387 | 
388 | let p_vr d =
389 |   let s = Bytes.bytes d.i in
390 |   let i = Bytes.start d.i in
391 |   let vr1 = unsafe_byte s i in
392 |   let vr0 = unsafe_byte s (i + 1) in
393 |   int_to_vr ((vr1 lsl 8) lor vr0)
394 | 
395 | let p_length b3 b2 b1 b0 d =     (* handles 32 bits platforms gracefully. *)
396 |   let s = Bytes.bytes d.i in
397 |   let i = Bytes.start d.i in
398 |   let b0 = unsafe_byte s (i + b0) in
399 |   let b1 = unsafe_byte s (i + b1) in
400 |   let b2 = unsafe_byte s (i + b2) in
401 |   let b3 = unsafe_byte s (i + b3) in
402 |   let lo = (b1 lsl 8) lor b0 in
403 |   let hi = (b3 lsl 8) lor b2 in
404 |   let hi_32 = hi lsl 16 in
405 |   if hi = 0xFFFF && lo = 0xFFFF then `Undefined else
406 |   if hi_32 <= 0 && hi <> 0 then `Overflow (hi, lo) else
407 |   `Int (hi_32 lor lo)
408 | 
409 | let p_length_le d = p_length 3 2 1 0 d
410 | let p_length_be d = p_length 0 1 2 3 d
411 | 
412 | let p_uint8 d i =
413 |   let s = Bytes.bytes d.i in
414 |   let i = Bytes.start d.i + i in
415 |   unsafe_byte s i
416 | 
417 | let p_uint16 b1 b0 d i =
418 |   let s = Bytes.bytes d.i in
419 |   let i = Bytes.start d.i + (i * 2) in
420 |   let b0 = unsafe_byte s (i + b0) in
421 |   let b1 = unsafe_byte s (i + b1) in
422 |   ((b1 lsl 8) lor b0)
423 | 
424 | let p_uint16_le d i = p_uint16 1 0 d i
425 | let p_uint16_be d i = p_uint16 0 1 d i
426 | 
427 | let p_int16 b1 b0 d i =
428 |   let s = Bytes.bytes d.i in
429 |   let i = Bytes.start d.i + (i * 2) in
430 |   let b0 = unsafe_byte s (i + b0) in
431 |   let b1 = unsafe_byte s (i + b1) in
432 |   let v = ((b1 lsl 8) lor b0) in
433 |   v - (v lsr 15 * 0x10000)
434 | 
435 | let p_int16_le d i = p_int16 1 0 d i
436 | let p_int16_be d i = p_int16 0 1 d i
437 | 
438 | let p_int32 b3 b2 b1 b0 d i =
439 |   let s = Bytes.bytes d.i in
440 |   let i = Bytes.start d.i + (i * 4) in
441 |   let b0 = unsafe_byte s (i + b0) in
442 |   let b1 = unsafe_byte s (i + b1) in
443 |   let b2 = unsafe_byte s (i + b2) in
444 |   let b3 = unsafe_byte s (i + b3) in
445 |   let lo = (b1 lsl 8) lor b0 in
446 |   let hi = (b3 lsl 8) lor b2 in
447 |   Int32.(logor (shift_left (of_int hi) 16) (of_int lo))
448 | 
449 | let p_int32_le d i = p_int32 3 2 1 0 d i
450 | let p_int32_be d i = p_int32 0 1 2 3 d i
451 | let p_uint32_le = p_int32_le
452 | let p_uint32_be = p_int32_be
453 | let p_float32_le d i = Int32.float_of_bits (p_int32_le d i)
454 | let p_float32_be d i = Int32.float_of_bits (p_int32_be d i)
455 | 
456 | let make_float64 hi lo =
457 |   let hi = Int64.(shift_left (of_int32 hi) 32) in
458 |   let lo = Int64.(logand (of_int32 lo) 0xFFFF_FFFFL) in (* careful, sign *)
459 |   Int64.(float_of_bits (logor hi lo))
460 | 
461 | let p_float64_le d i =
462 |   let lo = p_int32_le d i in
463 |   let hi = p_int32_le d (i + 1) in
464 |   make_float64 hi lo
465 | 
466 | let p_float64_be d i =
467 |   let hi = p_int32_be d i in
468 |   let lo = p_int32_be d (i + 1) in
469 |   make_float64 hi lo
470 | 
471 | (* Decoders *)
472 | 
473 | let d_try_tag p_tag k d =                            (* decodes a tag or eoi *)
474 |   try_get 4 ~err:err_eoi_tag_or_eoi begin fun r d -> match r with
475 |   | `Ok -> k (p_tag d 0) d
476 |   | `End -> ret_eoi d
477 |   end d
478 | 
479 | let d_tag p_tag k d =
480 |   get 4 ~err:(err_eoi_tag) begin fun d -> k (p_tag d 0) d end d
481 | 
482 | let d_vr tag k d =
483 |   get 2 ~err:(err_eoi_vr tag) begin fun d -> match p_vr d with
484 |   | None -> ret (err_unknown_vr tag (Bytes.copy d.i)) (k tag `UN) d
485 |   | Some vr -> (k tag vr) d
486 |   end d
487 | 
488 | let many_values tag = match Tag.vm tag with
489 | | None | Some `One -> false
490 | | _ -> true
491 | 
492 | let skip_if_unhandled_length tag vr len k k' d = match len with
493 | | `Undefined ->
494 |     let skip = large_skip 0xFFFF 0xFFFF ~err:(err_eoi_value tag) k in
495 |     ret (err_val_len_undefined tag) skip d
496 | | `Overflow (hi, lo) ->
497 |     let err = err_eoi_value tag in
498 |     ret (err_val_len_overflow tag) (large_skip hi lo ~err k) d
499 | | `Int len when len > Sys.max_string_length ->
500 |     ret (err_val_len_overflow tag) (skip len ~err:(err_eoi_value tag) k) d
501 | | `Int len -> k' len d
502 | 
503 | let d_string tag vr len k d =
504 |   skip_if_unhandled_length tag vr len k begin fun len d ->
505 |     get len ~err:(err_eoi_value tag) begin fun d ->
506 |       let v = match many_values tag with
507 |       | true -> `String (`Many (Bytes.copy_many_unpad_string d.i))
508 |       | false -> `String (`One (Bytes.copy_unpad_string d.i))
509 |       in
510 |       ret_element tag vr v k d
511 |     end d
512 |   end d
513 | 
514 | let d_number_string tag (vr : [ `IS | `DS ]) len k d =
515 |   skip_if_unhandled_length tag vr len k begin fun len d ->
516 |     get len ~err:(err_eoi_value tag) begin fun d ->
517 |       let rec fill result parse err ba j = function
518 |       | i :: is ->
519 |           let fail =
520 |             try ba.{j} <- parse (String.trim i); false
521 |             with Failure _ -> true
522 |           in
523 |           if fail then (ret (err tag i) k d) else
524 |           fill result parse err ba (j + 1) is
525 |       | [] -> ret_element tag (vr :> vr) (result ba) k d
526 |       in
527 |       let numbers = match many_values tag with
528 |       | true -> Bytes.copy_many_unpad_string d.i
529 |       | false -> [ Bytes.copy_unpad_string d.i ]
530 |       in
531 |       let count = List.length numbers in
532 |       match vr with
533 |       | `IS ->
534 |           let ba = Bigarray.(Array1.create int32 c_layout count) in
535 |           let result ba = `Int32 ba in
536 |           fill result Int32.of_string err_parse_int ba 0 numbers
537 |       | `DS ->
538 |           let ba = Bigarray.(Array1.create float64 c_layout count) in
539 |           let result ba = `Float64 ba in
540 |           fill result float_of_string err_parse_float ba 0 numbers
541 |     end d
542 |   end d
543 | 
544 | let d_tags p_tag tag vr len k d =
545 |   skip_if_unhandled_length tag vr len k begin fun len d ->
546 |     let err = err_eoi_value tag in
547 |     let tsize = 4 in
548 |     if len mod tsize <> 0
549 |     then ret (err_val_len_mismatch tag len tsize) (skip len ~err k) d else
550 |     get len ~err begin fun d ->
551 |       let count = len / tsize in
552 |       let acc = ref [] in
553 |       for i = count - 1 downto 0 do acc := (p_tag d i) :: !acc done;
554 |       let v = match !acc with [one] -> `One one | l -> `Many l in
555 |       ret_element tag (vr :> vr) (`Tag v) k d
556 |     end d
557 |   end d
558 | 
559 | let d_array kind ksize result p_comp tag vr len k d =
560 |   let err = err_eoi_value tag in
561 |   match len with
562 |   | `Overflow (hi, lo) ->
563 |       ret (err_val_len_overflow tag) (large_skip hi lo ~err k) d
564 |   | `Undefined ->
565 |       (* TODO, here according to the transfer syntax
566 |          and for tag (7FE0, 0010) and VR `OB or `OW
567 |          we should decode, see PS 3.5 annex A. *)
568 |       let skip = large_skip 0xFFFF 0xFFFF ~err k in
569 |       ret (err_val_len_undefined tag) skip d
570 |   | `Int len when len > Sys.max_string_length ->
571 |       ret (err_val_len_overflow tag) (skip len ~err k) d
572 |   | `Int len ->
573 |       if len mod ksize <> 0
574 |       then ret (err_val_len_mismatch tag len ksize) (skip len ~err k) d else
575 |       get len ~err begin fun d ->
576 |         let count = len / ksize in
577 |         let ba = Bigarray.(Array1.create kind c_layout count) in
578 |         for i = 0 to count - 1 do ba.{i} <- p_comp d i done;
579 |         ret_element tag vr (result ba) k d
580 |       end d
581 | 
582 | let d_uint8_array tag vr len k d =
583 |   let result ba = `UInt8 ba in
584 |   d_array Bigarray.int8_unsigned 1 result p_uint8 tag vr len k d
585 | 
586 | let d_int16_array p_int16 tag vr len k d =
587 |   let result ba = `Int16 ba in
588 |   d_array Bigarray.int16_signed 2 result p_int16 tag vr len k d
589 | 
590 | let d_uint16_array p_uint16 tag vr len k d =
591 |   let result ba = `UInt16 ba in
592 |   d_array Bigarray.int16_unsigned 2 result p_uint16 tag vr len k d
593 | 
594 | let d_int32_array p_int32 tag vr len k d =
595 |   let result ba = `Int32 ba in
596 |   d_array Bigarray.int32 4 result p_int32 tag vr len k d
597 | 
598 | let d_uint32_array p_uint32 tag vr len k d =
599 |   let result ba = `UInt32 ba in
600 |   d_array Bigarray.int32 4 result p_uint32 tag vr len k d
601 | 
602 | let d_float32_array p_float32 tag vr len k d =
603 |   let result ba = `Float32 ba in
604 |   d_array Bigarray.float32 4 result p_float32 tag vr len k d
605 | 
606 | let d_float64_array p_float64 tag vr len k d =
607 |   let result ba = `Float64 ba in
608 |   d_array Bigarray.float64 8 result p_float64 tag vr len k d
609 | 
610 | let d_value p_tag p_int16 p_uint16 p_int32 p_uint32 p_float32 p_float64
611 |     tag vr len k d =
612 |   match vr with
613 |   | `CS | `SH | `LO | `ST | `LT | `UT
614 |   | `PN | `AE | `AS | `UI
615 |   | `DA | `TM | `DT -> d_string tag vr len k d
616 |   | `IS | `DS as vr -> d_number_string tag vr len k d
617 |   | `SS -> d_int16_array p_int16 tag vr len k d
618 |   | `US -> d_uint16_array p_uint16 tag vr len k d
619 |   | `OW ->
620 |       if tag = 0x7FE00010l (* pixel data *) && d.signed_pixels
621 |       then d_int16_array p_int16 tag vr len k d
622 |       else d_uint16_array p_uint16 tag vr len k d
623 |   | `SL -> d_int32_array p_int32 tag vr len k d
624 |   | `UL -> d_uint32_array p_uint32 tag vr len k d
625 |   | `FL | `OF -> d_float32_array p_float32 tag vr len k d
626 |   | `FD -> d_float64_array p_float64 tag vr len k d
627 | (*  | `OB when len = `Undefined -> *)
628 |   | `OB | `UN -> d_uint8_array tag vr len k d
629 |   | `AT -> d_tags p_tag tag vr len k d
630 |   | `SQ -> assert false
631 | 
632 | let d_value_le tag vr len k d =
633 |   d_value
634 |     p_tag_le p_int16_le p_uint16_le p_int32_le p_uint32_le p_float32_le
635 |     p_float64_le tag vr len k d
636 | 
637 | let d_value_be tag vr len k d =
638 |   d_value
639 |     p_tag_be p_int16_be p_uint16_be p_int32_be p_uint32_be p_float32_be
640 |     p_float64_be tag vr len k d
641 | 
642 | let rec d_items p_tag d_element len k d = match len with
643 | | `Undefined ->
644 |     d_tag p_tag begin fun tag d -> match tag with
645 |     | tag when tag = Tag.seq_delim ->
646 |         get 4 ~err:(err_eoi_value_length tag) begin fun d ->
647 |           let t, _ = List.hd d.stack in
648 |           d.stack <- List.tl d.stack;
649 |           ret (`Lexeme (`Se t)) k d
650 |         end d
651 |     | tag when tag = Tag.item ->
652 |         get 4 ~err:(err_eoi_value_length tag) begin fun d ->
653 |           ret (`Lexeme `I) (d_items p_tag d_element len k) d
654 |         end d
655 |     | tag when tag = Tag.item_delim ->
656 |         get 4 ~err:(err_eoi_value_length tag)
657 |           (d_items p_tag d_element len k) d
658 |     | tag ->
659 |         d_element tag (d_items p_tag d_element len k) d
660 |     end d
661 | | `Int len as l ->
662 |     let t, pos = List.hd d.stack in
663 |     if Bytes.count d.i - pos = len
664 |     then (d.stack <- List.tl d.stack; ret (`Lexeme (`Se t)) k d) else
665 |     d_tag p_tag begin fun tag d -> match tag with
666 |     | tag when tag = Tag.item ->
667 |         get 4 ~err:(err_eoi_value_length tag) begin fun d ->
668 |           ret (`Lexeme `I) (d_items p_tag d_element l k) d
669 |         end d
670 |     | tag when tag = Tag.item_delim ->
671 |         get 4 ~err:(err_eoi_value_length tag)
672 |           (d_items p_tag d_element l k) d
673 |     | tag ->
674 |         d_element tag (d_items p_tag d_element l k) d
675 |     end d
676 | 
677 | let d_sequence p_tag d_element tag len k d = match len with
678 | | `Overflow (hi, lo) ->
679 |     let err = err_eoi_value tag in
680 |     ret (err_val_len_overflow tag) (large_skip hi lo ~err k) d
681 | | `Int _ | `Undefined as len ->
682 |     d.stack <- (tag, Bytes.count d.i) :: d.stack;
683 |     ret (`Lexeme (`Ss tag)) (d_items p_tag d_element len k) d
684 | 
685 | let rec d_element_lei tag k d =
686 |   get 4 ~err:(err_eoi_value_length tag) begin fun d ->
687 |     let len = p_length_le d in
688 |     let (vr : vr) = match Tag.vr tag with
689 |     | None -> d.vr tag
690 |     | Some (#vr as vr) -> vr
691 |     | Some (`OB_or_OW) -> `OW
692 |     | Some (`US_or_SS | `US_or_OW | `US_or_SS_or_OW) -> `US
693 |     in
694 |     match vr with
695 |     | `SQ -> d_sequence p_tag_le d_element_lei tag len k d
696 |     | vr -> d_value_le tag vr len k d
697 |   end d
698 | 
699 | let rec d_element_explicit p_tag p_uint16 p_length d_value tag k d =
700 |   d_vr tag begin fun tag vr d -> match vr with
701 |   | `OB | `OW | `OF | `UT | `UN | `SQ as vr ->
702 |       save_pos d;
703 |       skip 2 ~err:(err_eoi_reserved tag) begin fun d ->
704 |         save_pos d;
705 |         get 4 ~err:(err_eoi_value_length tag) begin fun d ->
706 |           match vr with
707 |           | `SQ ->
708 |               let d_element =
709 |                 d_element_explicit p_tag p_uint16 p_length d_value
710 |               in
711 |               d_sequence p_tag d_element tag (p_length d) k d
712 |           | vr -> d_value tag vr (p_length d) k d
713 |         end d
714 |       end d
715 |   | #vr as vr ->
716 |       save_pos d;
717 |       get 2 ~err:(err_eoi_value_length tag) begin fun d ->
718 |         d_value tag vr (`Int (p_uint16 d 0)) k d
719 |       end d
720 |   end d
721 | 
722 | let d_element_lee tag k d =
723 |   d_element_explicit p_tag_le p_uint16_le p_length_le d_value_le tag k d
724 | 
725 | let d_element_bee tag k d =
726 |   d_element_explicit p_tag_be p_uint16_be p_length_be d_value_be tag k d
727 | 
728 | let rec d_elements_lei k d =
729 |   d_try_tag p_tag_le begin fun tag d ->
730 |     d_element_lei tag (d_elements_lei k) d
731 |   end d
732 | 
733 | let rec d_elements_lee k d =
734 |   d_try_tag p_tag_le begin fun tag d ->
735 |     d_element_lee tag (d_elements_lee k) d
736 |   end d
737 | 
738 | let rec d_elements_bee k d =
739 |   d_try_tag p_tag_be begin fun tag d ->
740 |     d_element_bee tag (d_elements_bee k) d
741 |   end d
742 | 
743 | (* Decode DICOM files *)
744 | 
745 | let d_transfer_syntax tag k d =   (* decode transfer syntax and adjust dec. *)
746 |   let d_uid tag k d =
747 |     get 2 ~err:(err_eoi_value_length tag) begin fun d ->
748 |       get (p_uint16_le d 0) ~err:(err_eoi_value tag) begin fun d ->
749 |         let uid = Bytes.copy_unpad_string d.i in
750 |         d.syntax <- Uid.to_syntax uid;
751 |         ret_element tag `UI (`String (`One uid)) k d
752 |       end d
753 |     end d
754 |   in
755 |   d_vr tag begin fun tag vr d ->
756 |     if vr = `UI then d_uid tag k d else
757 |     ret (err_file_syntax_vr_not_uid vr) (d_uid tag k) d
758 |   end d
759 | 
760 | let rec d_file_meta k d =          (* decode group 0002 and adjust syntax. *)
761 |   d_try_tag p_tag_le begin fun tag d ->
762 |     if Tag.group tag = 0x0002 then begin
763 |       if Tag.element tag = 0x0010
764 |       then d_transfer_syntax tag (d_file_meta k) d
765 |       else d_element_lee tag (d_file_meta k) d
766 |     end else begin
767 |       match d.syntax with
768 |       | `LE_implicit ->
769 |           d_element_lei tag (d_elements_lei k) d
770 |       | `LE_explicit ->
771 |           d_element_lee tag (d_elements_lee k) d
772 |       | `BE_explicit ->
773 |           let tag = p_tag_be d 0 in (* tag in be, FIXME: brittle do swap here *)
774 |           d_element_bee tag (d_elements_bee k) d
775 |       | `File ->
776 |           d.syntax <- `LE_implicit;
777 |           ret err_file_syntax_unspecified
778 |             (d_element_lei tag (d_elements_lei k)) d
779 |     end
780 |   end d
781 | 
782 | let d_file d =          (* skip 128 bytes, decode DICM prefix and file meta. *)
783 |   skip 128 ~err:err_eoi_file_preamble begin function d ->
784 |     get 4 ~err:err_eoi_file_prefix begin function d ->
785 |       if p_file_prefix d
786 |       then (d_file_meta never) d
787 |       else ret err_parse_file_prefix (d_file_meta never) d
788 |     end d
789 |   end d
790 | 
791 | (* Decoding interface *)
792 | 
793 | let decode_fun = function
794 | | `LE_implicit -> d_elements_lei never
795 | | `LE_explicit -> d_elements_lee never
796 | | `BE_explicit -> d_elements_bee never
797 | | `File -> d_file
798 | 
799 | let decoder ?(vr = fun _ -> `UN) ~syntax src =
800 |   let k = decode_fun syntax in
801 |   { vr; i = Bytes.create src; syntax;
802 |     signed_pixels = false;
803 |     spos = 0; stack = []; k }
804 | 
805 | let decode d = d.k d
806 | let decoded_range d = d.spos, Bytes.count d.i
807 | let decoder_src d = Bytes.src d.i
808 | let decoder_syntax d = d.syntax
809 | 
810 | module Manual = struct
811 |   let src d = Bytes.source d.i
812 | end
813 | 
814 | (*---------------------------------------------------------------------------
815 |    Copyright (c) 2014 Daniel C. Bünzli
816 | 
817 |    Permission to use, copy, modify, and/or distribute this software for any
818 |    purpose with or without fee is hereby granted, provided that the above
819 |    copyright notice and this permission notice appear in all copies.
820 | 
821 |    THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
822 |    WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
823 |    MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
824 |    ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
825 |    WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
826 |    ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
827 |    OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
828 |   ---------------------------------------------------------------------------*)
829 | 


--------------------------------------------------------------------------------