pool/unison
SHA256
4
0
Fork 1
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
unison/Compile-without-unsafe-string.patch

1387 lines
47 KiB
Diff
Raw Normal View History

Accepting request 782743 from network Automatic submission by obs-autosubmit OBS-URL: https://build.opensuse.org/request/show/782743 OBS-URL: https://build.opensuse.org/package/show/openSUSE:Factory/unison?expand=0&rev=39
2020-03-09 17:33:59 +00:00
From: Stephane Glondu <steph@glondu.net>
Date: Mon, 10 Feb 2020 15:52:18 +0100
Subject: Compile without -unsafe-string
---
src/Makefile.OCaml | 2 +-
src/bytearray.ml | 27 ++++--
src/bytearray.mli | 4 +-
src/checksum.ml | 8 ++
src/checksum.mli | 5 ++
src/fileutil.ml | 2 +-
src/fingerprint.ml | 2 +-
src/fpcache.ml | 9 +-
src/fsmonitor/linux/inotify.ml | 8 +-
src/fsmonitor/watchercommon.ml | 19 ++--
src/fspath.ml | 4 +-
src/fswatch.ml | 19 ++--
src/lwt/generic/lwt_unix_impl.ml | 28 ++++--
src/lwt/lwt_unix.mli | 5 +-
src/osx.ml | 23 ++---
src/path.ml | 4 +-
src/remote.ml | 20 ++---
src/terminal.ml | 6 +-
src/test.ml | 2 +-
src/transfer.ml | 37 ++++----
src/uicommon.ml | 2 +-
src/uigtk2.ml | 2 +-
src/uitext.ml | 4 +-
src/unicode.ml | 184 ++++++++++++++++++++-------------------
24 files changed, 244 insertions(+), 182 deletions(-)
--- a/Makefile.OCaml
+++ b/Makefile.OCaml
@@ -98,7 +98,7 @@ buildexecutable::
### Default parameters
# Generate backtrace information for exceptions
-CAMLFLAGS+=-g -unsafe-string
+CAMLFLAGS+=-g
INCLFLAGS=-I lwt -I ubase -I system
CAMLFLAGS+=$(INCLFLAGS)
--- a/bytearray.ml
+++ b/bytearray.ml
@@ -38,15 +38,18 @@ let unsafe_blit_to_string a i s j l =
external unsafe_blit_from_string : string -> int -> t -> int -> int -> unit
= "ml_blit_string_to_bigarray" [@@noalloc]
-external unsafe_blit_to_string : t -> int -> string -> int -> int -> unit
+external unsafe_blit_from_bytes : bytes -> int -> t -> int -> int -> unit
+ = "ml_blit_string_to_bigarray" [@@noalloc]
+
+external unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit
= "ml_blit_bigarray_to_string" [@@noalloc]
let to_string a =
let l = length a in
if l > Sys.max_string_length then invalid_arg "Bytearray.to_string" else
let s = Bytes.create l in
- unsafe_blit_to_string a 0 s 0 l;
- s
+ unsafe_blit_to_bytes a 0 s 0 l;
+ Bytes.to_string s
let of_string s =
let l = String.length s in
@@ -61,8 +64,8 @@ let sub a ofs len =
invalid_arg "Bytearray.sub"
else begin
let s = Bytes.create len in
- unsafe_blit_to_string a ofs s 0 len;
- s
+ unsafe_blit_to_bytes a ofs s 0 len;
+ Bytes.to_string s
end
let rec prefix_rec a i a' i' l =
@@ -81,11 +84,17 @@ let blit_from_string s i a j l =
then invalid_arg "Bytearray.blit_from_string"
else unsafe_blit_from_string s i a j l
-let blit_to_string a i s j l =
+let blit_from_bytes s i a j l =
+ if l < 0 || i < 0 || i > Bytes.length s - l
+ || j < 0 || j > length a - l
+ then invalid_arg "Bytearray.blit_from_bytes"
+ else unsafe_blit_from_bytes s i a j l
+
+let blit_to_bytes a i s j l =
if l < 0 || i < 0 || i > length a - l
- || j < 0 || j > String.length s - l
- then invalid_arg "Bytearray.blit_to_string"
- else unsafe_blit_to_string a i s j l
+ || j < 0 || j > Bytes.length s - l
+ then invalid_arg "Bytearray.blit_to_bytes"
+ else unsafe_blit_to_bytes a i s j l
external marshal : 'a -> Marshal.extern_flags list -> t
= "ml_marshal_to_bigarray"
--- a/bytearray.mli
+++ b/bytearray.mli
@@ -16,7 +16,9 @@ val sub : t -> int -> int -> string
val blit_from_string : string -> int -> t -> int -> int -> unit
-val blit_to_string : t -> int -> string -> int -> int -> unit
+val blit_from_bytes : bytes -> int -> t -> int -> int -> unit
+
+val blit_to_bytes : t -> int -> bytes -> int -> int -> unit
val prefix : t -> t -> int -> bool
--- a/checksum.ml
+++ b/checksum.ml
@@ -63,3 +63,11 @@ let substring s p l =
cksum := (v lsl 14 - (v + v + v)) (* v * 16381 *)
done;
!cksum land 0x7fffffff
+
+let subbytes s p l =
+ let cksum = ref 0 in
+ for i = p to p + l - 1 do
+ let v = !cksum + Char.code (Bytes.unsafe_get s i) in
+ cksum := (v lsl 14 - (v + v + v)) (* v * 16381 *)
+ done;
+ !cksum land 0x7fffffff
--- a/checksum.mli
+++ b/checksum.mli
@@ -12,6 +12,11 @@ val substring : string
-> int (* substring length *)
-> t
+val subbytes : bytes
+ -> int (* offset in string *)
+ -> int (* substring length *)
+ -> t
+
val roll : u (* string length *)
-> t (* previous checksum *)
-> char (* outgoing char *)
--- a/fileutil.ml
+++ b/fileutil.ml
@@ -28,7 +28,7 @@ let backslashes2forwardslashes s0 =
then Bytes.set s i '/'
else Bytes.set s i c
done;
- s
+ Bytes.to_string s
with Not_found -> s0
let rec removeTrailingSlashes s =
--- a/fingerprint.ml
+++ b/fingerprint.ml
@@ -81,7 +81,7 @@ let toString md5 =
Bytes.set string (2*i) c1;
Bytes.set string (2*i + 1) c2;
done;
- string
+ Bytes.to_string string
end
let string = Digest.string
--- a/fpcache.ml
+++ b/fpcache.ml
@@ -53,6 +53,7 @@ let decompress st i path =
let s = Bytes.create (l + i) in
String.blit !st 0 s 0 i;
String.blit path 0 s i l;
+ let s = Bytes.to_string s in
st := s;
s
@@ -76,19 +77,19 @@ let read st ic =
let headerSize = Marshal.header_size in
let header = Bytes.create headerSize in
really_input ic header 0 headerSize;
- if fp1 <> Digest.string header then begin
+ if fp1 <> Digest.bytes header then begin
debug (fun () -> Util.msg "bad header checksum\n");
raise End_of_file
end;
let dataSize = Marshal.data_size header 0 in
let s = Bytes.create (headerSize + dataSize) in
- String.blit header 0 s 0 headerSize;
+ Bytes.blit header 0 s 0 headerSize;
really_input ic s headerSize dataSize;
- if fp2 <> Digest.string s then begin
+ if fp2 <> Digest.bytes s then begin
debug (fun () -> Util.msg "bad chunk checksum\n");
raise End_of_file
end;
- let q : entry list = Marshal.from_string s 0 in
+ let q : entry list = Marshal.from_bytes s 0 in
debug (fun () -> Util.msg "read chunk of %d files\n" (List.length q));
List.iter (fun (l, p, i) -> PathTbl.add tbl (decompress st l p) i) q
--- a/fsmonitor/linux/inotify.ml
+++ b/fsmonitor/linux/inotify.ml
@@ -94,20 +94,20 @@ let read fd =
let toread = to_read fd in
let ret = ref [] in
- let buf = String.make toread '\000' in
+ let buf = Bytes.make toread '\000' in
let toread = Unix.read fd buf 0 toread in
let read_c_string offset len =
let index = ref 0 in
- while !index < len && buf.[offset + !index] <> '\000' do incr index done;
- String.sub buf offset !index
+ while !index < len && Bytes.get buf (offset + !index) <> '\000' do incr index done;
+ Bytes.sub_string buf offset !index
in
let i = ref 0 in
while !i < toread
do
- let wd, l, cookie, len = convert (String.sub buf !i ss) in
+ let wd, l, cookie, len = convert (Bytes.sub_string buf !i ss) in
let s = if len > 0 then Some (read_c_string (!i + ss) len) else None in
ret := (wd, l, cookie, s) :: !ret;
i := !i + (ss + len);
--- a/fsmonitor/watchercommon.ml
+++ b/fsmonitor/watchercommon.ml
@@ -61,7 +61,7 @@ let quote s =
incr j
end
done;
- q
+ Bytes.to_string q
end
let unquote s =
@@ -88,7 +88,7 @@ let unquote s =
incr j
end
done;
- u
+ Bytes.to_string u
end
let split_on_space s =
@@ -108,6 +108,13 @@ let rec really_write o s pos len =
else
really_write o s (pos + l) (len - l)
+let rec really_write_substring o s pos len =
+ Lwt_unix.write_substring o s pos len >>= fun l ->
+ if l = len then
+ Lwt.return ()
+ else
+ really_write_substring o s (pos + l) (len - l)
+
let format_exc e =
match e with
Unix.Unix_error (code, funct, arg) ->
@@ -126,7 +133,7 @@ let _in = (*Lwt_unix.stdin*) Lwt_unix.of
let _out = (*Lwt_unix.stdout*) Lwt_unix.of_unix_file_descr Unix.stdout
let printf fmt =
- Printf.ksprintf (fun s -> really_write _out s 0 (String.length s)) fmt
+ Printf.ksprintf (fun s -> really_write_substring _out s 0 (String.length s)) fmt
let read_line =
let b = Buffer.create 160 in
@@ -143,15 +150,15 @@ let read_line =
Lwt.return ()
end >>= fun () ->
try
- let i = String.index_from buf !start '\n' in
+ let i = Bytes.index_from buf !start '\n' in
if i >= !last then raise Not_found;
- Buffer.add_substring b buf !start (i - !start);
+ Buffer.add_subbytes b buf !start (i - !start);
start := i + 1;
let s = Buffer.contents b in
Buffer.clear b;
Lwt.return s
with Not_found ->
- Buffer.add_substring b buf !start (!last - !start);
+ Buffer.add_subbytes b buf !start (!last - !start);
start := 0; last := 0;
read_line ()
in
--- a/fspath.ml
+++ b/fspath.ml
@@ -97,7 +97,7 @@ let appleDouble (Fspath f) =
Bytes.set res i '.';
Bytes.set res (i + 1) '_';
String.blit f i res (i + 2) (len - i);
- Fspath res
+ Fspath (Bytes.to_string res)
with Not_found ->
assert false
@@ -196,7 +196,7 @@ let concat fspath path =
String.blit fspath 0 s 0 l;
Bytes.set s l '/';
String.blit p 0 s (l + 1) l';
- Fspath s
+ Fspath (Bytes.to_string s)
end
(* Filename.dirname is screwed up in Windows so we use this function. It *)
--- a/fswatch.ml
+++ b/fswatch.ml
@@ -88,6 +88,13 @@ let rec really_write o s pos len =
else
really_write o s (pos + l) (len - l)
+let rec really_write_substring o s pos len =
+ Lwt_unix.write_substring o s pos len >>= fun l ->
+ if l = len then
+ Lwt.return ()
+ else
+ really_write_substring o s (pos + l) (len - l)
+
let split_on_space s =
try
let i = String.index s ' ' in
@@ -125,7 +132,7 @@ let quote s =
incr j
end
done;
- q
+ Bytes.to_string q
end
let unquote s =
@@ -152,7 +159,7 @@ let unquote s =
incr j
end
done;
- u
+ Bytes.to_string u
end
module Cond = struct
@@ -184,7 +191,7 @@ let printf o fmt =
debugverbose (fun () -> Util.msg "<< %s" s);
Util.convertUnixErrorsToFatal
"sending command to filesystem watcher"
- (fun () -> Lwt_unix.run (really_write o s 0 (String.length s))))
+ (fun () -> Lwt_unix.run (really_write_substring o s 0 (String.length s))))
fmt
let read_line i =
@@ -204,16 +211,16 @@ let read_line i =
Lwt.return ()
end >>= fun () ->
try
- let i = String.index_from buf !start '\n' in
+ let i = Bytes.index_from buf !start '\n' in
if i >= !last then raise Not_found;
- Buffer.add_substring b buf !start (i - !start);
+ Buffer.add_subbytes b buf !start (i - !start);
start := i + 1;
let s = Buffer.contents b in
Buffer.clear b;
debugverbose (fun() -> Util.msg ">> %s\n" s);
Lwt.return s
with Not_found ->
- Buffer.add_substring b buf !start (!last - !start);
+ Buffer.add_subbytes b buf !start (!last - !start);
start := 0; last := 0;
read ()
in
--- a/lwt/generic/lwt_unix_impl.ml
+++ b/lwt/generic/lwt_unix_impl.ml
@@ -170,12 +170,15 @@ let rec run thread =
`Write (buf, pos, len, res) ->
wrap_syscall outputs fd res
(fun () -> Unix.write fd buf pos len)
+ | `WriteSubstring (buf, pos, len, res) ->
+ wrap_syscall outputs fd res
+ (fun () -> Unix.write_substring fd buf pos len)
| `CheckSocket res ->
wrap_syscall outputs fd res
(fun () ->
try ignore (Unix.getpeername fd) with
Unix.Unix_error (Unix.ENOTCONN, _, _) ->
- ignore (Unix.read fd " " 0 1))
+ ignore (Unix.read fd (Bytes.create 1) 0 1))
| `Wait res ->
wrap_syscall inputs fd res (fun () -> ())
with Not_found ->
@@ -231,6 +234,19 @@ let write ch buf pos len =
| e ->
Lwt.fail e
+let write_substring ch buf pos len =
+ try
+ if windows_hack && recent_ocaml then
+ raise (Unix.Unix_error (Unix.EAGAIN, "", ""));
+ Lwt.return (Unix.write_substring ch buf pos len)
+ with
+ Unix.Unix_error ((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
+ let res = Lwt.wait () in
+ outputs := (ch, `WriteSubstring (buf, pos, len, res)) :: !outputs;
+ res
+ | e ->
+ Lwt.fail e
+
(*
let pipe () =
let (in_fd, out_fd) as fd_pair = Unix.pipe() in
@@ -364,7 +380,7 @@ let rec unsafe_really_input ic s ofs len
end
let really_input ic s ofs len =
- if ofs < 0 || len < 0 || ofs > String.length s - len
+ if ofs < 0 || len < 0 || ofs > Bytes.length s - len
then Lwt.fail (Invalid_argument "really_input")
else unsafe_really_input ic s ofs len
@@ -372,9 +388,9 @@ let input_line ic =
let buf = ref (Bytes.create 128) in
let pos = ref 0 in
let rec loop () =
- if !pos = String.length !buf then begin
+ if !pos = Bytes.length !buf then begin
let newbuf = Bytes.create (2 * !pos) in
- String.blit !buf 0 newbuf 0 !pos;
+ Bytes.blit !buf 0 newbuf 0 !pos;
buf := newbuf
end;
Lwt.bind (input_char ic) (fun c ->
@@ -396,8 +412,8 @@ let input_line ic =
Lwt.fail e))
(fun () ->
let res = Bytes.create !pos in
- String.blit !buf 0 res 0 !pos;
- Lwt.return res)
+ Bytes.blit !buf 0 res 0 !pos;
+ Lwt.return (Bytes.to_string res))
(****)
--- a/lwt/lwt_unix.mli
+++ b/lwt/lwt_unix.mli
@@ -34,8 +34,9 @@ type file_descr
val of_unix_file_descr : Unix.file_descr -> file_descr
-val read : file_descr -> string -> int -> int -> int Lwt.t
-val write : file_descr -> string -> int -> int -> int Lwt.t
+val read : file_descr -> bytes -> int -> int -> int Lwt.t
+val write : file_descr -> bytes -> int -> int -> int Lwt.t
+val write_substring : file_descr -> string -> int -> int -> int Lwt.t
val wait_read : file_descr -> unit Lwt.t
val wait_write : file_descr -> unit Lwt.t
val pipe_in : unit -> file_descr * Unix.file_descr
--- a/osx.ml
+++ b/osx.ml
@@ -60,7 +60,7 @@ let doubleVersion = "\000\002\000\000"
let doubleFiller = String.make 16 '\000'
let resource_fork_empty_tag = "This resource fork intentionally left blank "
let finfoLength = 32L
-let emptyFinderInfo () = String.make 32 '\000'
+let emptyFinderInfo () = Bytes.make 32 '\000'
let empty_resource_fork =
"\000\000\001\000" ^
"\000\000\001\000" ^
@@ -132,7 +132,7 @@ let readDouble dataFspath dataPath doubl
with End_of_file ->
fail dataFspath dataPath doubleFspath "truncated"
end;
- buf
+ Bytes.to_string buf
let readDoubleFromOffset dataFspath dataPath doubleFspath inch offset len =
LargeFile.seek_in inch offset;
@@ -220,19 +220,19 @@ let trim s =
trim_rec s (String.length s)
let extractInfo typ info =
- let flags = String.sub info 8 2 in
+ let flags = Bytes.of_string (String.sub info 8 2) in
let xflags = String.sub info 24 2 in
let typeCreator = String.sub info 0 8 in
(* Ignore hasBeenInited flag *)
- Bytes.set flags 0 (Char.chr (Char.code flags.[0] land 0xfe));
+ Bytes.set flags 0 (Char.chr (Char.code (Bytes.get flags 0) land 0xfe));
(* If the extended flags should be ignored, clear them *)
let xflags =
if Char.code xflags.[0] land 0x80 <> 0 then "\000\000" else xflags
in
let info =
match typ with
- `FILE -> "F" ^ typeCreator ^ flags ^ xflags
- | `DIRECTORY -> "D" ^ flags ^ xflags
+ `FILE -> "F" ^ typeCreator ^ Bytes.to_string flags ^ xflags
+ | `DIRECTORY -> "D" ^ Bytes.to_string flags ^ xflags
in
trim info
@@ -269,7 +269,7 @@ let getFileInfos dataFspath dataPath typ
let len = String.length resource_fork_empty_tag in
let buf = Bytes.create len in
really_input inch buf 0 len;
- buf = resource_fork_empty_tag)
+ Bytes.to_string buf = resource_fork_empty_tag)
(fun () -> close_in_noerr inch)
then
(0L, 0L)
@@ -336,7 +336,7 @@ let insertInfo fullInfo info =
String.blit info offset fullInfo 8 2;
(* Extended finder flags *)
String.blit info (offset + 2) fullInfo 24 2;
- fullInfo
+ Bytes.to_string fullInfo
let setFileInfos dataFspath dataPath finfo =
assert (finfo <> "");
@@ -344,7 +344,7 @@ let setFileInfos dataFspath dataPath fin
try
let p = Fspath.toSysPath (Fspath.concat dataFspath dataPath) in
let (fullFinfo, _) = getFileInfosInternal p false in
- setFileInfosInternal p (insertInfo fullFinfo finfo)
+ setFileInfosInternal p (insertInfo (Bytes.of_string fullFinfo) finfo)
with Unix.Unix_error ((Unix.EOPNOTSUPP | Unix.ENOSYS), _, _) ->
(* Not an HFS volume. Look for an AppleDouble file *)
let (workingDir, realPath) = Fspath.findWorkingDir dataFspath dataPath in
@@ -363,6 +363,7 @@ let setFileInfos dataFspath dataPath fin
close_in inch;
res)
(fun () -> close_in_noerr inch)
+ |> Bytes.of_string
in
let outch =
Fs.open_out_gen [Open_wronly; Open_binary] 0o600 doubleFspath in
@@ -517,9 +518,9 @@ let openRessOut fspath path length =
output_string outch "\000\000\000\002"; (* Resource fork *)
output_string outch "\000\000\014\226"; (* offset *)
(* FIX: should check for overflow! *)
- output_string outch (setInt4 (Uutil.Filesize.toInt64 length));
+ output_bytes outch (setInt4 (Uutil.Filesize.toInt64 length));
(* length *)
- output_string outch (emptyFinderInfo ());
+ output_bytes outch (emptyFinderInfo ());
output_string outch (empty_attribute_chunk ());
(* extended attributes *)
flush outch)
--- a/path.ml
+++ b/path.ml
@@ -34,7 +34,7 @@ let concat p p' =
String.blit p 0 p'' 0 l;
Bytes.set p'' l pathSeparatorChar;
String.blit p' 0 p'' (l + 1) l';
- p''
+ Bytes.to_string p''
let empty = ""
@@ -205,7 +205,7 @@ let addPrefixToFinalName path prefix =
String.blit path 0 p 0 i;
String.blit prefix 0 p i l';
String.blit path i p (i + l') (l - i);
- p
+ Bytes.to_string p
with Not_found ->
assert (not (isEmpty path));
prefix ^ path
--- a/remote.ml
+++ b/remote.ml
@@ -116,7 +116,7 @@ let emittedBytes = ref 0.
type ioBuffer =
{ channel : Lwt_unix.file_descr;
- buffer : string;
+ buffer : bytes;
mutable length : int;
mutable opened : bool }
@@ -142,7 +142,7 @@ let fillInputBuffer conn =
Util.msg "grab: EOF\n"
else
Util.msg "grab: %s\n"
- (String.escaped (String.sub conn.buffer 0 len)));
+ (String.escaped (Bytes.sub_string conn.buffer 0 len)));
if len = 0 then
lostConnection ()
else begin
@@ -157,10 +157,10 @@ let rec grabRec conn s pos len =
grabRec conn s pos len
end else begin
let l = min (len - pos) conn.length in
- Bytearray.blit_from_string conn.buffer 0 s pos l;
+ Bytearray.blit_from_bytes conn.buffer 0 s pos l;
conn.length <- conn.length - l;
if conn.length > 0 then
- String.blit conn.buffer l conn.buffer 0 conn.length;
+ Bytes.blit conn.buffer l conn.buffer 0 conn.length;
if pos + l < len then
grabRec conn s (pos + l) len
else
@@ -173,7 +173,7 @@ let grab conn s len =
grabRec conn s 0 len
let peekWithoutBlocking conn =
- String.sub conn.buffer 0 conn.length
+ Bytes.sub conn.buffer 0 conn.length
(****)
@@ -189,11 +189,11 @@ let rec sendOutput conn =
end >>= fun len ->
debugV (fun() ->
Util.msg "dump: %s\n"
- (String.escaped (String.sub conn.buffer 0 len)));
+ (String.escaped (Bytes.sub_string conn.buffer 0 len)));
emittedBytes := !emittedBytes +. float len;
conn.length <- conn.length - len;
if conn.length > 0 then
- String.blit
+ Bytes.blit
conn.buffer len conn.buffer 0 conn.length;
Lwt.return ())
@@ -203,7 +203,7 @@ let rec fillBuffer2 conn s pos len =
fillBuffer2 conn s pos len
else begin
let l = min (len - pos) (bufferSize - conn.length) in
- Bytearray.blit_to_string s pos conn.buffer conn.length l;
+ Bytearray.blit_to_bytes s pos conn.buffer conn.length l;
conn.length <- conn.length + l;
if pos + l < len then
fillBuffer2 conn s (pos + l) len
@@ -950,7 +950,7 @@ let rec checkHeader conn buffer pos len
expected \""
^ String.escaped (* (String.sub connectionHeader 0 (pos + 1)) *)
connectionHeader
- ^ "\" but received \"" ^ String.escaped (prefix ^ rest) ^ "\", \n"
+ ^ "\" but received \"" ^ String.escaped (prefix ^ Bytes.to_string rest) ^ "\", \n"
^ "which differs at \"" ^ String.escaped prefix ^ "\".\n"
^ "This can happen because you have different versions of Unison\n"
^ "installed on the client and server machines, or because\n"
@@ -1366,7 +1366,7 @@ let openConnectionReply = function
(i1,i2,o1,o2,s,Some fdTerm,clroot,pid) ->
(fun response ->
(* FIX: should loop until everything is written... *)
- ignore (Lwt_unix.run (Lwt_unix.write fdTerm (response ^ "\n") 0
+ ignore (Lwt_unix.run (Lwt_unix.write fdTerm (Bytes.of_string (response ^ "\n")) 0
(String.length response + 1))))
| _ -> (fun _ -> ())
--- a/terminal.ml
+++ b/terminal.ml
@@ -229,7 +229,7 @@ let rec termInput fdTerm fdInput =
(* The remote end is dead *)
Lwt.return None
else
- let query = String.sub buf 0 len in
+ let query = Bytes.sub_string buf 0 len in
if query = "\r\n" then
readPrompt ()
else
@@ -251,12 +251,12 @@ let handlePasswordRequests fdTerm callba
(* The remote end is dead *)
Lwt.return ()
else
- let query = String.sub buf 0 len in
+ let query = Bytes.sub_string buf 0 len in
if query = "\r\n" then
loop ()
else begin
let response = callback query in
- Lwt_unix.write fdTerm
+ Lwt_unix.write_substring fdTerm
(response ^ "\n") 0 (String.length response + 1)
>>= (fun _ ->
loop ())
--- a/test.ml
+++ b/test.ml
@@ -131,7 +131,7 @@ let readfs p =
let rec loop p =
let s = Fs.lstat p in
match s.Unix.LargeFile.st_kind with
- | Unix.S_REG -> File (read p)
+ | Unix.S_REG -> File (Bytes.to_string (read p))
| Unix.S_LNK -> Link (Fs.readlink p)
| Unix.S_DIR -> Dir (Safelist.map (fun x -> (x, loop (extend p x))) (read_dir p))
| _ -> assert false
--- a/transfer.ml
+++ b/transfer.ml
@@ -75,6 +75,9 @@ let reallyRead infd buffer pos length =
let rec reallyWrite outfd buffer pos length =
output outfd buffer pos length
+let rec reallyWriteSubstring outfd buffer pos length =
+ output_substring outfd buffer pos length
+
(*************************************************************************)
(* TOKEN QUEUE *)
(*************************************************************************)
@@ -89,7 +92,7 @@ let rec reallyWrite outfd buffer pos len
(2 * comprBufSize + tokenQueueLimit) bytes at a time) *)
type token =
- | STRING of string * int * int
+ | STRING of bytes * int * int
| BLOCK of int
| EOF
@@ -167,7 +170,7 @@ let rec pushString q id transmit s pos l
assert (l > 0);
q.data.{q.pos} <- 'S';
encodeInt2 q.data (q.pos + 1) l;
- Bytearray.blit_from_string s pos q.data (q.pos + 3) l;
+ Bytearray.blit_from_bytes s pos q.data (q.pos + 3) l;
q.pos <- q.pos + l + 3;
q.prog <- q.prog + l;
q.previous <- `Str l;
@@ -182,7 +185,7 @@ let growString q id transmit len' s pos
Util.msg "growing string (pos:%d/%d len:%d+%d)\n"
q.pos queueSize len' len);
let l = min (queueSize - q.pos) len in
- Bytearray.blit_from_string s pos q.data q.pos l;
+ Bytearray.blit_from_bytes s pos q.data q.pos l;
assert (q.pos - len' - 3 >= 0);
assert (q.data.{q.pos - len' - 3} = 'S');
assert (decodeInt2 q.data (q.pos - len' - 2) = len');
@@ -292,7 +295,7 @@ let rec receiveRec outfd showProgress da
let length = decodeInt2 data (pos + 1) in
if Trace.enabled "generic" then debug (fun() -> Util.msg
"receiving %d bytes\n" length);
- reallyWrite outfd (Bytearray.sub data (pos + 3) length) 0 length;
+ reallyWriteSubstring outfd (Bytearray.sub data (pos + 3) length) 0 length;
showProgress length;
receiveRec outfd showProgress data (pos + length + 3) maxPos
| 'E' ->
@@ -384,7 +387,7 @@ struct
iter (count + 1) newOffset length
end else if offset > 0 then begin
let chunkSize = length - offset in
- String.blit buffer offset buffer 0 chunkSize;
+ Bytes.blit buffer offset buffer 0 chunkSize;
iter count 0 chunkSize
end else begin
let l = input infd buffer length (bufferSize - length) in
@@ -410,9 +413,9 @@ struct
Bigarray.Array1.create Bigarray.int32 Bigarray.c_layout blockCount in
let strongCs = Bytearray.create (blockCount * csSize) in
let addBlock i buf offset =
- weakCs.{i} <- Int32.of_int (Checksum.substring buf offset blockSize);
+ weakCs.{i} <- Int32.of_int (Checksum.subbytes buf offset blockSize);
Bytearray.blit_from_string
- (Digest.substring buf offset blockSize) 0 strongCs (i * csSize) csSize
+ (Digest.subbytes buf offset blockSize) 0 strongCs (i * csSize) csSize
in
(* Make sure we are at the beginning of the file
(important for AppleDouble files *)
@@ -480,7 +483,7 @@ struct
if Trace.enabled "rsynctoken" then
debugToken (fun() ->
Util.msg "decompressing string (%d bytes)\n" length);
- reallyWrite outfd (Bytearray.sub data (pos + 3) length) 0 length;
+ reallyWriteSubstring outfd (Bytearray.sub data (pos + 3) length) 0 length;
progress := !progress + length;
decode (pos + length + 3)
| 'B' ->
@@ -540,16 +543,16 @@ struct
let sigFilter hashTableLength signatures =
let len = hashTableLength lsl 2 in
- let filter = String.make len '\000' in
+ let filter = Bytes.make len '\000' in
for k = 0 to signatures.blockCount - 1 do
let cs = Int32.to_int signatures.weakChecksum.{k} land 0x7fffffff in
let h1 = cs lsr 28 in
assert (h1 >= 0 && h1 < 8);
let h2 = (cs lsr 5) land (len - 1) in
let mask = 1 lsl h1 in
- Bytes.set filter h2 (Char.chr (Char.code filter.[h2] lor mask))
+ Bytes.set filter h2 (Char.chr (Char.code (Bytes.get filter h2) lor mask))
done;
- filter
+ Bytes.to_string filter
let filterMem filter hashTableLength checksum =
let len = hashTableLength lsl 2 in
@@ -741,7 +744,7 @@ struct
let chunkSize = st.length - st.offset in
if chunkSize > 0 then begin
assert(comprBufSize >= blockSize);
- String.blit comprBuf st.offset comprBuf 0 chunkSize
+ Bytes.blit comprBuf st.offset comprBuf 0 chunkSize
end;
let rem = Uutil.Filesize.sub srcLength st.absolutePos in
let avail = comprBufSize - chunkSize in
@@ -768,19 +771,19 @@ struct
if miss then
rollChecksum st
else begin
- let cksum = Checksum.substring comprBuf st.offset blockSize in
+ let cksum = Checksum.subbytes comprBuf st.offset blockSize in
st.checksum <- cksum;
- st.cksumOutgoing <- String.unsafe_get comprBuf st.offset;
+ st.cksumOutgoing <- Bytes.unsafe_get comprBuf st.offset;
processBlock st
end
and rollChecksum st =
let ingoingChar =
- String.unsafe_get comprBuf (st.offset + blockSize - 1) in
+ Bytes.unsafe_get comprBuf (st.offset + blockSize - 1) in
let cksum =
Checksum.roll cksumTable st.checksum st.cksumOutgoing ingoingChar in
st.checksum <- cksum;
- st.cksumOutgoing <- String.unsafe_get comprBuf st.offset;
+ st.cksumOutgoing <- Bytes.unsafe_get comprBuf st.offset;
if filterMem filter hashTableLength cksum then
processBlock st
else
@@ -811,7 +814,7 @@ struct
-1
| (k, cs) :: tl, None
when cs = checksum ->
- let fingerprint = Digest.substring comprBuf st.offset blockSize in
+ let fingerprint = Digest.subbytes comprBuf st.offset blockSize in
findBlock st checksum entry (Some fingerprint)
| (k, cs) :: tl, Some fingerprint
when cs = checksum && fingerprintMatch k fingerprint ->
--- a/uicommon.ml
+++ b/uicommon.ml
@@ -367,7 +367,7 @@ let quote s =
| c ->
Bytes.set buf !pos c; pos := !pos + 1
done;
- "{" ^ String.sub buf 0 !pos ^ "}"
+ "{" ^ Bytes.sub_string buf 0 !pos ^ "}"
let ignorePath path = "Path " ^ quote (Path.toString path)
--- a/uigtk2.ml
+++ b/uigtk2.ml
@@ -94,7 +94,7 @@ let icon =
let icon =
let p = GdkPixbuf.create ~width:48 ~height:48 ~has_alpha:true () in
Gpointer.blit
- (Gpointer.region_of_bytes Pixmaps.icon_data) (GdkPixbuf.get_pixels p);
+ (Gpointer.region_of_bytes (Bytes.of_string Pixmaps.icon_data)) (GdkPixbuf.get_pixels p);
p
let leftPtrWatch =
--- a/uitext.ml
+++ b/uitext.ml
@@ -113,8 +113,8 @@ let getInput () =
let s = Bytes.create 1 in
let n = Unix.read Unix.stdin s 0 1 in
if n = 0 then raise End_of_file;
- if s.[0] = '\003' then raise Sys.Break;
- s.[0]
+ if Bytes.get s 0 = '\003' then raise Sys.Break;
+ Bytes.get s 0
in
funs.System.startReading ();
let c = input_char () in
--- a/unicode.ml
+++ b/unicode.ml
@@ -21,9 +21,11 @@ exception Invalid
let fail () = raise Invalid
-let get s i = Char.code (String.unsafe_get s i)
+let get s i = Char.code (Bytes.unsafe_get s i)
let set s i v = Bytes.unsafe_set s i (Char.unsafe_chr v)
+let string_get s i = Char.code (String.unsafe_get s i)
+
(****)
let rec decode_char s i l =
@@ -773,9 +775,9 @@ let combining_property_bitmap = "\
let combining_class c =
if c > 0xffff then 0 else
- let v = get combining_property_bitmap (c lsr 8) in
+ let v = string_get combining_property_bitmap (c lsr 8) in
if v = 0 then 0 else
- get combining_property_bitmap (v lsl 8 + c land 0xff)
+ string_get combining_property_bitmap (v lsl 8 + c land 0xff)
let rec find_loc s i l p =
if i = 0 then i else
@@ -818,14 +820,14 @@ and cont s i l j p v =
(* move char to the right location *)
let k = find_loc s i l p' in
let d = j - i in
- let s' = String.sub s i d in
- String.blit s k s (k + d) (i - k);
- String.blit s' 0 s k d;
+ let s' = Bytes.sub s i d in
+ Bytes.blit s k s (k + d) (i - k);
+ Bytes.blit s' 0 s k d;
scan s j l p
end
let order s =
- scan s 0 (String.length s) 0
+ scan s 0 (Bytes.length s) 0
(****)
@@ -847,40 +849,40 @@ let set_char_3 s i c =
let rec norm s i l s' j =
if i < l then begin
- let c = get s i in
+ let c = string_get s i in
if c < 0x80 then begin
- set s' j (get norm_ascii c);
+ set s' j (string_get norm_ascii c);
norm s (i + 1) l s' (j + 1)
end else if c < 0xE0 then begin
(* 80 - 7FF *)
if c < 0xc2 || i + 1 >= l then raise Invalid;
- let c1 = get s (i + 1) in
+ let c1 = string_get s (i + 1) in
if c1 land 0xc0 <> 0x80 then raise Invalid;
- let idx = get norm_prim (c - 0xc0) in
+ let idx = string_get norm_prim (c - 0xc0) in
let idx = idx lsl 6 + c1 - 0x80 in
- let k = get norm_second_high idx in
+ let k = string_get norm_second_high idx in
if k = 0 then begin
set s' j c;
set s' (j + 1) c1;
norm s (i + 2) l s' (j + 2)
end else begin
- let k = (k - 2) lsl 8 + get norm_second_low idx in
- let n = get norm_repl k in
+ let k = (k - 2) lsl 8 + string_get norm_second_low idx in
+ let n = string_get norm_repl k in
String.blit norm_repl (k + 1) s' j n;
norm s (i + 2) l s' (j + n)
end
end else if c < 0xF0 then begin
(* 800 - FFFF *)
if i + 2 >= l then raise Invalid;
- let c1 = get s (i + 1) in
+ let c1 = string_get s (i + 1) in
if c1 land 0xc0 <> 0x80 then raise Invalid;
let idx = c lsl 6 + c1 - 0x3880 in
if idx < 0x20 then raise Invalid;
- let c2 = get s (i + 2) in
+ let c2 = string_get s (i + 2) in
if c2 land 0xc0 <> 0x80 then raise Invalid;
- let idx = get norm_prim idx in
+ let idx = string_get norm_prim idx in
let idx = idx lsl 6 + c2 - 0x80 in
- let k = get norm_second_high idx in
+ let k = string_get norm_second_high idx in
if k = 0 then begin
set s' j c;
set s' (j + 1) c1;
@@ -905,17 +907,17 @@ let rec norm s i l s' j =
end
end
end else begin
- let k = (k - 2) lsl 8 + get norm_second_low idx in
- let n = get norm_repl k in
+ let k = (k - 2) lsl 8 + string_get norm_second_low idx in
+ let n = string_get norm_repl k in
String.blit norm_repl (k + 1) s' j n;
norm s (i + 3) l s' (j + n)
end
end else begin
(* 10000 - 10FFFF *)
if i + 3 >= l then raise Invalid;
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
- let c3 = get s (i + 3) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
+ let c3 = string_get s (i + 3) in
if (c1 lor c2 lor c3) land 0xc0 <> 0x80 then raise Invalid;
let v = c lsl 18 + c1 lsl 12 + c2 lsl 6 + c3 - 0x03c82080 in
if v < 0x10000 || v > 0x10ffff then raise Invalid;
@@ -926,13 +928,13 @@ let rec norm s i l s' j =
norm s (i + 4) l s' (j + 4)
end
end else
- String.sub s' 0 j
+ Bytes.sub s' 0 j
let normalize s =
let l = String.length s in
let s' = Bytes.create (3 * l) in
try
- let s' = norm s 0 l s' 0 in order s'; s'
+ let s' = norm s 0 l s' 0 in order s'; Bytes.to_string s'
with Invalid ->
(* We need a comparison function which is coherent (transitive)
also with non-unicode strings. The optimization below assumes
@@ -944,40 +946,40 @@ let normalize s =
let rec decomp s i l s' j =
if i < l then begin
- let c = get s i in
+ let c = string_get s i in
if c < 0x80 then begin
- set s' j (get decomp_ascii c);
+ set s' j (string_get decomp_ascii c);
decomp s (i + 1) l s' (j + 1)
end else if c < 0xE0 then begin
(* 80 - 7FF *)
if c < 0xc2 || i + 1 >= l then raise Invalid;
- let c1 = get s (i + 1) in
+ let c1 = string_get s (i + 1) in
if c1 land 0xc0 <> 0x80 then raise Invalid;
- let idx = get decomp_prim (c - 0xc0) in
+ let idx = string_get decomp_prim (c - 0xc0) in
let idx = idx lsl 6 + c1 - 0x80 in
- let k = get decomp_second_high idx in
+ let k = string_get decomp_second_high idx in
if k = 0 then begin
set s' j c;
set s' (j + 1) c1;
decomp s (i + 2) l s' (j + 2)
end else begin
- let k = (k - 2) lsl 8 + get decomp_second_low idx in
- let n = get decomp_repl k in
+ let k = (k - 2) lsl 8 + string_get decomp_second_low idx in
+ let n = string_get decomp_repl k in
String.blit decomp_repl (k + 1) s' j n;
decomp s (i + 2) l s' (j + n)
end
end else if c < 0xF0 then begin
(* 800 - FFFF *)
if i + 2 >= l then raise Invalid;
- let c1 = get s (i + 1) in
+ let c1 = string_get s (i + 1) in
if c1 land 0xc0 <> 0x80 then raise Invalid;
let idx = c lsl 6 + c1 - 0x3880 in
if idx < 0x20 then raise Invalid;
- let c2 = get s (i + 2) in
+ let c2 = string_get s (i + 2) in
if c2 land 0xc0 <> 0x80 then raise Invalid;
- let idx = get decomp_prim idx in
+ let idx = string_get decomp_prim idx in
let idx = idx lsl 6 + c2 - 0x80 in
- let k = get decomp_second_high idx in
+ let k = string_get decomp_second_high idx in
if k = 0 then begin
set s' j c;
set s' (j + 1) c1;
@@ -1002,17 +1004,17 @@ let rec decomp s i l s' j =
end
end
end else begin
- let k = (k - 2) lsl 8 + get decomp_second_low idx in
- let n = get decomp_repl k in
+ let k = (k - 2) lsl 8 + string_get decomp_second_low idx in
+ let n = string_get decomp_repl k in
String.blit decomp_repl (k + 1) s' j n;
decomp s (i + 3) l s' (j + n)
end
end else begin
(* 10000 - 10FFFF *)
if i + 3 >= l then raise Invalid;
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
- let c3 = get s (i + 3) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
+ let c3 = string_get s (i + 3) in
if (c1 lor c2 lor c3) land 0xc0 <> 0x80 then raise Invalid;
let v = c lsl 18 + c1 lsl 12 + c2 lsl 6 + c3 - 0x03c82080 in
if v < 0x10000 || v > 0x10ffff then raise Invalid;
@@ -1023,13 +1025,13 @@ let rec decomp s i l s' j =
decomp s (i + 4) l s' (j + 4)
end
end else
- String.sub s' 0 j
+ Bytes.sub s' 0 j
let decompose s =
let l = String.length s in
let s' = Bytes.create (3 * l) in
try
- let s' = decomp s 0 l s' 0 in order s'; s'
+ let s' = decomp s 0 l s' 0 in order s'; Bytes.to_string s'
with Invalid ->
s
@@ -1041,10 +1043,10 @@ let rec compare_rec s s' i l =
if l < String.length s' then -1 else
0
end else begin
- let c = get s i in
- let c' = get s' i in
+ let c = string_get s i in
+ let c' = string_get s' i in
if c < 0x80 && c' < 0x80 then begin
- let v = compare (get norm_ascii c) (get norm_ascii c') in
+ let v = compare (string_get norm_ascii c) (string_get norm_ascii c') in
if v <> 0 then v else compare_rec s s' (i + 1) l
end else
compare (normalize s) (normalize s')
@@ -1061,8 +1063,8 @@ let rec compare_cs_rec s s' i l =
if l < String.length s' then -1 else
0
end else begin
- let c = get s i in
- let c' = get s' i in
+ let c = string_get s i in
+ let c' = string_get s' i in
if c < 0x80 && c' < 0x80 then begin
let v = compare c c' in
if v <> 0 then v else compare_cs_rec s s' (i + 1) l
@@ -1457,12 +1459,12 @@ let uniCharCombiningBitmap = "\
let bitmap_test base bitmap character =
character >= base && character < 0x10000
&&
- (let value = get bitmap ((character lsr 8) land 0xFF) in
+ (let value = string_get bitmap ((character lsr 8) land 0xFF) in
value = 0xFF
||
(value <> 0
&&
- get bitmap ((value - 1) * 32 + 256 + (character land 0xFF) / 8)
+ string_get bitmap ((value - 1) * 32 + 256 + (character land 0xFF) / 8)
land (1 lsl (character land 7)) <> 0))
let unicode_combinable character =
@@ -1547,8 +1549,8 @@ let rec scan d s i l =
end
end else begin
let (i1, i2) = d in
- String.blit s i2 s i1 (l - i2);
- String.sub s 0 (i1 + l - i2)
+ Bytes.blit s i2 s i1 (l - i2);
+ Bytes.sub s 0 (i1 + l - i2)
end
and cont d s i l j v' =
@@ -1560,7 +1562,7 @@ and cont d s i l j v' =
scan d s j l
else begin
let (i1, i2) = d in
- String.blit s i2 s i1 (i - i2);
+ Bytes.blit s i2 s i1 (i - i2);
let i1 = i1 + i - i2 in
let (v'', i) = compose_rec s j l v'' in
let i1 = encode_char s i1 l v'' in
@@ -1584,7 +1586,7 @@ and compose_rec s i l v =
(v, i)
let compose s =
- try scan (0, 0) (Bytes.copy s) 0 (String.length s) with Invalid -> s
+ try Bytes.to_string (scan (0, 0) (Bytes.of_string s) 0 (String.length s)) with Invalid -> s
(***)
@@ -1592,25 +1594,25 @@ let set_2 s i v =
set s i (v land 0xff);
set s (i + 1) (v lsr 8)
-let get_2 s i = (get s (i + 1)) lsl 8 + get s i
+let get_2 s i = (string_get s (i + 1)) lsl 8 + string_get s i
let rec scan s' j s i l =
if i < l then begin
- let c = get s i in
+ let c = string_get s i in
if c < 0x80 then
cont s' j s (i + 1) l c
else if c < 0xE0 then begin
(* 80 - 7FF *)
if c < 0xc2 || i + 1 >= l then fail () else
- let c1 = get s (i + 1) in
+ let c1 = string_get s (i + 1) in
if c1 land 0xc0 <> 0x80 then fail () else
let v = c lsl 6 + c1 - 0x3080 in
cont s' j s (i + 2) l v
end else if c < 0xF0 then begin
(* 800 - FFFF *)
if i + 2 >= l then fail () else
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
if (c1 lor c2) land 0xc0 <> 0x80 then fail () else
let v = c lsl 12 + c1 lsl 6 + c2 - 0xe2080 in
if v < 0x800 then fail () else
@@ -1618,9 +1620,9 @@ let rec scan s' j s i l =
end else begin
(* 10000 - 10FFFF *)
if i + 3 >= l then fail () else
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
- let c3 = get s (i + 3) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
+ let c3 = string_get s (i + 3) in
if (c1 lor c2 lor c3) land 0xc0 <> 0x80 then fail () else
let v = c lsl 18 + c1 lsl 12 + c2 lsl 6 + c3 - 0x03c82080 in
if v < 0x10000 || v > 0x10ffff then fail () else
@@ -1630,7 +1632,7 @@ let rec scan s' j s i l =
scan s' (j + 4) s (i + 4) l
end
end else
- String.sub s' 0 (j + 2)
+ Bytes.sub s' 0 (j + 2)
and cont s' j s i l v =
set_2 s' j v;
@@ -1638,8 +1640,8 @@ and cont s' j s i l v =
let to_utf_16 s =
let l = String.length s in
- let s' = String.make (2 * l + 2) '\000' in
- scan s' 0 s 0 l
+ let s' = Bytes.make (2 * l + 2) '\000' in
+ Bytes.to_string (scan s' 0 s 0 l)
(***)
@@ -1665,13 +1667,13 @@ let set_2 s i v =
set s i (v land 0xff);
set s (i + 1) (v lsr 8)
-let get_2 s i = (get s (i + 1)) lsl 8 + get s i
+let get_2 s i = (string_get s (i + 1)) lsl 8 + string_get s i
-let end_of_name s i l = let i' = i + 1 in i' = l || get s i' = 0x2f (*'/'*)
+let end_of_name s i l = let i' = i + 1 in i' = l || string_get s i' = 0x2f (*'/'*)
let rec scan s' j s i l =
if i < l then begin
- let c = get s i in
+ let c = string_get s i in
if c < 0x80 then
cont s' j s (i + 1) l
(if c = 0x20 && end_of_name s i l then 0xf028
@@ -1680,15 +1682,15 @@ let rec scan s' j s i l =
else if c < 0xE0 then begin
(* 80 - 7FF *)
if c < 0xc2 || i + 1 >= l then fail () else
- let c1 = get s (i + 1) in
+ let c1 = string_get s (i + 1) in
if c1 land 0xc0 <> 0x80 then fail () else
let v = c lsl 6 + c1 - 0x3080 in
cont s' j s (i + 2) l v
end else if c < 0xF0 then begin
(* 800 - FFFF *)
if i + 2 >= l then fail () else
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
if (c1 lor c2) land 0xc0 <> 0x80 then fail () else
let v = c lsl 12 + c1 lsl 6 + c2 - 0xe2080 in
if v < 0x800 then fail () else
@@ -1696,9 +1698,9 @@ let rec scan s' j s i l =
end else begin
(* 10000 - 10FFFF *)
if i + 3 >= l then fail () else
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
- let c3 = get s (i + 3) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
+ let c3 = string_get s (i + 3) in
if (c1 lor c2 lor c3) land 0xc0 <> 0x80 then fail () else
let v = c lsl 18 + c1 lsl 12 + c2 lsl 6 + c3 - 0x03c82080 in
if v < 0x10000 || v > 0x10ffff then fail () else
@@ -1708,7 +1710,7 @@ let rec scan s' j s i l =
scan s' (j + 4) s (i + 4) l
end
end else
- String.sub s' 0 (j + 2)
+ Bytes.sub s' 0 (j + 2)
and cont s' j s i l v =
set_2 s' j v;
@@ -1716,8 +1718,8 @@ and cont s' j s i l v =
let to_utf_16_filename s =
let l = String.length s in
- let s' = String.make (2 * l + 2) '\000' in
- scan s' 0 s 0 l
+ let s' = Bytes.make (2 * l + 2) '\000' in
+ Bytes.to_string (scan s' 0 s 0 l)
(****)
@@ -1725,7 +1727,7 @@ let rec scan s' i' l' s i l =
if i + 2 <= l then begin
let v = get_2 s i in
if v = 0 then
- String.sub s' 0 i' (* null *)
+ Bytes.sub s' 0 i' (* null *)
else if v < 0xD800 || v > 0xDFFF then
let i' = encode_char s' i' l' v in
scan s' i' l' s (i + 2) l
@@ -1748,13 +1750,13 @@ let rec scan s' i' l' s i l =
end else if i < l then
fail () (* Odd number of chars *)
else
- String.sub s' 0 i'
+ Bytes.sub s' 0 i'
let from_utf_16 s =
let l = String.length s in
let l' = 3 * l / 2 in
let s' = Bytes.create l' in
- scan s' 0 l' s 0 l
+ Bytes.to_string (scan s' 0 l' s 0 l)
(****)
@@ -1772,7 +1774,7 @@ let rec scan s' i' l' s i l =
if i + 2 <= l then begin
let v = get_2 s i in
if v = 0 then
- String.sub s' 0 i' (* null *)
+ Bytes.sub s' 0 i' (* null *)
else if v < 0xD800 then
let i' = encode_char s' i' l' v in
scan s' i' l' s (i + 2) l
@@ -1781,7 +1783,7 @@ let rec scan s' i' l' s i l =
if v > 0xf000 && v <= 0xf029 then
if v = 0xf028 && end_of_name s i l then 0x20
else if v = 0xf029 && end_of_name s i l then 0x2e
- else get sfm_decode (v - 0xf000)
+ else string_get sfm_decode (v - 0xf000)
else
v
in
@@ -1806,7 +1808,7 @@ let rec scan s' i' l' s i l =
end else if i < l then
fail () (* Odd number of chars *)
else
- String.sub s' 0 i'
+ Bytes.sub s' 0 i'
(* NOTE: we MUST have to_utf_16_filename (from_utf_16 s) = s for any
Windows valid filename s *)
@@ -1814,26 +1816,26 @@ let from_utf_16_filename s =
let l = String.length s in
let l' = 3 * l / 2 in
let s' = Bytes.create l' in
- scan s' 0 l' s 0 l
+ Bytes.to_string (scan s' 0 l' s 0 l)
(****)
let rec scan s i l =
i = l ||
- let c = get s i in
+ let c = string_get s i in
if c < 0x80 then
c <> 0 && scan s (i + 1) l
else if c < 0xE0 then begin
(* 80 - 7FF *)
c >= 0xc2 && i + 1 < l &&
- let c1 = get s (i + 1) in
+ let c1 = string_get s (i + 1) in
c1 land 0xc0 = 0x80 &&
scan s (i + 2) l
end else if c < 0xF0 then begin
(* 800 - FFFF *)
i + 2 < l &&
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
(c1 lor c2) land 0xc0 = 0x80 &&
let v = c lsl 12 + c1 lsl 6 + c2 - 0xe2080 in
v >= 0x800 && (v < 0xd800 || (v > 0xdfff && v <> 0xfffe && v <> 0xffff)) &&
@@ -1841,9 +1843,9 @@ let rec scan s i l =
end else begin
(* 10000 - 10FFFF *)
i + 3 < l &&
- let c1 = get s (i + 1) in
- let c2 = get s (i + 2) in
- let c3 = get s (i + 3) in
+ let c1 = string_get s (i + 1) in
+ let c2 = string_get s (i + 2) in
+ let c3 = string_get s (i + 3) in
(c1 lor c2 lor c3) land 0xc0 = 0x80 &&
let v = c lsl 18 + c1 lsl 12 + c2 lsl 6 + c3 - 0x03c82080 in
v >= 0x10000 && v <= 0x10ffff &&
Reference in New Issue Copy Permalink